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