1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
implementation module Sil.Compile
import StdEnum
from StdFunc import o
import StdList
import StdString
import Control.Applicative
import Control.Monad
import Control.Monad.RWST
import Control.Monad.Trans
import Data.Error
from Data.Func import $
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
from Text import <+
import qualified ABC.Assembler as ABC
import Sil.Syntax
import Sil.Util
instance toString CompileError
where
toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
toString VariableLabel = "Variable stored at label."
toString FunctionOnStack = "Function stored on the stack."
toString UnknownError = "Unknown error."
compile :: Program -> MaybeError CompileError 'ABC'.Assembler
compile prog = case evalRWST (gen prog) () zero of
Error e -> Error e
Ok (_,p) -> Ok p
:: Address :== Int
:: FunctionSymbol =
{ fs_arity :: Int
}
:: CompileState =
{ labels :: ['ABC'.Label]
, addresses :: 'M'.Map Name Address
, symbols :: 'M'.Map Name FunctionSymbol
, returns :: ['ABC'.Assembler]
, stackoffset :: Int
}
instance zero CompileState
where
zero =
{ labels = ["_l" <+ i \\ i <- [0..]]
, addresses = 'M'.newMap
, symbols = 'M'.newMap
, returns = []
, stackoffset = 0
}
labels :: CompileState -> ['ABC'.Label]
labels cs = cs.labels
addresses :: CompileState -> 'M'.Map Name Address
addresses cs = cs.addresses
symbols :: CompileState -> 'M'.Map Name FunctionSymbol
symbols cs = cs.symbols
newReturn :: 'ABC'.Assembler CompileState -> CompileState
newReturn ret cs = {cs & returns=[ret:cs.returns]}
addToReturn :: 'ABC'.Assembler CompileState -> CompileState
addToReturn ret cs=:{returns=[r:rs]} = {cs & returns=[ret ++ r:rs]}
removeFromReturn :: Int CompileState -> CompileState
removeFromReturn i cs=:{returns=[r:rs]} = {cs & returns=[drop i r:rs]}
popReturn :: CompileState -> CompileState
popReturn cs = {cs & returns=tl cs.returns}
peekReturn :: CompileState -> 'ABC'.Assembler
peekReturn cs = hd cs.returns
stackoffset :: CompileState -> Int
stackoffset cs = cs.stackoffset
:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
fresh :: Gen 'ABC'.Label
fresh = gets labels
>>= \labs -> modify (\cs -> {cs & labels=tl labs})
*> pure (hd labs)
reserveVar :: Int Name -> Gen Int
reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name {fs_arity=length f.f_args} cs.symbols})
cleanup :: Gen ()
cleanup = gets peekReturn >>= tell
growStack :: Int -> Gen ()
growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})
shrinkStack :: (Int -> Gen ())
shrinkStack = growStack o ((-) 0)
class gen a :: a -> Gen ()
instance gen Program
where
gen p =
tell [ 'ABC'.Annotation $ 'ABC'.RawAnnot ["comp", "920", "01011101001"]
, 'ABC'.Annotation $ 'ABC'.RawAnnot ["start", "__sil_boot"]
, 'ABC'.Annotation $ 'ABC'.RawAnnot ["endinfo"]
, 'ABC'.Annotation $ 'ABC'.RawAnnot ["module", "m_sil_compiled", "\"sil_compiled\""]
, 'ABC'.Label "__sil_boot"
, 'ABC'.Create
, 'ABC'.Fill "_" 0 "main" 0
, 'ABC'.Jmp "_driver"
] *>
mapM_ addFunction p.p_funs *>
mapM_ gen p.p_funs
instance gen Function
where
gen f =
tell [ 'ABC'.Annotation $ 'ABC'.OAnnot args []
, 'ABC'.Label f.f_name
] *>
foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
modify (newReturn cleanup) *>
gen f.f_code *>
modify popReturn
where
cleanup = case f.f_args of
[] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
]
_ -> [ 'ABC'.Comment "Cleanup"
, 'ABC'.Update_a 0 args
, 'ABC'.Pop_a args
, 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
]
args = length f.f_args
locals = length f.f_code.cb_init
instance gen CodeBlock
where
gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
mapM_ gen cb.cb_init *>
modify (addToReturn cleanup`) *>
mapM_ gen cb.cb_content *>
cleanup *>
tell ['ABC'.Rtn] *>
modify (removeFromReturn $ length cleanup`)
where
cleanup` = case cb.cb_init of
[] -> []
_ -> [ 'ABC'.Update_a 0 locals
, 'ABC'.Pop_a locals
]
locals = length cb.cb_init
instance gen Initialisation
where
gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]
instance gen Statement
where
gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just i -> comment (toString st) *> gen app *>
tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1]
_ -> liftT $ Error $ UndefinedName n
gen (Application app) = comment "Application" *> gen app *> tell ['ABC'.Pop_a 1]
gen (Return (Just app)) = comment "Return" *> gen app *> cleanup *> tell ['ABC'.Rtn]
gen (Return Nothing) = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
gen (MachineStm s) = tell ['ABC'.Raw s]
instance gen Application
where
gen (Name n) =
gets stackoffset >>= \so ->
gets addresses >>= \addrs ->
case 'M'.get n addrs of
Just i -> tell ['ABC'.Push_a $ i + so] *> growStack 1
_ -> liftT $ Error $ UndefinedName n
gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0] *> growStack 1
gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0] *> growStack 1
gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just i -> liftT $ Error FunctionOnStack
_ -> gets symbols >>= \syms -> case 'M'.get n syms of
Just fs ->
comment "Retrieve arguments" *> mapM gen args *>
comment "Apply function" *>
tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
, 'ABC'.Jsr n
, 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
] *>
shrinkStack fs.fs_arity
_ -> liftT $ Error $ UndefinedName n
gen (BuiltinApp op arg) = gen arg *> gen op *> growStack 1
gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op *> growStack 1
instance gen Op1
where
gen op =
toBStack 'ABC'.BT_Int 1 *>
tell [instr] *>
BtoAStack 'ABC'.BT_Int
where
instr = case op of
Neg -> 'ABC'.NegI
instance gen Op2
where
gen op =
toBStack 'ABC'.BT_Int 2 *>
tell [instr] *>
BtoAStack 'ABC'.BT_Int
where
instr = case op of
Add -> 'ABC'.AddI
Sub -> 'ABC'.SubI
Mul -> 'ABC'.MulI
Div -> 'ABC'.DivI
Rem -> 'ABC'.RemI
toBStack :: 'ABC'.BasicType Int -> Gen ()
toBStack t n = tell [push i \\ i <- [0..n-1]] *> tell ['ABC'.Pop_a (n-1)]
where
push = case t of
'ABC'.BT_Bool -> 'ABC'.PushB_a
'ABC'.BT_Int -> 'ABC'.PushI_a
BtoAStack :: 'ABC'.BasicType -> Gen ()
BtoAStack t = tell [fill 0 0, 'ABC'.Pop_b 1]
where
fill = case t of
'ABC'.BT_Bool -> 'ABC'.FillB_b
'ABC'.BT_Int -> 'ABC'.FillI_b
comment :: String -> Gen ()
comment s = tell ['ABC'.Comment s]
|
