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 ["lab_", toString i]) [1..]
  48
  49 gen :: AST -> String
  50 gen _ = prog
  51     where
  52         expr = (Op2Expr zero (Op1Expr zero UnMinus (IntExpr zero 4)) BiPlus (IntExpr zero 7))
  53         expr2 = (FunExpr zero "test" [IntExpr zero 4] [])
  54         stmt = (IfStmt (BoolExpr zero True) [] [])
  55         prog = case evalRWST (g stmt) "end" ('Map'.newMap, labelStream) of
  56             Left (Error e) = abort e
  57             Right (_, prog) = toString prog
  58 //gen _ = toString    [Lab "Test"
  59 //                    ,Instr "ldc" [Lit 1] "Eerste instructie"
  60 //                    ,Instr "ldc" [Lit 2] "Tweede instructie"]
  61
  62
  63 //helper functions for the gen monad
  64 genMap :: Gen GenMap
  65 genMap = gets fst
  66 changeGenMap :: (GenMap -> GenMap) -> Gen GenMap
  67 changeGenMap f = modify (appFst f) >>| genMap
  68
  69 extend :: String LoadPlace GenMap -> GenMap
  70 extend k pl g = 'Map'.put k pl g
  71
  72 fresh :: Gen Label
  73 fresh = gets snd >>= \vars->
  74         modify (appSnd $ const $ tail vars) >>|
  75         pure (head vars)
  76
  77 class g a :: a -> Gen ()
  78
  79 instance g Expr where
  80     g (VarExpr _ (VarDef k fs)) = load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
  81     g (IntExpr _ i) = loadP (LDC i) >>= \instr-> tell [instr]
  82     g (CharExpr _ c) = undef //how to deal with strings?
  83     g (BoolExpr _ True) = loadP (LDC TRUE) >>= \instr-> tell [instr]
  84     g (BoolExpr _ False) = loadP (LDC FALSE) >>= \instr-> tell [instr]
  85     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| tell [Instr (op2ins op) [] ""]
  86     g (Op1Expr _ UnNegation e) = g e >>| tell [Instr "not" [] ""]
  87     g (Op1Expr _ UnMinus e) = g e >>| tell [Instr "neg" [] ""]
  88     g (EmptyListExpr _) = abort "Shit, empty list expr"
  89     g (TupleExpr p (e1,e2)) = abort "How to deal with tuples?"
  90     g (FunExpr _ k es fs) = mapM g es >>| jump "bsr" k >>= \instr-> tell [instr]
  91
  92 instance g Stmt where
  93     g (IfStmt cond th el) =
  94         fresh >>= \elseLabel->
  95         fresh >>= \endLabel->
  96         g cond >>|
  97         tell [Instr "brf" [L elseLabel] "branch else"] >>|
  98         mapM_ g th >>|
  99         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 100         tell [Lab elseLabel] >>|
 101         mapM_ g el  >>|
 102         tell [Lab endLabel]
 103     g (WhileStmt cond th) =
 104         fresh >>= \startLabel->
 105         fresh >>= \endLabel ->
 106         tell [Lab startLabel] >>|
 107         g cond >>|
 108         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 109         mapM_ g th >>|
 110         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 111         tell [Lab endLabel]
 112     g (AssStmt (VarDef k fs) e) =
 113         g e >>|
 114         abort "Shit, an assignment, figure out something with storing vars or something"
 115         //vars will be on stack in locals (possible pointers to heap)
 116     g (FunStmt _ _) = abort "CodeGen, FunStmt unused" //not used
 117     g (ReturnStmt Nothing)  = tell [Instr "ret" [] ""] //NOTE! Assumes only return address on stack, safe?
 118     g (ReturnStmt (Just e)) =
 119         g e >>|
 120         tell [Instr "str" [Raw "RR"] ""] >>|
 121         g (ReturnStmt Nothing)
 122
 123 instance g VarDecl where
 124     g _ = abort "How will we store vars? use the locals thing?"
 125
 126 instance g FunDecl where
 127     g (FunDecl _ k args mt vds stms) =
 128         fresh >>= \l-> let lbl = l+++"_"+++k in
 129         tell [Lab lbl] >>|
 130         changeGenMap (extend k (FUNC lbl)) >>|
 131         tell [Instr "link" [Lit $ length vds] ""] //reserve room for local variables
 132         //Todo: actual code generation. Probably using 'RWST'.local to scope
 133         //the VarDecl in this function
 134
 135
 136
 137
 138
 139 op2ins :: Op2 -> String
 140 op2ins op = case op of
 141     BiPlus = "add"
 142     BiMinus = "sub"
 143     BiTimes = "mul"
 144     BiDivide = "div"
 145     BiMod = "mod"
 146     BiEquals = "eq"
 147     BiLesser = "lt"
 148     BiGreater = "gt"
 149     BiLesserEq = "le"
 150     BiGreaterEq = "ge"
 151     BiUnEqual = "ne"
 152     BiAnd = "and"
 153     BiOr = "or"
 154     BiCons = abort "Shit, Cons, how to deal with this?"
 155
 156 load :: String -> Gen Instr
 157 load k = genMap >>= \g-> case 'Map'.member k g of
 158     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found in variable mapping"])
 159     True = loadP $ 'Map'.find k g
 160
 161 loadP :: LoadPlace -> Gen Instr
 162 loadP pl = dec pl >>= \(instr, arg)-> pure $ Instr instr [arg] ""
 163 where
 164     dec (LDA i) = pure ("lda", Lit i)
 165     dec (LDC i) = pure ("ldc", Lit i)
 166     dec (LDH i) = pure ("ldh", Lit i)
 167     dec (LDL i) = pure ("ldl", Lit i)
 168     dec (LDR i) = pure ("ldr", Lit i)
 169     dec (LDS i) = pure ("lds", Lit i)
 170     dec _       = liftT (Left $ Error "PANIC: trying to load non adres")
 171
 172 //Instruction (String), key of function to jump to
 173 jump :: String String -> Gen Instr
 174 jump instr k = genMap >>= \g-> case 'Map'.member k g of
 175     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 176     True = dec ('Map'.find k g) >>= \lbl-> pure $ Instr instr [lbl] (k +++"()")
 177 where
 178     dec (FUNC l) = pure (L l)
 179     dec _ = liftT (Left $ Error "PANIC: trying to jump to non label")
 180
 181 class print a :: a -> [String]
 182
 183 instance print Instr where
 184     print (Lab l) = [l, ":", "\n"]
 185     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 186
 187 instance print [Arg] where
 188     print args = (map toString args)
 189
 190 instance toString Arg where
 191     toString (L l) = l
 192     toString (Lit int) = toString int
 193
 194 instance toString SSMProgram where
 195     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p