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