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