gen.icl

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