gen.icl

   1 implementation module gen
   2
   3 import StdMisc
   4 import StdList
   5 import StdOverloaded
   6 import StdString
   7 from StdFunc import id, const
   8 import StdTuple
   9 import StdEnum
  10
  11 import Data.Func
  12 import qualified Data.Map as Map
  13 import Data.List
  14 import Data.Either
  15 import Data.Tuple
  16 import Data.Functor
  17 import Data.Monoid
  18 import Data.Maybe
  19 import Control.Applicative
  20 import Control.Monad
  21 import Control.Monad.Trans
  22 from Text import class Text(concat), instance Text String
  23
  24 import AST
  25 import RWST
  26
  27 TRUE :== -1
  28 FALSE :== 0
  29 :: Instr    = Instr String [Arg] String
  30             | Lab Label
  31 :: Label :== 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
  38
  39 labelStream :: [Label]
  40 labelStream = ["lbl_" +++ toString i\\i<-[1..]]
  41
  42 defaultAddressBook :: Addressbook
  43 defaultAddressBook = extend "print" (LAB "print")
  44                         $ extend "read" (LAB "read")
  45                         $ extend "isEmpty" (LAB "isEmpty")
  46                         'Map'.newMap
  47
  48 gen :: AST -> Either String String
  49 gen (AST fds) = case evalRWST prog () (defaultAddressBook, labelStream) of
  50             Left (Error e) = Left e
  51             Right (_, p) = Right $ toString p
  52     where
  53         prog = tell [
  54                         Instr "bsr" [L "main"] "",
  55                         Instr "halt" [] ""
  56                         ] >>| tell programContext
  57             >>| mapM_ g fds
  58
  59 programContext :: SSMProgram
  60 programContext =    [Lab "1printint"
  61                     ,Instr "link" [Lit 0] ""
  62                     ,Instr "ldl" [Lit -2] "load first argument"
  63                                         ,Instr "trap" [Lit 0] "print int"
  64                     ,Instr "unlink" [] ""
  65                     ,Instr "ret" [] ""
  66                                         ,Lab "1printchar"
  67                     ,Instr "link" [Lit 0] ""
  68                     ,Instr "ldl" [Lit -2] "load first argument"
  69                                         ,Instr "trap" [Lit 1] "print char"
  70                     ,Instr "unlink" [] ""
  71                     ,Instr "ret" [] ""
  72                     ,Lab "1readint"
  73                     ,Instr "link" [Lit 0] ""
  74                                         ,Instr "trap" [Lit 10] "read int"
  75                     ,Instr "str" [Raw "RR"] ""
  76                     ,Instr "unlink" [] ""
  77                     ,Instr "ret" [] ""
  78                     ,Lab "1readchar"
  79                     ,Instr "link" [Lit 0] ""
  80                                         ,Instr "trap" [Lit 11] "read char"
  81                     ,Instr "str" [Raw "RR"] ""
  82                     ,Instr "unlink" [] ""
  83                     ,Instr "ret" [] ""
  84                     ,Lab "isEmpty"
  85                     ,Instr "link" [Lit 0] ""
  86                     ,Instr "ldl" [Lit -2] "load prt to list"
  87                     ,Instr "lda" [Lit 0] "derefrence ptr"
  88                     ,Instr "ldc" [Lit 0] ""
  89                     ,Instr "eq" [] "test for null pointer"
  90                     ,Instr "str" [Raw "RR"] ""
  91                     ,Instr "unlink" [] ""
  92                     ,Instr "ret" [] ""
  93                     ]
  94
  95 //helper functions for the gen monad
  96 getAdressbook :: Gen Addressbook
  97 getAdressbook = gets fst
  98
  99 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
 100 updateAdressbook f = modify (appFst f) >>| getAdressbook
 101
 102 extend :: String Address Addressbook -> Addressbook
 103 extend k pl g = 'Map'.put k pl g
 104
 105 fresh :: Gen Label
 106 fresh = gets snd >>= \vars->
 107         modify (appSnd $ const $ tail vars) >>|
 108         pure (head vars)
 109
 110 class g a :: a -> Gen ()
 111
 112 instance g Op1 where
 113         g UnNegation = tell [Instr "not" [] ""]
 114         g UnMinus = tell [Instr "neg" [] ""]
 115
 116 instance g Op2 where
 117         g o = tell [Instr s [] ""]
 118                 where
 119                         s = case o of
 120                     BiPlus = "add"
 121                                 BiMinus = "sub"
 122                     BiTimes = "mul"
 123                     BiDivide = "div"
 124                     BiMod = "mod"
 125                     BiEquals = "eq"
 126                     BiLesser = "lt"
 127                     BiGreater = "gt"
 128                     BiLesserEq = "le"
 129                     BiGreaterEq = "ge"
 130                     BiUnEqual = "ne"
 131                     BiAnd =  "and"
 132                     BiOr = "or"
 133                     BiCons = abort "Shit, Cons, how to deal with this?"
 134
 135 instance g FieldSelector where
 136         g FieldFst = tell [Instr "lda" [Lit 0] "fst"]
 137         g FieldSnd = tell [Instr "lda" [Lit 1] "snd"]
 138         g FieldHd = tell [Instr "lda" [Lit -1] "hd"]
 139         g FieldTl = tell [Instr "lda" [Lit 0] "tl"]
 140
 141 instance g Expr where
 142     g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
 143     g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
 144         g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
 145     g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
 146                 >>| tell [Instr "sth" [] ""]
 147     g (Op1Expr _ o e) = g e >>| g o
 148     g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
 149                 >>| tell [Instr "sth" [] ""]
 150                 >>| tell [Instr "ajs" [Lit -1] ""]
 151                 >>| tell [Instr "sth" [] ""]
 152     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
 153     g (TupleExpr _ (e1,e2)) = g e1
 154                 >>| tell [Instr "sth" [] ""]
 155                 >>| g e2
 156                 >>| tell [Instr "sth" [] ""]
 157                 >>| tell [Instr "ajs" [Lit -1] ""]
 158     g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
 159                 Just (ADDR t) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure ()
 160                 _ = liftT (Left $ Error "PANIC: variable and function name clash")
 161     g (FunExpr _ k es fs) =
 162                 mapM_ g es
 163                 >>| jump "bsr" k
 164         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 165                 >>| tell [Instr "ldr" [Raw "RR"] ""]
 166
 167 jump :: String String -> Gen ()
 168 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
 169         Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 170         Just (LAB t) = tell [Instr instr [L t] (k +++"()")]
 171         Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label")
 172
 173 instance g Stmt where
 174     g (IfStmt cond th el) =
 175         fresh >>= \elseLabel->
 176         fresh >>= \endLabel->
 177         g cond >>|
 178         tell [Instr "brf" [L elseLabel] "branch else"] >>|
 179         mapM_ g th >>|
 180         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 181         tell [Lab elseLabel] >>|
 182         mapM_ g el  >>|
 183         tell [Lab endLabel]
 184     g (WhileStmt cond th) =
 185         fresh >>= \startLabel->
 186         fresh >>= \endLabel ->
 187         tell [Lab startLabel] >>|
 188         g cond >>|
 189         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 190         mapM_ g th >>|
 191         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 192         tell [Lab endLabel]
 193     g (AssStmt (VarDef k fs) e) =
 194         g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
 195             Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
 196             Just (LAB t) = liftT (Left $ Error $ "PANIC: cannot assign to function")
 197             Just (ADDR t) = tell [Instr "stl" [Lit t] ""]
 198     g (FunStmt k es fs) = mapM_ g es
 199         >>| jump "bsr" k
 200         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 201         >>| mapM_ g fs
 202                 >>| pure ()
 203     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 204                 >>| tell [Instr "ret" [] ""]
 205     g (ReturnStmt (Just e)) = g e
 206                 >>| tell [Instr "str" [Raw "RR"] ""]
 207                 >>| g (ReturnStmt Nothing)
 208
 209 foldVarDecl :: Int VarDecl -> Gen Int
 210 foldVarDecl x (VarDecl _ _ k e) = g e
 211     >>| annote x k
 212         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 213
 214 addVars :: [String] -> (Addressbook -> Addressbook)
 215 addVars [] = id
 216 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 217
 218 instance g FunDecl where
 219     g (FunDecl _ k args _ vds stms) =
 220         //varDecls can call the enclosing function, so first reserve a label for it
 221         updateAdressbook (extend k (LAB k)) >>|
 222         getAdressbook >>= \oldMap ->
 223                 updateAdressbook (addVars args) >>|
 224         tell [Lab k] >>|
 225                 tell [Instr "link" [Lit 0] ""] >>|
 226         //add the vars
 227         foldM foldVarDecl 1 vds  >>|
 228         //and the statements
 229         mapM_ g stms >>|
 230         updateAdressbook (const oldMap) >>| pure ()
 231
 232 annote :: Int String -> Gen ()
 233 annote pos key =
 234     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
 235
 236 class print a :: a -> [String]
 237
 238 instance print Instr where
 239     print (Lab l) = [l, ":", "\n"]
 240     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 241
 242 instance print [Arg] where
 243     print args = (map toString args)
 244
 245 instance toString Arg where
 246     toString (L l) = l
 247     toString (Lit int) = toString int
 248     toString (Raw s) = s
 249
 250 instance toString SSMProgram where
 251     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p