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