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