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 "1printint" (LAB "1printint")
  44         $ extend "1printchar" (LAB "1printchar")
  45         $ extend "1readchar" (LAB "1readchar")
  46         $ extend "1readint" (LAB "1readint")
  47         'Map'.newMap
  48
  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
  53     where
  54         prog = tell [
  55                         Instr "bsr" [L "main"] "",
  56                         Instr "halt" [] ""
  57                         ] >>| tell programContext
  58             >>| mapM_ g fds
  59
  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"
  65                     ,Instr "unlink" [] ""
  66                     ,Instr "ret" [] ""
  67                                         ,Lab "1printchar"
  68                     ,Instr "link" [Lit 0] ""
  69                     ,Instr "ldl" [Lit -2] "load first argument"
  70                                         ,Instr "trap" [Lit 1] "print char"
  71                     ,Instr "unlink" [] ""
  72                     ,Instr "ret" [] ""
  73                     ,Lab "1readint"
  74                     ,Instr "link" [Lit 0] ""
  75                                         ,Instr "trap" [Lit 10] "read int"
  76                     ,Instr "str" [Raw "RR"] ""
  77                     ,Instr "unlink" [] ""
  78                     ,Instr "ret" [] ""
  79                     ,Lab "1readchar"
  80                     ,Instr "link" [Lit 0] ""
  81                                         ,Instr "trap" [Lit 11] "read char"
  82                     ,Instr "str" [Raw "RR"] ""
  83                     ,Instr "unlink" [] ""
  84                     ,Instr "ret" [] ""
  85                     ,Lab "isEmpty"
  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"] ""
  92                     ,Instr "unlink" [] ""
  93                     ,Instr "ret" [] ""
  94                     ]
  95
  96 //helper functions for the gen monad
  97 getAdressbook :: Gen Addressbook
  98 getAdressbook = gets fst
  99
 100 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
 101 updateAdressbook f = modify (appFst f) >>| getAdressbook
 102
 103 extend :: String Address Addressbook -> Addressbook
 104 extend k pl g = 'Map'.put k pl g
 105
 106 fresh :: Gen Label
 107 fresh = gets snd >>= \vars->
 108         modify (appSnd $ const $ tail vars) >>|
 109         pure (head vars)
 110
 111 class g a :: a -> Gen ()
 112
 113 instance g Op1 where
 114         g UnNegation = tell [Instr "not" [] ""]
 115         g UnMinus = tell [Instr "neg" [] ""]
 116
 117 instance g Op2 where
 118         g o = tell [Instr s [] ""]
 119                 where
 120                         s = case o of
 121                     BiPlus = "add"
 122                                 BiMinus = "sub"
 123                     BiTimes = "mul"
 124                     BiDivide = "div"
 125                     BiMod = "mod"
 126                     BiEquals = "eq"
 127                     BiLesser = "lt"
 128                     BiGreater = "gt"
 129                     BiLesserEq = "le"
 130                     BiGreaterEq = "ge"
 131                     BiUnEqual = "ne"
 132                     BiAnd =  "and"
 133                     BiOr = "or"
 134                     BiCons = abort "Shit, Cons, how to deal with this?"
 135
 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"]
 141
 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" [] ""]
 156                 >>| g e2
 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) =
 163                 mapM_ g es
 164                 >>| jump "bsr" k
 165         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 166                 >>| tell [Instr "ldr" [Raw "RR"] ""]
 167
 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")
 173
 174 instance g Stmt where
 175     g (IfStmt cond th el) =
 176         fresh >>= \elseLabel->
 177         fresh >>= \endLabel->
 178         g cond >>|
 179         tell [Instr "brf" [L elseLabel] "branch else"] >>|
 180         mapM_ g th >>|
 181         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 182         tell [Lab elseLabel] >>|
 183         mapM_ g el  >>|
 184         tell [Lab endLabel]
 185     g (WhileStmt cond th) =
 186         fresh >>= \startLabel->
 187         fresh >>= \endLabel ->
 188         tell [Lab startLabel] >>|
 189         g cond >>|
 190         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 191         mapM_ g th >>|
 192         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 193         tell [Lab endLabel]
 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
 200         >>| jump "bsr" k
 201         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 202         >>| mapM_ g fs
 203                 >>| pure ()
 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)
 209
 210 foldVarDecl :: Int VarDecl -> Gen Int
 211 foldVarDecl x (VarDecl _ _ k e) = g e
 212     >>| annote x k
 213         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 214
 215 addVars :: [String] -> (Addressbook -> Addressbook)
 216 addVars [] = id
 217 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 218
 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) >>|
 225         tell [Lab k] >>|
 226                 tell [Instr "link" [Lit 0] ""] >>|
 227         //add the vars
 228         foldM foldVarDecl 1 vds  >>|
 229         //and the statements
 230         mapM_ g stms >>|
 231         updateAdressbook (const oldMap) >>| pure ()
 232
 233 annote :: Int String -> Gen ()
 234 annote pos key =
 235     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
 236
 237 class print a :: a -> [String]
 238
 239 instance print Instr where
 240     print (Lab l) = [l, ":", "\n"]
 241     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 242
 243 instance print [Arg] where
 244     print args = (map toString args)
 245
 246 instance toString Arg where
 247     toString (L l) = l
 248     toString (Lit int) = toString int
 249     toString (Raw s) = s
 250
 251 instance toString SSMProgram where
 252     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p