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 Control.Applicative
  21 import Control.Monad
  22 import Control.Monad.Trans
  23 from Text import class Text(concat), instance Text String
  24
  25 import AST
  26 import RWST
  27
  28 //Instruction is an instruction, with possible arguments and a possible comment
  29 //Or is a label
  30 TRUE :== -1
  31 FALSE :== 0
  32 :: Instr    = Instr String [Arg] String
  33             | Lab Label
  34 :: Label :== String
  35 :: Arg = L Label | Lit Int
  36 :: SSMProgram :== [Instr]
  37 :: GenError = Error String
  38 :: GenMap :== 'Map'.Map String LoadPlace
  39 :: LoadPlace    = LDA Int | LDC Int | LDH Int | LDL Int
  40                 | LDR Int | LDS Int
  41                 | FUNC Label
  42 :: Gen a :== RWST Label SSMProgram (GenMap, [Label]) (Either GenError) a
  43
  44 labelStream :: [Label]
  45 labelStream = map (\i-> concat ["lab_", toString i]) [1..]
  46
  47 gen :: AST -> String
  48 gen _ = prog
  49     where
  50         expr = (Op2Expr zero (Op1Expr zero UnMinus (IntExpr zero 4)) BiPlus (IntExpr zero 7))
  51         expr2 = (FunExpr zero "test" [IntExpr zero 4] [])
  52         stmt = (IfStmt (BoolExpr zero True) [] [])
  53         prog = case evalRWST (g stmt) "end" ('Map'.newMap, labelStream) of
  54             Left (Error e) = abort e
  55             Right (_, prog) = toString prog
  56 //gen _ = toString    [Lab "Test"
  57 //                    ,Instr "ldc" [Lit 1] "Eerste instructie"
  58 //                    ,Instr "ldc" [Lit 2] "Tweede instructie"]
  59
  60
  61 //helper functions for the gen monad
  62 genMap :: Gen GenMap
  63 genMap = gets fst
  64
  65 fresh :: Gen Label
  66 fresh = gets snd >>= \vars->
  67         modify (appSnd $ const $ tail vars) >>|
  68         pure (head vars)
  69
  70 class g a :: a -> Gen ()
  71
  72 instance g Expr where
  73     g (VarExpr _ (VarDef k fs)) = load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
  74     g (IntExpr _ i) = loadP (LDC i) >>= \instr-> tell [instr]
  75     g (CharExpr _ c) = undef //how to deal with strings?
  76     g (BoolExpr _ True) = loadP (LDC TRUE) >>= \instr-> tell [instr]
  77     g (BoolExpr _ False) = loadP (LDC FALSE) >>= \instr-> tell [instr]
  78     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| tell [Instr (op2ins op) [] ""]
  79     g (Op1Expr _ UnNegation e) = g e >>| tell [Instr "not" [] ""]
  80     g (Op1Expr _ UnMinus e) = g e >>| tell [Instr "neg" [] ""]
  81     g (EmptyListExpr _) = abort "Shit, empty list expr"
  82     g (TupleExpr p (e1,e2)) = abort "How to deal with tuples?"
  83     g (FunExpr _ k es fs) = mapM g es >>| jump "bsr" k >>= \instr-> tell [instr]
  84             //bra is probably not right, figure out function call way
  85
  86 instance g Stmt where
  87     g (IfStmt cond th el) =
  88         fresh >>= \elseLabel->
  89         fresh >>= \endLabel->
  90         g cond >>|
  91         tell [Instr "brf" [L elseLabel] "branch false"] >>|
  92         mapM_ g th >>|
  93         tell [Instr "bra" [L endLabel] "branch end if"] >>|
  94         tell [Lab elseLabel] >>|
  95         mapM_ g el  >>|
  96         tell [Lab endLabel]
  97
  98
  99 op2ins :: Op2 -> String
 100 op2ins op = case op of
 101     BiPlus = "add"
 102     BiMinus = "sub"
 103     BiTimes = "mul"
 104     BiDivide = "div"
 105     BiMod = "mod"
 106     BiEquals = "eq"
 107     BiLesser = "lt"
 108     BiGreater = "gt"
 109     BiLesserEq = "le"
 110     BiGreaterEq = "ge"
 111     BiUnEqual = "ne"
 112     BiAnd = "and"
 113     BiOr = "or"
 114     BiCons = abort "Shit, Cons, how to deal with this?"
 115
 116 load :: String -> Gen Instr
 117 load k = genMap >>= \g-> case 'Map'.member k g of
 118     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found in variable mapping"])
 119     True = loadP $ 'Map'.find k g
 120
 121 loadP :: LoadPlace -> Gen Instr
 122 loadP pl = dec pl >>= \(instr, arg)-> pure $ Instr instr [arg] ""
 123 where
 124     dec (LDA i) = pure ("lda", Lit i)
 125     dec (LDC i) = pure ("ldc", Lit i)
 126     dec (LDH i) = pure ("ldh", Lit i)
 127     dec (LDL i) = pure ("ldl", Lit i)
 128     dec (LDR i) = pure ("ldr", Lit i)
 129     dec (LDS i) = pure ("lds", Lit i)
 130     dec _       = liftT (Left $ Error "PANIC: trying to load non adres")
 131
 132 //Instruction (String), key of function to jump to
 133 jump :: String String -> Gen Instr
 134 jump instr k = genMap >>= \g-> case 'Map'.member k g of
 135     False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 136     True = dec ('Map'.find k g) >>= \lbl-> pure $ Instr instr [lbl] k
 137 where
 138     dec (FUNC l) = pure (L l)
 139     dec _ = liftT (Left $ Error "PANIC: trying to jump to non label")
 140
 141 class print a :: a -> [String]
 142
 143 instance print Instr where
 144     print (Lab l) = [l, ":", "\n"]
 145     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 146
 147 instance print [Arg] where
 148     print args = (map toString args)
 149
 150 instance toString Arg where
 151     toString (L l) = l
 152     toString (Lit int) = toString int
 153
 154 instance toString SSMProgram where
 155     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p