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