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                 mapM_ g es
 125                 >>| jump "bsr" k
 126         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 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 >>| getAdressbook >>= \ab->case 'Map'.get k ab of
 157             Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
 158             Just (LAB t) = liftT (Left $ Error $ "PANIC: cannot assign to function")
 159             Just (ADDR t) = tell [Instr "stl" [Lit t] ""]
 160     g (FunStmt k es) = mapM_ g es
 161         >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args
 162         >>| jump "bsr" k
 163     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 164                 >>| tell [Instr "ret" [] ""]
 165     g (ReturnStmt (Just e)) = g e
 166                 >>| tell [Instr "str" [Raw "RR"] ""]
 167                 >>| g (ReturnStmt Nothing)
 168
 169 foldVarDecl :: Int VarDecl -> Gen Int
 170 foldVarDecl x (VarDecl _ _ k e) = g e
 171     >>| annote x k
 172         >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1)
 173
 174 addVars :: [String] -> (Addressbook -> Addressbook)
 175 addVars [] = id
 176 addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab)
 177
 178 instance g FunDecl where
 179     g (FunDecl _ k args _ vds stms) =
 180         //varDecls can call the enclosing function, so first reserve a label for it
 181         updateAdressbook (extend k (LAB k)) >>|
 182         getAdressbook >>= \oldMap ->
 183                 updateAdressbook (addVars args) >>|
 184         tell [Lab k] >>|
 185                 tell [Instr "link" [Lit 0] ""] >>|
 186         //add the vars
 187         foldM foldVarDecl 1 vds  >>|
 188         //and the statements
 189         mapM_ g stms >>|
 190         updateAdressbook (const oldMap) >>| pure ()
 191
 192 annote :: Int String -> Gen ()
 193 annote pos key =
 194     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "green", Raw key] ""]
 195
 196 class print a :: a -> [String]
 197
 198 instance print Instr where
 199     print (Lab l) = [l, ":", "\n"]
 200     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 201
 202 instance print [Arg] where
 203     print args = (map toString args)
 204
 205 instance toString Arg where
 206     toString (L l) = l
 207     toString (Lit int) = toString int
 208     toString (Raw s) = s
 209
 210 instance toString SSMProgram where
 211     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p