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 Expr where
 123     g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
 124     g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
 125         g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
 126     g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
 127                 >>| tell [Instr "sth" [] ""]
 128     g (Op1Expr _ o e) = g e >>| g o
 129     g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
 130                 >>| tell [Instr "sth" [] ""]
 131                 >>| tell [Instr "ajs" [Lit -1] ""]
 132                 >>| tell [Instr "sth" [] ""]
 133     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
 134     g (TupleExpr _ (e1,e2)) = g e1
 135                 >>| tell [Instr "sth" [] ""]
 136                 >>| g e2
 137                 >>| tell [Instr "sth" [] ""]
 138                 >>| tell [Instr "ajs" [Lit -1] ""]
 139     g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
 140                 Nothing = liftT (Left $ Error "PANIC: undefined variable")
 141                 Just (ADDR t) = tell [Instr "ldl" [Lit t] ""]
 142                 Just (LAB t) = liftT (Left $ Error "PANIC: variable and function name clash")
 143                 //load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
 144     g (FunExpr _ k es fs) =
 145                 mapM_ g es
 146                 >>| jump "bsr" k
 147         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 148                 >>| tell [Instr "ldr" [Raw "RR"] ""]
 149
 150 jump :: String String -> Gen ()
 151 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
 152         Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 153         Just (LAB t) = tell [Instr instr [L t] (k +++"()")]
 154         Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label")
 155
 156 instance g Stmt where
 157     g (IfStmt cond th el) =
 158         fresh >>= \elseLabel->
 159         fresh >>= \endLabel->
 160         g cond >>|
 161         tell [Instr "brf" [L elseLabel] "branch else"] >>|
 162         mapM_ g th >>|
 163         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 164         tell [Lab elseLabel] >>|
 165         mapM_ g el  >>|
 166         tell [Lab endLabel]
 167     g (WhileStmt cond th) =
 168         fresh >>= \startLabel->
 169         fresh >>= \endLabel ->
 170         tell [Lab startLabel] >>|
 171         g cond >>|
 172         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 173         mapM_ g th >>|
 174         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 175         tell [Lab endLabel]
 176     g (AssStmt (VarDef k fs) e) =
 177         g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
 178             Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
 179             Just (LAB t) = liftT (Left $ Error $ "PANIC: cannot assign to function")
 180             Just (ADDR t) = tell [Instr "stl" [Lit t] ""]
 181     g (FunStmt k es) = mapM_ g es
 182         >>| jump "bsr" k
 183         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 184         >>| pure ()
 185     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 186                 >>| tell [Instr "ret" [] ""]
 187     g (ReturnStmt (Just e)) = g e
 188                 >>| tell [Instr "str" [Raw "RR"] ""]
 189                 >>| g (ReturnStmt Nothing)
 190
 191 foldVarDecl :: Int VarDecl -> Gen Int
 192 foldVarDecl x (VarDecl _ _ k e) = g e
 193     >>| annote x k
 194         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 195
 196 addVars :: [String] -> (Addressbook -> Addressbook)
 197 addVars [] = id
 198 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 199
 200 instance g FunDecl where
 201     g (FunDecl _ k args _ vds stms) =
 202         //varDecls can call the enclosing function, so first reserve a label for it
 203         updateAdressbook (extend k (LAB k)) >>|
 204         getAdressbook >>= \oldMap ->
 205                 updateAdressbook (addVars args) >>|
 206         tell [Lab k] >>|
 207                 tell [Instr "link" [Lit 0] ""] >>|
 208         //add the vars
 209         foldM foldVarDecl 1 vds  >>|
 210         //and the statements
 211         mapM_ g stms >>|
 212         updateAdressbook (const oldMap) >>| pure ()
 213
 214 annote :: Int String -> Gen ()
 215 annote pos key =
 216     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
 217
 218 class print a :: a -> [String]
 219
 220 instance print Instr where
 221     print (Lab l) = [l, ":", "\n"]
 222     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 223
 224 instance print [Arg] where
 225     print args = (map toString args)
 226
 227 instance toString Arg where
 228     toString (L l) = l
 229     toString (Lit int) = toString int
 230     toString (Raw s) = s
 231
 232 instance toString SSMProgram where
 233     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p