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
  67 fresh :: Gen Label
  68 fresh = gets snd >>= \vars->
  69         modify (appSnd $ const $ tail vars) >>|
  70         pure (head vars)
  71
  72 class g a :: a -> Gen ()
  73
  74 instance g Expr where
  75     g (VarExpr _ (VarDef k fs)) = load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
  76     g (IntExpr _ i) = loadP (LDC i) >>= \instr-> tell [instr]
  77     g (CharExpr _ c) = undef //how to deal with strings?
  78     g (BoolExpr _ True) = loadP (LDC TRUE) >>= \instr-> tell [instr]
  79     g (BoolExpr _ False) = loadP (LDC FALSE) >>= \instr-> tell [instr]
  80     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| tell [Instr (op2ins op) [] ""]
  81     g (Op1Expr _ UnNegation e) = g e >>| tell [Instr "not" [] ""]
  82     g (Op1Expr _ UnMinus e) = g e >>| tell [Instr "neg" [] ""]
  83     g (EmptyListExpr _) = abort "Shit, empty list expr"
  84     g (TupleExpr p (e1,e2)) = abort "How to deal with tuples?"
  85     g (FunExpr _ k es fs) = mapM g es >>| jump "bsr" k >>= \instr-> tell [instr]
  86             //bra is probably not right, figure out function call way
  87
  88 instance g Stmt where
  89     g (IfStmt cond th el) =
  90         fresh >>= \elseLabel->
  91         fresh >>= \endLabel->
  92         g cond >>|
  93         tell [Instr "brf" [L elseLabel] "branch else"] >>|
  94         mapM_ g th >>|
  95         tell [Instr "bra" [L endLabel] "branch end if"] >>|
  96         tell [Lab elseLabel] >>|
  97         mapM_ g el  >>|
  98         tell [Lab endLabel]
  99     g (WhileStmt cond th) =
 100         fresh >>= \startLabel->
 101         fresh >>= \endLabel ->
 102         tell [Lab startLabel] >>|
 103         g cond >>|
 104         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 105         mapM_ g th >>|
 106         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 107         tell [Lab endLabel]
 108     g (AssStmt (VarDef k fs) e) =
 109         g e >>|
 110         abort "Shit, an assignment, figure out something with storing vars or something"
 111     g (FunStmt _ _) = abort "CodeGen FunStmt unused" //not used
 112     g (ReturnStmt Nothing)  = tell [Instr "ret" [] ""]
 113     g (ReturnStmt (Just e)) =
 114         g e >>|
 115         tell [Instr "str" [Raw "RR"] ""] >>|
 116         g (ReturnStmt Nothing)
 117
 118
 119
 120 op2ins :: Op2 -> String
 121 op2ins op = case op of
 122     BiPlus = "add"
 123     BiMinus = "sub"
 124     BiTimes = "mul"
 125     BiDivide = "div"
 126     BiMod = "mod"
 127     BiEquals = "eq"
 128     BiLesser = "lt"
 129     BiGreater = "gt"
 130     BiLesserEq = "le"
 131     BiGreaterEq = "ge"
 132     BiUnEqual = "ne"
 133     BiAnd = "and"
 134     BiOr = "or"
 135     BiCons = abort "Shit, Cons, how to deal with this?"
 136
 137 load :: String -> Gen Instr
 138 load k = genMap >>= \g-> case 'Map'.member k g of
 139     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found in variable mapping"])
 140     True = loadP $ 'Map'.find k g
 141
 142 loadP :: LoadPlace -> Gen Instr
 143 loadP pl = dec pl >>= \(instr, arg)-> pure $ Instr instr [arg] ""
 144 where
 145     dec (LDA i) = pure ("lda", Lit i)
 146     dec (LDC i) = pure ("ldc", Lit i)
 147     dec (LDH i) = pure ("ldh", Lit i)
 148     dec (LDL i) = pure ("ldl", Lit i)
 149     dec (LDR i) = pure ("ldr", Lit i)
 150     dec (LDS i) = pure ("lds", Lit i)
 151     dec _       = liftT (Left $ Error "PANIC: trying to load non adres")
 152
 153 //Instruction (String), key of function to jump to
 154 jump :: String String -> Gen Instr
 155 jump instr k = genMap >>= \g-> case 'Map'.member k g of
 156     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 157     True = dec ('Map'.find k g) >>= \lbl-> pure $ Instr instr [lbl] k
 158 where
 159     dec (FUNC l) = pure (L l)
 160     dec _ = liftT (Left $ Error "PANIC: trying to jump to non label")
 161
 162 class print a :: a -> [String]
 163
 164 instance print Instr where
 165     print (Lab l) = [l, ":", "\n"]
 166     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 167
 168 instance print [Arg] where
 169     print args = (map toString args)
 170
 171 instance toString Arg where
 172     toString (L l) = l
 173     toString (Lit int) = toString int
 174
 175 instance toString SSMProgram where
 176     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p