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 defaultAddressBook :: Addressbook
43 defaultAddressBook = extend "1printint" (LAB "1printint")
44 $ extend "1printchar" (LAB "1printchar")
45 $ extend "1readchar" (LAB "1readchar")
46 $ extend "1readint" (LAB "1readint")
49 gen :: AST -> Either String String
50 gen (AST fds) = case evalRWST prog () (defaultAddressBook, labelStream) of
51 Left (Error e) = Left e
52 Right (_, p) = Right $ toString p
55 Instr "bsr" [L "main"] "",
57 ] >>| tell programContext
60 programContext :: SSMProgram
61 programContext = [Lab "1printint"
62 ,Instr "link" [Lit 0] ""
63 ,Instr "ldl" [Lit -2] "load first argument"
64 ,Instr "trap" [Lit 0] "print int"
68 ,Instr "link" [Lit 0] ""
69 ,Instr "ldl" [Lit -2] "load first argument"
70 ,Instr "trap" [Lit 1] "print char"
74 ,Instr "link" [Lit 0] ""
75 ,Instr "trap" [Lit 10] "read int"
76 ,Instr "str" [Raw "RR"] ""
80 ,Instr "link" [Lit 0] ""
81 ,Instr "trap" [Lit 11] "read char"
82 ,Instr "str" [Raw "RR"] ""
86 ,Instr "link" [Lit 0] ""
87 ,Instr "ldl" [Lit -2] "load prt to list"
88 ,Instr "lda" [Lit 0] "derefrence ptr"
89 ,Instr "ldc" [Lit 0] ""
90 ,Instr "eq" [] "test for null pointer"
91 ,Instr "str" [Raw "RR"] ""
96 //helper functions for the gen monad
97 getAdressbook :: Gen Addressbook
98 getAdressbook = gets fst
100 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
101 updateAdressbook f = modify (appFst f) >>| getAdressbook
103 extend :: String Address Addressbook -> Addressbook
104 extend k pl g = 'Map'.put k pl g
107 fresh = gets snd >>= \vars->
108 modify (appSnd $ const $ tail vars) >>|
111 class g a :: a -> Gen ()
114 g UnNegation = tell [Instr "not" [] ""]
115 g UnMinus = tell [Instr "neg" [] ""]
118 g o = tell [Instr s [] ""]
134 BiCons = abort "Shit, Cons, how to deal with this?"
136 instance g FieldSelector where
137 g FieldFst = tell [Instr "lda" [Lit 0] "fst"]
138 g FieldSnd = tell [Instr "lda" [Lit 1] "snd"]
139 g FieldHd = tell [Instr "lda" [Lit -1] "hd"]
140 g FieldTl = tell [Instr "lda" [Lit 0] "tl"]
142 instance g Expr where
143 g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
144 g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
145 g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
146 g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
147 >>| tell [Instr "sth" [] ""]
148 g (Op1Expr _ o e) = g e >>| g o
149 g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
150 >>| tell [Instr "sth" [] ""]
151 >>| tell [Instr "ajs" [Lit -1] ""]
152 >>| tell [Instr "sth" [] ""]
153 g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
154 g (TupleExpr _ (e1,e2)) = g e1
155 >>| tell [Instr "sth" [] ""]
157 >>| tell [Instr "sth" [] ""]
158 >>| tell [Instr "ajs" [Lit -1] ""]
159 g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
160 Just (ADDR t) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure ()
161 _ = liftT (Left $ Error "PANIC: variable and function name clash")
162 g (FunExpr _ k es fs) =
165 >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
166 >>| tell [Instr "ldr" [Raw "RR"] ""]
168 jump :: String String -> Gen ()
169 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
170 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
171 Just (LAB t) = tell [Instr instr [L t] (k +++"()")]
172 Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label")
174 instance g Stmt where
175 g (IfStmt cond th el) =
176 fresh >>= \elseLabel->
177 fresh >>= \endLabel->
179 tell [Instr "brf" [L elseLabel] "branch else"] >>|
181 tell [Instr "bra" [L endLabel] "branch end if"] >>|
182 tell [Lab elseLabel] >>|
185 g (WhileStmt cond th) =
186 fresh >>= \startLabel->
187 fresh >>= \endLabel ->
188 tell [Lab startLabel] >>|
190 tell [Instr "brf" [L endLabel] "branch end while"] >>|
192 tell [Instr "bra" [L startLabel] "branch start while"] >>|
194 g (AssStmt (VarDef k fs) e) =
195 g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
196 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
197 Just (LAB t) = liftT (Left $ Error $ "PANIC: cannot assign to function")
198 Just (ADDR t) = tell [Instr "stl" [Lit t] ""]
199 g (FunStmt k es fs) = mapM_ g es
201 >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
204 g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
205 >>| tell [Instr "ret" [] ""]
206 g (ReturnStmt (Just e)) = g e
207 >>| tell [Instr "str" [Raw "RR"] ""]
208 >>| g (ReturnStmt Nothing)
210 foldVarDecl :: Int VarDecl -> Gen Int
211 foldVarDecl x (VarDecl _ _ k e) = g e
213 >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
215 addVars :: [String] -> (Addressbook -> Addressbook)
217 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
219 instance g FunDecl where
220 g (FunDecl _ k args _ vds stms) =
221 //varDecls can call the enclosing function, so first reserve a label for it
222 updateAdressbook (extend k (LAB k)) >>|
223 getAdressbook >>= \oldMap ->
224 updateAdressbook (addVars args) >>|
226 tell [Instr "link" [Lit 0] ""] >>|
228 foldM foldVarDecl 1 vds >>|
231 updateAdressbook (const oldMap) >>| pure ()
233 annote :: Int String -> Gen ()
235 tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
237 class print a :: a -> [String]
239 instance print Instr where
240 print (Lab l) = [l, ":", "\n"]
241 print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
243 instance print [Arg] where
244 print args = (map toString args)
246 instance toString Arg where
248 toString (Lit int) = toString int
251 instance toString SSMProgram where
252 toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p