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) = mapM_ g es
 186         >>| jump "bsr" k
 187         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 188         >>| pure ()
 189     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 190                 >>| tell [Instr "ret" [] ""]
 191     g (ReturnStmt (Just e)) = g e
 192                 >>| tell [Instr "str" [Raw "RR"] ""]
 193                 >>| g (ReturnStmt Nothing)
 194
 195 foldVarDecl :: Int VarDecl -> Gen Int
 196 foldVarDecl x (VarDecl _ _ k e) = g e
 197     >>| annote x k
 198         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 199
 200 addVars :: [String] -> (Addressbook -> Addressbook)
 201 addVars [] = id
 202 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 203
 204 instance g FunDecl where
 205     g (FunDecl _ k args _ vds stms) =
 206         //varDecls can call the enclosing function, so first reserve a label for it
 207         updateAdressbook (extend k (LAB k)) >>|
 208         getAdressbook >>= \oldMap ->
 209                 updateAdressbook (addVars args) >>|
 210         tell [Lab k] >>|
 211                 tell [Instr "link" [Lit 0] ""] >>|
 212         //add the vars
 213         foldM foldVarDecl 1 vds  >>|
 214         //and the statements
 215         mapM_ g stms >>|
 216         updateAdressbook (const oldMap) >>| pure ()
 217
 218 annote :: Int String -> Gen ()
 219 annote pos key =
 220     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
 221
 222 class print a :: a -> [String]
 223
 224 instance print Instr where
 225     print (Lab l) = [l, ":", "\n"]
 226     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 227
 228 instance print [Arg] where
 229     print args = (map toString args)
 230
 231 instance toString Arg where
 232     toString (L l) = l
 233     toString (Lit int) = toString int
 234     toString (Raw s) = s
 235
 236 instance toString SSMProgram where
 237     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p