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 | ADDR Int
37 :: Gen a :== RWST () SSMProgram (Addressbook, [Label]) (Either GenError) a
39 labelStream :: [Label]
40 labelStream = ["lbl_" +++ toString i\\i<-[1..]]
42 gen :: AST -> Either String String
43 gen (AST fds) = case evalRWST prog () ('Map'.newMap, labelStream) of
44 Left (Error e) = Left e
45 Right (_, p) = Right $ toString p
48 Instr "bsr" [L "main"] "",
53 //All VarDecls are added as function, how to deal with assignments?
54 // (And when we deal with assignments, how to deal with assignments to higher order functions?)
55 //Dealing with arguments
56 //Dealing with types that do not fit on the Stack
57 // Probably completely change LoadPlace to a Type and a position relative to *something*
58 // And where the type determines if this position is a pointer to the heap or an
61 //helper functions for the gen monad
62 getAdressbook :: Gen Addressbook
63 getAdressbook = gets fst
65 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
66 updateAdressbook f = modify (appFst f) >>| getAdressbook
68 extend :: String Address Addressbook -> Addressbook
69 extend k pl g = 'Map'.put k pl g
72 fresh = gets snd >>= \vars->
73 modify (appSnd $ const $ tail vars) >>|
76 class g a :: a -> Gen ()
79 g UnNegation = tell [Instr "not" [] ""]
80 g UnMinus = tell [Instr "neg" [] ""]
83 g o = tell [Instr s [] ""]
99 BiCons = abort "Shit, Cons, how to deal with this?"
101 instance g Expr where
102 g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
103 g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
104 g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
105 g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
106 >>| tell [Instr "sth" [] ""]
107 g (Op1Expr _ o e) = g e >>| g o
108 g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
109 >>| tell [Instr "sth" [] ""]
110 >>| tell [Instr "ajs" [Lit -1] ""]
111 >>| tell [Instr "sth" [] ""]
112 g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
113 g (TupleExpr _ (e1,e2)) = g e1
114 >>| tell [Instr "sth" [] ""]
116 >>| tell [Instr "sth" [] ""]
117 >>| tell [Instr "ajs" [Lit -1] ""]
118 g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
119 Nothing = liftT (Left $ Error "PANIC: undefined variable")
120 Just (ADDR t) = tell [Instr "ldl" [Lit t] ""]
121 Just (LAB t) = liftT (Left $ Error "PANIC: variable and function name clash")
122 //load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
123 g (FunExpr _ k es fs) =
126 >>| tell [Instr "ldr" [Raw "RR"] ""]
128 jump :: String String -> Gen ()
129 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
130 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
131 Just (LAB t) = tell [Instr instr [L t] (k +++"()")]
132 Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label")
134 instance g Stmt where
135 g (IfStmt cond th el) =
136 fresh >>= \elseLabel->
137 fresh >>= \endLabel->
139 tell [Instr "brf" [L elseLabel] "branch else"] >>|
141 tell [Instr "bra" [L endLabel] "branch end if"] >>|
142 tell [Lab elseLabel] >>|
145 g (WhileStmt cond th) =
146 fresh >>= \startLabel->
147 fresh >>= \endLabel ->
148 tell [Lab startLabel] >>|
150 tell [Instr "brf" [L endLabel] "branch end while"] >>|
152 tell [Instr "bra" [L startLabel] "branch start while"] >>|
154 g (AssStmt (VarDef k fs) e) =
155 g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
156 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
157 Just (LAB t) = liftT (Left $ Error $ "PANIC: cannot assign to function")
158 Just (ADDR t) = tell [Instr "stl" [Lit t] ""]
159 g (FunStmt k es) = mapM g es >>| jump "bsr" k
160 g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
161 >>| tell [Instr "ret" [] ""]
162 g (ReturnStmt (Just e)) = g e
163 >>| tell [Instr "str" [Raw "RR"] ""]
164 >>| g (ReturnStmt Nothing)
166 foldVarDecl :: Int VarDecl -> Gen Int
167 foldVarDecl x (VarDecl _ _ k e) = g e
168 >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
170 addVars :: [String] -> (Addressbook -> Addressbook)
172 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
174 instance g FunDecl where
175 g (FunDecl _ k args _ vds stms) =
176 //varDecls can call the enclosing function, so first reserve a label for it
177 updateAdressbook (extend k (LAB k)) >>|
178 getAdressbook >>= \oldMap ->
179 updateAdressbook (addVars args) >>|
181 tell [Instr "link" [Lit 0] ""] >>|
182 //then generate functions for the VarDecls
183 foldM foldVarDecl 1 vds >>|
184 //then the main function
186 updateAdressbook (const oldMap) >>| pure ()
188 class print a :: a -> [String]
190 instance print Instr where
191 print (Lab l) = [l, ":", "\n"]
192 print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
194 instance print [Arg] where
195 print args = (map toString args)
197 instance toString Arg where
199 toString (Lit int) = toString int
202 instance toString SSMProgram where
203 toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p