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