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