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 addVars :: [String] -> (Addressbook -> Addressbook)
 171 addVars [] = id
 172 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 173
 174 instance g FunDecl where
 175     g (FunDecl _ k args _ vds stms) =
 176         //varDecls can call the enclosing function, so first reserve a label for it
 177         updateAdressbook (extend k (LAB k)) >>|
 178         getAdressbook >>= \oldMap ->
 179                 updateAdressbook (addVars args) >>|
 180         tell [Lab k] >>|
 181                 tell [Instr "link" [Lit 0] ""] >>|
 182         //then generate functions for the VarDecls
 183         foldM foldVarDecl 1 vds  >>|
 184         //then the main function
 185         mapM_ g stms >>|
 186         updateAdressbook (const oldMap) >>| pure ()
 187
 188 class print a :: a -> [String]
 189
 190 instance print Instr where
 191     print (Lab l) = [l, ":", "\n"]
 192     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 193
 194 instance print [Arg] where
 195     print args = (map toString args)
 196
 197 instance toString Arg where
 198     toString (L l) = l
 199     toString (Lit int) = toString int
 200     toString (Raw s) = s
 201
 202 instance toString SSMProgram where
 203     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p