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