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 //Instruction is an instruction, with possible arguments and a possible comment
  28 //Or is a label
  29 TRUE :== -1
  30 FALSE :== 0
  31 :: Instr    = Instr String [Arg] String
  32             | Lab Label
  33 :: Label :== String
  34 :: Arg = L Label | Lit Int | Raw String
  35 :: SSMProgram :== [Instr]
  36 :: GenError = Error String
  37 :: GenMap :== 'Map'.Map String LoadPlace
  38 //completely change to either Stack, Heap, Register?
  39 :: LoadPlace    = LDA Int | LDC Int | LDH Int | LDL Int
  40                 | LDR Int | LDS Int
  41                 | FUNC Label
  42 :: Gen a :== RWST Label SSMProgram (GenMap, [Label]) (Either GenError) a
  43
  44 labelStream :: [Label]
  45 labelStream = ["lbl_" +++ toString i\\i<-[1..]]
  46
  47 gen :: AST -> Either String String
  48 gen (AST fds) = case evalRWST prog "" ('Map'.newMap, labelStream) of
  49             Left (Error e) = Left e
  50             Right (_, p) = Right $ toString p
  51     where
  52         prog = tell [Instr "bra" [L "main"] ""] >>| mapM_ g fds
  53 //gen _ = prog
  54 //    where
  55 //        expr = (Op2Expr zero (Op1Expr zero UnMinus (IntExpr zero 4)) BiPlus (IntExpr zero 7))
  56 //        expr2 = (FunExpr zero "test" [IntExpr zero 4] [])
  57 //        stmt = (IfStmt (BoolExpr zero True) [] [])
  58 //        prog = case evalRWST (g stmt) 0 ('Map'.newMap, labelStream) of
  59 //            Left (Error e) = abort e
  60 //            Right (_, prog) = toString prog
  61 //gen _ = toString    [Lab "Test"
  62 //                    ,Instr "ldc" [Lit 1] "Eerste instructie"
  63 //                    ,Instr "ldc" [Lit 2] "Tweede instructie"]
  64
  65 //Current issues:
  66 //All VarDecls are added as function, how to deal with assignments?
  67 //  (And when we deal with assignments, how to deal with assignments to higher order functions?)
  68 //Dealing with arguments
  69 //Dealing with types that do not fit on the Stack
  70 //  Probably completely change LoadPlace to a Type and a position relative to *something*
  71 //  And where the type determines if this position is a pointer to the heap or an
  72 //  unboxed value
  73
  74 //helper functions for the gen monad
  75 genMap :: Gen GenMap
  76 genMap = gets fst
  77
  78 changeGenMap :: (GenMap -> GenMap) -> Gen GenMap
  79 changeGenMap f = modify (appFst f) >>| genMap
  80
  81 extend :: String LoadPlace GenMap -> GenMap
  82 extend k pl g = 'Map'.put k pl g
  83
  84 fresh :: Gen Label
  85 fresh = gets snd >>= \vars->
  86         modify (appSnd $ const $ tail vars) >>|
  87         pure (head vars)
  88
  89 class g a :: a -> Gen ()
  90
  91 instance g Expr where
  92     g (VarExpr _ (VarDef k fs)) = load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
  93     g (IntExpr _ i) = loadP (LDC i) >>= \instr-> tell [instr]
  94     g (CharExpr _ c) = abort "How to deal with chars?"
  95     g (BoolExpr _ True) = loadP (LDC TRUE) >>= \instr-> tell [instr]
  96     g (BoolExpr _ False) = loadP (LDC FALSE) >>= \instr-> tell [instr]
  97     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| tell [Instr (op2ins op) [] ""]
  98     g (Op1Expr _ UnNegation e) = g e >>| tell [Instr "not" [] ""]
  99     g (Op1Expr _ UnMinus e) = g e >>| tell [Instr "neg" [] ""]
 100     g (EmptyListExpr _) = abort "Shit, empty list expr"
 101     g (TupleExpr p (e1,e2)) = abort "How to deal with tuples?"
 102     g (FunExpr _ k es fs) =
 103         mapM g es >>| //put all arguments on the stack (todo: fix argument handling!)
 104         jump "bsr" k >>= \instr->
 105         tell [instr] >>| //actually branch to function
 106         tell [Instr "ldr" [Raw "RR"] ""] //push return value on stack, todo: check for VOID
 107
 108 instance g Stmt where
 109     g (IfStmt cond th el) =
 110         fresh >>= \elseLabel->
 111         fresh >>= \endLabel->
 112         g cond >>|
 113         tell [Instr "brf" [L elseLabel] "branch else"] >>|
 114         mapM_ g th >>|
 115         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 116         tell [Lab elseLabel] >>|
 117         mapM_ g el  >>|
 118         tell [Lab endLabel]
 119     g (WhileStmt cond th) =
 120         fresh >>= \startLabel->
 121         fresh >>= \endLabel ->
 122         tell [Lab startLabel] >>|
 123         g cond >>|
 124         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 125         mapM_ g th >>|
 126         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 127         tell [Lab endLabel]
 128     g (AssStmt (VarDef k fs) e) =
 129         g e >>|
 130         abort "Shit, an assignment, figure out something with storing vars or something"
 131         //vars will be on stack in locals (possible pointers to heap)
 132     g (FunStmt _ _) = abort "CodeGen, FunStmt unused" //not used
 133     g (ReturnStmt Nothing)  = tell [Instr "ret" [] ""] //NOTE! Assumes only return address on stack, safe?
 134     g (ReturnStmt (Just e)) =
 135         g e >>|
 136         tell [Instr "str" [Raw "RR"] ""] >>|
 137         g (ReturnStmt Nothing)
 138
 139 instance g VarDecl where
 140     g (VarDecl _ Nothing _ _) = liftT (Left $ Error "PANIC: untyped vardecl")
 141     g (VarDecl _ (Just t) k e) =
 142         (\l->k+++"_"+++l) <$> fresh >>= \lbl->
 143         changeGenMap (extend k (FUNC lbl)) >>|
 144         tell [Lab lbl] >>|
 145         g e >>|
 146         tell [Instr "str" [Raw "RR"] ""] >>|
 147         tell [Instr "ret" [] ""]
 148
 149
 150 instance g FunDecl where
 151     g (FunDecl _ k _ _ vds stms) =
 152         //varDecls can call the enclosing function, so first reserve a label for it
 153         (\l-> if (k=="main") "main" (l+++"_"+++k)) <$> fresh >>= \lbl->
 154         changeGenMap (extend k (FUNC lbl)) >>|
 155         //then generate functions for the VarDecls
 156         genMap >>= \oldMap ->
 157         mapM_ g vds  >>|
 158         //then the main function
 159         tell [Lab lbl] >>|
 160         mapM_ g stms >>|
 161         changeGenMap (const oldMap) >>| pure ()
 162
 163 op2ins :: Op2 -> String
 164 op2ins op = case op of
 165     BiPlus = "add"
 166     BiMinus = "sub"
 167     BiTimes = "mul"
 168     BiDivide = "div"
 169     BiMod = "mod"
 170     BiEquals = "eq"
 171     BiLesser = "lt"
 172     BiGreater = "gt"
 173     BiLesserEq = "le"
 174     BiGreaterEq = "ge"
 175     BiUnEqual = "ne"
 176     BiAnd = "and"
 177     BiOr = "or"
 178     BiCons = abort "Shit, Cons, how to deal with this?"
 179
 180 load :: String -> Gen Instr
 181 load k = genMap >>= \g-> case 'Map'.member k g of
 182     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found in variable mapping"])
 183     True = loadP $ 'Map'.find k g
 184
 185 loadP :: LoadPlace -> Gen Instr
 186 loadP pl = dec pl >>= \(instr, arg)-> pure $ Instr instr [arg] ""
 187 where
 188     dec (LDA i) = pure ("lda", Lit i)
 189     dec (LDC i) = pure ("ldc", Lit i)
 190     dec (LDH i) = pure ("ldh", Lit i)
 191     dec (LDL i) = pure ("ldl", Lit i)
 192     dec (LDR i) = pure ("ldr", Lit i)
 193     dec (LDS i) = pure ("lds", Lit i)
 194     dec _       = liftT (Left $ Error "PANIC: trying to load non adres")
 195
 196 //Instruction (String), key of function to jump to
 197 jump :: String String -> Gen Instr
 198 jump instr k = genMap >>= \g-> case 'Map'.member k g of
 199     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 200     True = dec ('Map'.find k g) >>= \lbl-> pure $ Instr instr [lbl] (k +++"()")
 201 where
 202     dec (FUNC l) = pure (L l)
 203     dec _ = liftT (Left $ Error "PANIC: trying to jump to non label")
 204
 205 class print a :: a -> [String]
 206
 207 instance print Instr where
 208     print (Lab l) = [l, ":", "\n"]
 209     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 210
 211 instance print [Arg] where
 212     print args = (map toString args)
 213
 214 instance toString Arg where
 215     toString (L l) = l
 216     toString (Lit int) = toString int
 217     toString (Raw s) = s
 218
 219 instance toString SSMProgram where
 220     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p