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 [
  48                         Instr "bsr" [L "main"] "",
  49                         Instr "halt" [] ""
  50                         ] >>| 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 getAdressbook :: Gen Addressbook
  63 getAdressbook = gets fst
  64
  65 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
  66 updateAdressbook f = modify (appFst f) >>| getAdressbook
  67
  68 extend :: String Address Addressbook -> Addressbook
  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 Op1 where
  79         g UnNegation = tell [Instr "not" [] ""]
  80         g UnMinus = tell [Instr "neg" [] ""]
  81
  82 instance g Op2 where
  83         g o = tell [Instr s [] ""]
  84                 where
  85                         s = case o of
  86                     BiPlus = "add"
  87                                 BiMinus = "sub"
  88                     BiTimes = "mul"
  89                     BiDivide = "div"
  90                     BiMod = "mod"
  91                     BiEquals = "eq"
  92                     BiLesser = "lt"
  93                     BiGreater = "gt"
  94                     BiLesserEq = "le"
  95                     BiGreaterEq = "ge"
  96                     BiUnEqual = "ne"
  97                     BiAnd =  "and"
  98                     BiOr = "or"
  99                     BiCons = abort "Shit, Cons, how to deal with this?"
 100
 101 instance g Expr where
 102     g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
 103     g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
 104         g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
 105     g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
 106                 >>| tell [Instr "sth" [] ""]
 107     g (Op1Expr _ o e) = g e >>| g o
 108     g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
 109                 >>| tell [Instr "sth" [] ""]
 110                 >>| tell [Instr "ajs" [Lit -1] ""]
 111                 >>| tell [Instr "sth" [] ""]
 112     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
 113     g (TupleExpr _ (e1,e2)) = g e1
 114                 >>| tell [Instr "sth" [] ""]
 115                 >>| g e2
 116                 >>| tell [Instr "sth" [] ""]
 117                 >>| tell [Instr "ajs" [Lit -1] ""]
 118     g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
 119                 Nothing = liftT (Left $ Error "PANIC: undefined variable")
 120                 Just (ADDR t) = tell [Instr "ldl" [Lit t] ""]
 121                 Just (LAB t) = liftT (Left $ Error "PANIC: variable and function name clash")
 122                 //load k >>= \instr-> tell [instr] //note: pure is pure for list, i.e. []
 123     g (FunExpr _ k es fs) =
 124 //              tell [Instr "ldr" [Raw "MP"] ("old frame pointer")]
 125                 mapM g es
 126                 >>| jump "bsr" k
 127                 >>| tell [Instr "ldr" [Raw "RR"] ""]
 128
 129 jump :: String String -> Gen ()
 130 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
 131         Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 132         Just (LAB t) = tell [Instr instr [L t] (k +++"()")]
 133         Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label")
 134
 135 instance g Stmt where
 136 //    g (IfStmt cond th el) =
 137 //        fresh >>= \elseLabel->
 138 //        fresh >>= \endLabel->
 139 //        g cond >>|
 140 //        tell [Instr "brf" [L elseLabel] "branch else"] >>|
 141 //        mapM_ g th >>|
 142 //        tell [Instr "bra" [L endLabel] "branch end if"] >>|
 143 //        tell [Lab elseLabel] >>|
 144 //        mapM_ g el  >>|
 145 //        tell [Lab endLabel]
 146 //    g (WhileStmt cond th) =
 147 //        fresh >>= \startLabel->
 148 //        fresh >>= \endLabel ->
 149 //        tell [Lab startLabel] >>|
 150 //        g cond >>|
 151 //        tell [Instr "brf" [L endLabel] "branch end while"] >>|
 152 //        mapM_ g th >>|
 153 //        tell [Instr "bra" [L startLabel] "branch start while"] >>|
 154 //        tell [Lab endLabel]
 155 //    g (AssStmt (VarDef k fs) e) =
 156 //        g e >>|
 157 //        abort "Shit, an assignment, figure out something with storing vars or something"
 158 //        //vars will be on stack in locals (possible pointers to heap)
 159 //    g (FunStmt _ _) = abort "CodeGen, FunStmt unused" //not used
 160     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 161                 >>| tell [Instr "ret" [] ""]
 162     g (ReturnStmt (Just e)) = g e
 163                 >>| tell [Instr "str" [Raw "RR"] ""]
 164                 >>| g (ReturnStmt Nothing)
 165
 166 foldVarDecl :: Int VarDecl -> Gen Int
 167 foldVarDecl x (VarDecl _ _ k e) = g e
 168         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 169
 170 instance g FunDecl where
 171     g (FunDecl _ k _ _ vds stms) =
 172         //varDecls can call the enclosing function, so first reserve a label for it
 173         updateAdressbook (extend k (LAB k)) >>|
 174         tell [Lab k] >>|
 175                 tell [Instr "link" [Lit 0] ""] >>|
 176         //then generate functions for the VarDecls
 177         getAdressbook >>= \oldMap ->
 178         foldM foldVarDecl 1 vds  >>|
 179         //then the main function
 180         mapM_ g stms >>|
 181         updateAdressbook (const oldMap) >>| pure ()
 182 //
 183 //load :: String -> Gen Instr
 184 //load k = genMap >>= \g-> case 'Map'.member k g of
 185 //    False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found in variable mapping"])
 186 //    True = loadP $ 'Map'.find k g
 187 //
 188 //loadP :: LoadPlace -> Gen Instr
 189 //loadP pl = dec pl >>= \(instr, arg)-> pure $ Instr instr [arg] ""
 190 //where
 191 //    dec (LDA i) = pure ("lda", Lit i)
 192 //    dec (LDC i) = pure ("ldc", Lit i)
 193 //    dec (LDH i) = pure ("ldh", Lit i)
 194 //    dec (LDL i) = pure ("ldl", Lit i)
 195 //    dec (LDR i) = pure ("ldr", Lit i)
 196 //    dec (LDS i) = pure ("lds", Lit i)
 197 //    dec _       = liftT (Left $ Error "PANIC: trying to load non adres")
 198 //
 199 ////Instruction (String), key of function to jump to
 200 //jump :: String String -> Gen Instr
 201 //jump instr k = genMap >>= \g-> case 'Map'.member k g of
 202 //    False = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 203 //    True = dec ('Map'.find k g) >>= \lbl-> pure $ Instr instr [lbl] (k +++"()")
 204 //where
 205 //    dec (FUNC l) = pure (L l)
 206 //    dec _ = liftT (Left $ Error "PANIC: trying to jump to non label")
 207
 208 class print a :: a -> [String]
 209
 210 instance print Instr where
 211     print (Lab l) = [l, ":", "\n"]
 212     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 213
 214 instance print [Arg] where
 215     print args = (map toString args)
 216
 217 instance toString Arg where
 218     toString (L l) = l
 219     toString (Lit int) = toString int
 220     toString (Raw s) = s
 221
 222 instance toString SSMProgram where
 223     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p