gen.icl

   1 implementation module gen
   2
   3
   4 import StdMisc
   5 import StdList
   6 import StdOverloaded
   7 import StdString
   8 from StdFunc import id
   9 import StdTuple
  10 import StdEnum
  11 from StdEnv import const
  12
  13 import Data.Func
  14 import qualified Data.Map as Map
  15 import Data.List
  16 import Data.Either
  17 import Data.Tuple
  18 import Data.Functor
  19 import Data.Monoid
  20 import Data.Maybe
  21 import Control.Applicative
  22 import Control.Monad
  23 import Control.Monad.Trans
  24 from Text import class Text(concat), instance Text String
  25
  26 import AST
  27 import RWST
  28
  29 //Instruction is an instruction, with possible arguments and a possible comment
  30 //Or is a label
  31 TRUE :== -1
  32 FALSE :== 0
  33 :: Instr    = Instr String [Arg] String
  34             | Lab Label
  35 :: Label :== String
  36 :: Arg = L Label | Lit Int | Raw String
  37 :: SSMProgram :== [Instr]
  38 :: GenError = Error String
  39 :: GenMap :== 'Map'.Map String LoadPlace
  40 //completely change to either Stack, Heap, Register?
  41 :: LoadPlace    = LDA Int | LDC Int | LDH Int | LDL Int
  42                 | LDR Int | LDS Int
  43                 | FUNC Label
  44 :: Gen a :== RWST Label SSMProgram (GenMap, [Label]) (Either GenError) a
  45
  46 labelStream :: [Label]
  47 labelStream = map (\i-> concat ["lbl_", toString i]) [1..]
  48
  49 gen :: AST -> String
  50 gen (AST fds) = case evalRWST prog "" ('Map'.newMap, labelStream) of
  51             Left (Error e) = e
  52             Right (_, p) = toString p
  53     where
  54         prog = tell [Instr "bra" [L "main"] ""] >>| mapM_ g fds
  55 //gen _ = prog
  56 //    where
  57 //        expr = (Op2Expr zero (Op1Expr zero UnMinus (IntExpr zero 4)) BiPlus (IntExpr zero 7))
  58 //        expr2 = (FunExpr zero "test" [IntExpr zero 4] [])
  59 //        stmt = (IfStmt (BoolExpr zero True) [] [])
  60 //        prog = case evalRWST (g stmt) 0 ('Map'.newMap, labelStream) of
  61 //            Left (Error e) = abort e
  62 //            Right (_, prog) = toString prog
  63 //gen _ = toString    [Lab "Test"
  64 //                    ,Instr "ldc" [Lit 1] "Eerste instructie"
  65 //                    ,Instr "ldc" [Lit 2] "Tweede instructie"]
  66
  67 //Current issues:
  68 //All VarDecls are added as function, how to deal with assignments?
  69 //  (And when we deal with assignments, how to deal with assignments to higher order functions?)
  70 //Dealing with arguments
  71 //Dealing with types that do not fit on the Stack
  72 //  Probably completely change LoadPlace to a Type and a position relative to *something*
  73 //  And where the type determines if this position is a pointer to the heap or an
  74 //  unboxed value
  75
  76 //helper functions for the gen monad
  77 genMap :: Gen GenMap
  78 genMap = gets fst
  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