1 implementation module gen
7 from StdFunc import id, const
12 import qualified Data.Map as Map
19 import Control.Applicative
21 import Control.Monad.Trans
22 from Text import class Text(concat), instance Text String
29 :: Instr = Instr String [Arg] String
32 :: Arg = L Label | Lit Int | Raw String
33 :: SSMProgram :== [Instr]
34 :: GenError = Error String
35 :: Addressbook :== 'Map'.Map String Address
36 :: Address = LAB String Int Int | ADDR Int Int
37 :: Gen a :== RWST () SSMProgram (Addressbook, [Label]) (Either GenError) a
39 labelStream :: [Label]
40 labelStream = ["lbl_" +++ toString i\\i<-[1..]]
42 defaultAddressBook :: [FunDecl] -> Addressbook
43 defaultAddressBook fd = extend "1printint" (LAB "1printint" 1 0)
44 $ extend "1printchar" (LAB "1printchar" 1 1)
45 $ extend "read" (LAB "read" 0 2)
46 $ extend "isEmpty" (LAB "isEmpty" 1 3)
49 addFuncs [] _ = 'Map'.newMap
50 addFuncs [(FunDecl _ k args _ _ _):xs] n =
51 extend k (LAB k (length args) n) $ addFuncs xs (n+1)
53 gen :: AST -> Either String String
54 gen (AST fds) = case evalRWST prog () (defaultAddressBook fds, labelStream) of
55 Left (Error e) = Left e
56 Right (_, p) = Right $ toString p
59 Instr "bsr" [L "main"] "",
61 ] >>| tell (programContext fds)
64 programContext :: [FunDecl] -> SSMProgram
65 programContext x = [Lab "1func"
66 :fS ["1printint" ,"1printchar","read"
67 ,"isEmpty":map (\(FunDecl _ k _ _ _ _)->k) x] 0] ++ context
70 fS :: [String] Int -> SSMProgram
73 Lab $ "1next" +++ toString n
74 ,Instr "ldr" [Raw "R5"] ""
75 ,Instr "ldc" [Lit n] $ "branch to: " +++ k
79 (Instr "brf" [L $ "1next" +++ (toString $ n + 1)] "")
83 context = [Lab "1printint"
84 ,Instr "link" [Lit 0] ""
85 ,Instr "ldl" [Lit -2] "load first argument"
86 ,Instr "trap" [Lit 0] "print int"
90 ,Instr "link" [Lit 0] ""
91 ,Instr "ldl" [Lit -2] "load first argument"
92 ,Instr "trap" [Lit 1] "print char"
96 ,Instr "link" [Lit 0] ""
97 ,Instr "trap" [Lit 11] "read char"
98 ,Instr "str" [Raw "RR"] ""
102 ,Instr "link" [Lit 0] ""
103 ,Instr "ldl" [Lit -2] "load prt to list"
104 ,Instr "lda" [Lit 0] "derefrence ptr"
105 ,Instr "ldc" [Lit 0] ""
106 ,Instr "eq" [] "test for null pointer"
107 ,Instr "str" [Raw "RR"] ""
108 ,Instr "unlink" [] ""
113 getAdressbook :: Gen Addressbook
114 getAdressbook = gets fst
116 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
117 updateAdressbook f = modify (appFst f) >>| getAdressbook
119 extend :: String Address Addressbook -> Addressbook
120 extend k pl g = 'Map'.put k pl g
123 fresh = gets snd >>= \vars->
124 modify (appSnd $ const $ tail vars) >>|
127 class g a :: a -> Gen ()
130 g UnNegation = tell [Instr "not" [] ""]
131 g UnMinus = tell [Instr "neg" [] ""]
134 g o = tell [Instr s [] ""]
150 BiCons = abort "Shit, Cons, how to deal with this?"
152 instance g FieldSelector where
153 g FieldFst = tell [Instr "lda" [Lit -1] "fst"]
154 g FieldSnd = tell [Instr "lda" [Lit 0] "snd"]
155 g FieldHd = tell [Instr "lda" [Lit -1] "hd"]
156 g FieldTl = tell [Instr "lda" [Lit 0] "tl"]
158 instance g Expr where
159 g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
160 g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
161 g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
162 g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
163 >>| tell [Instr "sth" [] ""]
164 g (Op1Expr _ o e) = g e >>| g o
165 g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
166 >>| tell [Instr "sth" [] ""]
167 >>| tell [Instr "ajs" [Lit -1] ""]
168 >>| tell [Instr "sth" [] ""]
169 g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
170 g (TupleExpr _ (e1,e2)) = g e1
172 >>| tell [Instr "stmh" [Lit 2] ""]
173 g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
174 Just (ADDR t arity) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure ()
175 Just (LAB l _ fn) = tell
176 [Instr "ldc" [Lit fn] ""
178 ,Instr "ldc" [Lit 0] ""
180 ,Instr "ajs" [Lit -1] ""]
181 Nothing = liftT $ Left $ Error "PANIC: unresolver variable expr"
182 g (LambdaExpr _ _ _) = liftT $ Left $ Error "PANIC: Lambdas should be unfolded"
183 g (FunExpr _ k es fs) = funnyStuff k es fs
185 funnyStuff :: String [Expr] [FieldSelector] -> Gen ()
186 funnyStuff k es fs = getAdressbook >>= \ab->case 'Map'.get k ab of
187 //Identifier points to function
188 Just (LAB l arity fn) = if (arity <> (length es))
189 //Function is not complete
192 [Instr "ldc" [Lit fn] "Store function number"
194 ,Instr "str" [Raw "R7"] ""
195 ,Instr "ldc" [Lit $ length es] "Store arity"
197 ,Instr "ajs" [Lit -1] ""
199 >>| if (isEmpty es) (pure ()) (tell
200 [Instr "stmh" [Lit $ length es] "Store arguments"
201 ,Instr "ajs" [Lit -1] ""
202 ,Instr "ldr" [Raw "R7"] ""]))
203 //Function is complete
205 >>| getAdressbook >>= \ab->(case 'Map'.get k ab of
206 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
207 Just (LAB t _ _) = tell [Instr "bsr" [L t] (k +++"()")]
208 Just (ADDR t arity) = liftT (Left $ Error "NO ADDRESS JUMPING FFS")
211 [Instr "ajs" [Lit $ ~(length es)] "Clean arguments"
212 ,Instr "ldr" [Raw "RR"] ""])
213 //Identifier points to variable, thus higher order function
214 Just (ADDR t arity) = if (arity <> (length es))
215 //Function is still not complete
216 ( fresh >>= \finish->fresh >>= \start->tell [
217 //Store function number
218 Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE"
219 ,Instr "ldh" [Lit 0] "get function number"
220 ,Instr "sth" [] "Store"
221 //Store function arity
222 ,Instr "ldl" [Lit t] "get pointer again"
223 ,Instr "ldh" [Lit 1] "get function arity"
224 ,Instr "ldc" [Lit $ length es] "add argument number"
225 ,Instr "add" [] "add"
226 ,Instr "sth" [] "Store"
227 ,Instr "ajs" [Lit -1] "Adjust pointer"
229 ,Instr "ldl" [Lit t] ""
230 ,Instr "ldh" [Lit 1] "Load available arguments"
231 ,Instr "str" [Raw "R5"] "Store available args in register"
232 ,Instr "ldc" [Lit 0] "Store offset"
233 ,Instr "str" [Raw "R6"] "Store offset in register"
235 ,Instr "ldr" [Raw "R5"] ""
236 ,Instr "ldc" [Lit 0] ""
238 ,Instr "brt" [L finish] "Done pushing arg, bye"
240 ,Instr "ldl" [Lit t] ""
241 ,Instr "ldr" [Raw "R6"] ""
242 ,Instr "add" [] "Corrected heapaddress"
243 ,Instr "ldh" [Lit 2] "Load argument"
244 ,Instr "sth" [] "And store it immediatly after"
245 //Decrease available arguments
246 ,Instr "ldr" [Raw "R5"] ""
247 ,Instr "ldc" [Lit 1] ""
249 ,Instr "str" [Raw "R5"] ""
250 //Increase available arguments
251 ,Instr "ldr" [Raw "R6"] ""
252 ,Instr "ldc" [Lit 1] ""
254 ,Instr "str" [Raw "R6"] ""
255 ,Instr "bra" [L start] ""
260 [Instr "stmh" [Lit $ length es] "Store extra args"
261 ,Instr "ajs" [Lit -1] ""]
263 //Function is complete
264 ( fresh >>= \finish->fresh >>= \start->tell [
265 Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL"
266 ,Instr "ldh" [Lit 1] "Load available arguments"
267 ,Instr "str" [Raw "R5"] "Store available args in register"
268 ,Instr "ldc" [Lit 0] "Store offset"
269 ,Instr "str" [Raw "R6"] "Store offset in register"
272 ,Instr "ldr" [Raw "R5"] ""
273 ,Instr "ldc" [Lit 0] ""
275 ,Instr "brt" [L finish] "Done pushing arg, bye"
277 ,Instr "ldl" [Lit t] ""
278 ,Instr "ldr" [Raw "R6"] ""
279 ,Instr "add" [] "Corrected heapaddress"
280 ,Instr "ldh" [Lit 2] "Load argument"
281 //Decrease available arguments
282 ,Instr "ldr" [Raw "R5"] ""
283 ,Instr "ldc" [Lit 1] ""
285 ,Instr "str" [Raw "R5"] ""
286 //Increase available arguments
287 ,Instr "ldr" [Raw "R6"] ""
288 ,Instr "ldc" [Lit 1] ""
290 ,Instr "str" [Raw "R6"] ""
291 ,Instr "bra" [L start] ""
296 [Instr "ldl" [Lit t] ""
297 ,Instr "ldh" [Lit 0] "Get function number"
298 ,Instr "str" [Raw "R5"] ""
299 ,Instr "bsr" [L "1func"] "HIGHER ORDER END"
300 ,Instr "ldl" [Lit t] ""
301 ,Instr "ldh" [Lit 1] ""
303 ,Instr "ldr" [Raw "SP"] ""
305 ,Instr "ldc" [Lit $ length es + 1] ""
307 ,Instr "str" [Raw "SP"] ""
308 ,Instr "ldr" [Raw "RR"] ""
311 Nothing = liftT (Left $ Error $ "PANIC: Undefined function: " +++ k)
313 instance g Stmt where
314 g (IfStmt cond th el) =
315 fresh >>= \elseLabel->
316 fresh >>= \endLabel->
318 tell [Instr "brf" [L elseLabel] "branch else"] >>|
320 tell [Instr "bra" [L endLabel] "branch end if"] >>|
321 tell [Lab elseLabel] >>|
324 g (WhileStmt cond th) =
325 fresh >>= \startLabel->
326 fresh >>= \endLabel ->
327 tell [Lab startLabel] >>|
329 tell [Instr "brf" [L endLabel] "branch end while"] >>|
331 tell [Instr "bra" [L startLabel] "branch start while"] >>|
333 g (AssStmt (VarDef k fs) e) =
334 g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
335 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
336 Just (LAB t _ _) = liftT (Left $ Error $ "PANIC: cannot assign to function")
337 Just (ADDR t ar) = tell [Instr "stl" [Lit t] ""]
338 g (FunStmt k es fs) = funnyStuff k es fs
339 g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
340 >>| tell [Instr "ret" [] ""]
341 g (ReturnStmt (Just e)) = g e
342 >>| tell [Instr "str" [Raw "RR"] ""]
343 >>| g (ReturnStmt Nothing)
345 foldVarDecl :: Int VarDecl -> Gen Int
346 foldVarDecl x (VarDecl _ mt k e) = g e
348 >>| updateAdressbook (extend k (ADDR x $ arity $ fromJust mt))
352 arity (_ ->> x) = 1 + arity x
355 addVars :: Type [String] -> (Addressbook -> Addressbook)
357 addVars (t ->> ts) [x:xs] = \ab->
358 extend x (ADDR (-2 - (length xs)) (arity t)) (addVars ts xs ab)
359 addVars t [x] = \ab->
360 extend x (ADDR -2 0) ab
362 instance g FunDecl where
363 g (FunDecl _ k args mt vds stms) =
364 //varDecls can call the enclosing function, so first reserve a label for it
365 getAdressbook >>= \oldMap ->
366 updateAdressbook (addVars (fromJust mt) args) >>|
368 tell [Instr "link" [Lit 0] ""] >>|
370 foldM foldVarDecl 1 vds >>|
373 //Ugly hack to always return
374 g (ReturnStmt Nothing) >>|
375 updateAdressbook (const oldMap) >>| pure ()
377 annote :: Int String -> Gen ()
379 tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "black", Raw key] ""]
381 class print a :: a -> [String]
383 instance print Instr where
384 print (Lab l) = [l, ":", "\n"]
385 print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
387 instance print [Arg] where
388 print args = (map toString args)
390 instance toString Arg where
392 toString (Lit int) = toString int
395 instance toString SSMProgram where
396 toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p