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 Int Int | ADDR Int Int
  37 :: Gen a :== RWST () SSMProgram (Addressbook, [Label]) (Either GenError) a
  38
  39 labelStream :: [Label]
  40 labelStream = ["lbl_" +++ toString i\\i<-[1..]]
  41
  42 defaultAddressBook :: [FunDecl] -> Addressbook
  43 defaultAddressBook fd = extend "1printint" (LAB "1printint" 1 0)
  44         $ extend "1printchar" (LAB "1printchar" 1 1)
  45         $ extend "read" (LAB "read" 0 2)
  46         $ extend "isEmpty" (LAB "isEmpty" 1 3)
  47         $ addFuncs fd 4
  48         where
  49                 addFuncs [] _ = 'Map'.newMap
  50                 addFuncs [(FunDecl _ k args _ _ _):xs] n =
  51                         extend k (LAB k (length args) n) $ addFuncs xs (n+1)
  52
  53 gen :: AST -> Either String String
  54 gen (AST fds) = case evalRWST prog () (defaultAddressBook fds, labelStream) of
  55             Left (Error e) = Left e
  56             Right (_, p) = Right $ toString p
  57     where
  58         prog = tell [
  59                         Instr "bsr" [L "main"] "",
  60                         Instr "halt" [] ""
  61                         ] >>| tell (programContext fds)
  62             >>| mapM_ g fds
  63
  64 programContext :: [FunDecl] -> SSMProgram
  65 programContext x = [Lab "1func"
  66                                 :fS ["1printint" ,"1printchar","read"
  67                                         ,"isEmpty":map (\(FunDecl _ k _ _ _ _)->k) x] 0] ++ context
  68         where
  69
  70                 fS :: [String] Int -> SSMProgram
  71                 fS [] _ = []
  72                 fS [k:xs] n = [
  73                          Lab $ "1next" +++ toString n
  74                         ,Instr "ldr" [Raw "R5"] ""
  75                         ,Instr "ldc" [Lit n] $ "branch to: " +++ k
  76                         ,Instr "eq" [] ""
  77                         ,if (isEmpty xs)
  78                                 (Instr "nop" [] "")
  79                                 (Instr "brf" [L $ "1next" +++ (toString $ n + 1)] "")
  80                         ,Instr "bra" [L k] ""
  81                         :fS xs $ n+1]
  82                 context :: SSMProgram
  83                 context =   [Lab "1printint"
  84                     ,Instr "link" [Lit 0] ""
  85                     ,Instr "ldl" [Lit -2] "load first argument"
  86                                         ,Instr "trap" [Lit 0] "print int"
  87                     ,Instr "unlink" [] ""
  88                     ,Instr "ret" [] ""
  89                                         ,Lab "1printchar"
  90                     ,Instr "link" [Lit 0] ""
  91                     ,Instr "ldl" [Lit -2] "load first argument"
  92                                         ,Instr "trap" [Lit 1] "print char"
  93                     ,Instr "unlink" [] ""
  94                     ,Instr "ret" [] ""
  95                     ,Lab "read"
  96                     ,Instr "link" [Lit 0] ""
  97                                         ,Instr "trap" [Lit 11] "read char"
  98                     ,Instr "str" [Raw "RR"] ""
  99                     ,Instr "unlink" [] ""
 100                     ,Instr "ret" [] ""
 101                     ,Lab "isEmpty"
 102                     ,Instr "link" [Lit 0] ""
 103                     ,Instr "ldl" [Lit -2] "load prt to list"
 104                     ,Instr "lda" [Lit 0] "derefrence ptr"
 105                     ,Instr "ldc" [Lit 0] ""
 106                     ,Instr "eq" [] "test for null pointer"
 107                     ,Instr "str" [Raw "RR"] ""
 108                     ,Instr "unlink" [] ""
 109                     ,Instr "ret" [] ""
 110                     ,Lab "read"
 111                     ]
 112
 113 getAdressbook :: Gen Addressbook
 114 getAdressbook = gets fst
 115
 116 updateAdressbook :: (Addressbook -> Addressbook) -> Gen Addressbook
 117 updateAdressbook f = modify (appFst f) >>| getAdressbook
 118
 119 extend :: String Address Addressbook -> Addressbook
 120 extend k pl g = 'Map'.put k pl g
 121
 122 fresh :: Gen Label
 123 fresh = gets snd >>= \vars->
 124         modify (appSnd $ const $ tail vars) >>|
 125         pure (head vars)
 126
 127 class g a :: a -> Gen ()
 128
 129 instance g Op1 where
 130         g UnNegation = tell [Instr "not" [] ""]
 131         g UnMinus = tell [Instr "neg" [] ""]
 132
 133 instance g Op2 where
 134         g o = tell [Instr s [] ""]
 135                 where
 136                         s = case o of
 137                     BiPlus = "add"
 138                                 BiMinus = "sub"
 139                     BiTimes = "mul"
 140                     BiDivide = "div"
 141                     BiMod = "mod"
 142                     BiEquals = "eq"
 143                     BiLesser = "lt"
 144                     BiGreater = "gt"
 145                     BiLesserEq = "le"
 146                     BiGreaterEq = "ge"
 147                     BiUnEqual = "ne"
 148                     BiAnd =  "and"
 149                     BiOr = "or"
 150                     BiCons = abort "Shit, Cons, how to deal with this?"
 151
 152 instance g FieldSelector where
 153         g FieldFst = tell [Instr "lda" [Lit -1] "fst"]
 154         g FieldSnd = tell [Instr "lda" [Lit 0] "snd"]
 155         g FieldHd = tell [Instr "lda" [Lit -1] "hd"]
 156         g FieldTl = tell [Instr "lda" [Lit 0] "tl"]
 157
 158 instance g Expr where
 159     g (IntExpr _ i) = tell [Instr "ldc" [Lit i] ""]
 160     g (CharExpr _ c) = tell [Instr "ldc" [Lit (toInt c)] ""]
 161         g (BoolExpr _ b) = tell [Instr "ldc" [Lit (if b TRUE FALSE)] ""]
 162     g (EmptyListExpr _) = tell [Instr "ldc" [Lit 0] ""]
 163                 >>| tell [Instr "sth" [] ""]
 164     g (Op1Expr _ o e) = g e >>| g o
 165     g (Op2Expr _ e1 BiCons e2) = g e2 >>| g e1
 166                 >>| tell [Instr "sth" [] ""]
 167                 >>| tell [Instr "ajs" [Lit -1] ""]
 168                 >>| tell [Instr "sth" [] ""]
 169     g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op
 170     g (TupleExpr _ (e1,e2)) = g e1
 171                 >>| g e2
 172                 >>| tell [Instr "stmh" [Lit 2] ""]
 173     g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of
 174                 Just (ADDR t arity) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure ()
 175                 Just (LAB l _ fn) = tell
 176                         [Instr "ldc" [Lit fn] ""
 177                         ,Instr "sth" [] ""
 178                         ,Instr "ldc" [Lit 0] ""
 179                         ,Instr "sth" [] ""
 180                         ,Instr "ajs" [Lit -1] ""]
 181                 Nothing = liftT $ Left $ Error "PANIC: unresolver variable expr"
 182     g (LambdaExpr _ _ _) = liftT $ Left $ Error "PANIC: Lambdas should be unfolded"
 183     g (FunExpr _ k es fs) = funnyStuff k es fs
 184
 185 funnyStuff :: String [Expr] [FieldSelector] -> Gen ()
 186 funnyStuff k es fs = getAdressbook >>= \ab->case 'Map'.get k ab of
 187         //Identifier points to function
 188         Just (LAB l arity fn) = if (arity <> (length es))
 189                 //Function is not complete
 190                 (       mapM_ g es
 191                         >>| tell
 192                                 [Instr "ldc" [Lit fn] "Store function number"
 193                                 ,Instr "sth" [] ""
 194                                 ,Instr "str" [Raw "R7"] ""
 195                                 ,Instr "ldc" [Lit $ length es] "Store arity"
 196                                 ,Instr "sth" [] ""
 197                                 ,Instr "ajs" [Lit -1] ""
 198                                 ]
 199                         >>| if (isEmpty es) (pure ()) (tell
 200                                 [Instr "stmh" [Lit $ length es] "Store arguments"
 201                                 ,Instr "ajs" [Lit -1] ""
 202                                 ,Instr "ldr" [Raw "R7"] ""]))
 203                 //Function is complete
 204                 (       mapM_ g es
 205                         >>| getAdressbook >>= \ab->(case 'Map'.get k ab of
 206                                 Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 207                                 Just (LAB t _ _) = tell [Instr "bsr" [L t] (k +++"()")]
 208                                 Just (ADDR t arity) = liftT (Left $ Error "NO ADDRESS JUMPING FFS")
 209                         )
 210                 >>| tell
 211                                 [Instr "ajs" [Lit $ ~(length es)] "Clean arguments"
 212                                 ,Instr "ldr" [Raw "RR"] ""])
 213         //Identifier points to variable, thus higher order function
 214         Just (ADDR t arity) = if (arity <> (length es))
 215                 //Function is still  not complete
 216                 ( fresh >>= \finish->fresh >>= \start->tell [
 217                         //Store function number
 218                          Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE"
 219                         ,Instr "ldh" [Lit 0] "get function number"
 220                         ,Instr "sth" [] "Store"
 221                         //Store function arity
 222                         ,Instr "ldl" [Lit t] "get pointer again"
 223                         ,Instr "ldh" [Lit 1] "get function arity"
 224                         ,Instr "ldc" [Lit $ length es] "add argument number"
 225                         ,Instr "add" [] "add"
 226                         ,Instr "sth" [] "Store"
 227                         ,Instr "ajs" [Lit -1] "Adjust pointer"
 228                         //load the arguments
 229                         ,Instr "ldl" [Lit t] ""
 230                         ,Instr "ldh" [Lit 1] "Load available arguments"
 231                         ,Instr "str" [Raw "R5"] "Store available args in register"
 232                         ,Instr "ldc" [Lit 0] "Store offset"
 233                         ,Instr "str" [Raw "R6"] "Store offset in register"
 234                         ,Lab start
 235                         ,Instr "ldr" [Raw "R5"] ""
 236                         ,Instr "ldc" [Lit 0] ""
 237                         ,Instr "eq" [] ""
 238                         ,Instr "brt" [L finish] "Done pushing arg, bye"
 239                         //Load heapadress
 240                         ,Instr "ldl" [Lit t] ""
 241                         ,Instr "ldr" [Raw "R6"] ""
 242                         ,Instr "add" [] "Corrected heapaddress"
 243                         ,Instr "ldh" [Lit 2] "Load argument"
 244                         ,Instr "sth" [] "And store it immediatly after"
 245                         //Decrease available arguments
 246                         ,Instr "ldr" [Raw "R5"] ""
 247                         ,Instr "ldc" [Lit 1] ""
 248                         ,Instr "sub" [] ""
 249                         ,Instr "str" [Raw "R5"] ""
 250                         //Increase available arguments
 251                         ,Instr "ldr" [Raw "R6"] ""
 252                         ,Instr "ldc" [Lit 1] ""
 253                         ,Instr "add" [] ""
 254                         ,Instr "str" [Raw "R6"] ""
 255                         ,Instr "bra" [L start] ""
 256                         ,Lab finish
 257                         ]
 258                   >>| mapM_ g es
 259                   >>| tell
 260                                 [Instr "stmh" [Lit $ length es] "Store extra args"
 261                                 ,Instr "ajs" [Lit -1] ""]
 262                 )
 263                 //Function is complete
 264                 ( fresh >>= \finish->fresh >>= \start->tell [
 265                          Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL"
 266                         ,Instr "ldh" [Lit 1] "Load available arguments"
 267                         ,Instr "str" [Raw "R5"] "Store available args in register"
 268                         ,Instr "ldc" [Lit 0] "Store offset"
 269                         ,Instr "str" [Raw "R6"] "Store offset in register"
 270
 271                         ,Lab start
 272                         ,Instr "ldr" [Raw "R5"] ""
 273                         ,Instr "ldc" [Lit 0] ""
 274                         ,Instr "eq" [] ""
 275                         ,Instr "brt" [L finish] "Done pushing arg, bye"
 276                         //Load heapadress
 277                         ,Instr "ldl" [Lit t] ""
 278                         ,Instr "ldr" [Raw "R6"] ""
 279                         ,Instr "add" [] "Corrected heapaddress"
 280                         ,Instr "ldh" [Lit 2] "Load argument"
 281                         //Decrease available arguments
 282                         ,Instr "ldr" [Raw "R5"] ""
 283                         ,Instr "ldc" [Lit 1] ""
 284                         ,Instr "sub" [] ""
 285                         ,Instr "str" [Raw "R5"] ""
 286                         //Increase available arguments
 287                         ,Instr "ldr" [Raw "R6"] ""
 288                         ,Instr "ldc" [Lit 1] ""
 289                         ,Instr "add" [] ""
 290                         ,Instr "str" [Raw "R6"] ""
 291                         ,Instr "bra" [L start] ""
 292                         ,Lab finish
 293                         ]
 294                   >>| mapM_ g es
 295                   >>| tell
 296                         [Instr "ldl" [Lit t] ""
 297                         ,Instr "ldh" [Lit 0] "Get function number"
 298                         ,Instr "str" [Raw "R5"] ""
 299                         ,Instr "bsr" [L "1func"] "HIGHER ORDER END"
 300                         ,Instr "ldl" [Lit t] ""
 301                         ,Instr "ldh" [Lit 1] ""
 302                         ,Instr "neg" [] ""
 303                         ,Instr "ldr" [Raw "SP"] ""
 304                         ,Instr "add" [] ""
 305                         ,Instr "ldc" [Lit $ length es + 1] ""
 306                         ,Instr "sub" [] ""
 307                         ,Instr "str" [Raw "SP"] ""
 308                         ,Instr "ldr" [Raw "RR"] ""
 309                         ]
 310                 )
 311         Nothing = liftT (Left $ Error $ "PANIC: Undefined function: " +++ k)
 312
 313 instance g Stmt where
 314     g (IfStmt cond th el) =
 315         fresh >>= \elseLabel->
 316         fresh >>= \endLabel->
 317         g cond >>|
 318        tell [Instr "brf" [L elseLabel] "branch else"] >>|
 319         mapM_ g th >>|
 320         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 321         tell [Lab elseLabel] >>|
 322         mapM_ g el  >>|
 323         tell [Lab endLabel]
 324     g (WhileStmt cond th) =
 325         fresh >>= \startLabel->
 326         fresh >>= \endLabel ->
 327         tell [Lab startLabel] >>|
 328         g cond >>|
 329         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 330         mapM_ g th >>|
 331         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 332         tell [Lab endLabel]
 333     g (AssStmt (VarDef k fs) e) =
 334         g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
 335             Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
 336             Just (LAB t _ _) = liftT (Left $ Error $ "PANIC: cannot assign to function")
 337             Just (ADDR t ar) = case fs of
 338                 []  = tell [Instr "stl" [Lit t] ""]
 339                 _   = tell [Instr "ldl" [Lit t] ""]
 340                         >>| mapM_ followFs fs
 341                         >>| tell [Instr "sta" [Lit 0] ""]
 342     g (FunStmt k es fs) = funnyStuff k es fs
 343     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 344                 >>| tell [Instr "ret" [] ""]
 345     g (ReturnStmt (Just e)) = g e
 346                 >>| tell [Instr "str" [Raw "RR"] ""]
 347                 >>| g (ReturnStmt Nothing)
 348
 349 //expects the heap address to the var to slect on to be on the stack
 350 //and leaves the heap adress to write to on the stack
 351 followFs :: FieldSelector -> Gen()
 352 followFs FieldHd = tell [Instr "ldc" [Lit 1] "select hd"
 353                         ,Instr "sub" [] "select hd"]
 354 followFs FieldTl = tell []
 355 followFs FieldFst = tell [Instr "ldc" [Lit 1] "select fst"
 356                          ,Instr "sub" [] "select fst"]
 357 followFs FieldSnd = tell []
 358
 359 foldVarDecl :: Int VarDecl -> Gen Int
 360 foldVarDecl x (VarDecl _ mt k e) = g e
 361     >>| annote x k
 362         >>| updateAdressbook (extend k (ADDR x $ arity $ fromJust mt))
 363         >>| pure (x + 1)
 364
 365 arity :: Type -> Int
 366 arity (_ ->> x) = 1 + arity x
 367 arity _ = 0
 368
 369 addVars :: Type [String] -> (Addressbook -> Addressbook)
 370 addVars _ [] = id
 371 addVars (t ->> ts) [x:xs] = \ab->
 372         extend x (ADDR (-2 - (length xs)) (arity t)) (addVars ts xs ab)
 373 addVars t [x] = \ab->
 374         extend x (ADDR -2 0) ab
 375
 376 instance g FunDecl where
 377     g (FunDecl _ k args mt vds stms) =
 378         //varDecls can call the enclosing function, so first reserve a label for it
 379         getAdressbook >>= \oldMap ->
 380                 updateAdressbook (addVars (fromJust mt) args) >>|
 381         tell [Lab k] >>|
 382                 tell [Instr "link" [Lit 0] ""] >>|
 383         //add the vars
 384         foldM foldVarDecl 1 vds  >>|
 385         //and the statements
 386         mapM_ g stms >>|
 387                 //Ugly hack to always return
 388                 g (ReturnStmt Nothing) >>|
 389         updateAdressbook (const oldMap) >>| pure ()
 390
 391 annote :: Int String -> Gen ()
 392 annote pos key =
 393     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "black", Raw key] ""]
 394
 395 class print a :: a -> [String]
 396
 397 instance print Instr where
 398     print (Lab l) = [l, ":", "\n"]
 399     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 400
 401 instance print [Arg] where
 402     print args = (map toString args)
 403
 404 instance toString Arg where
 405     toString (L l) = l
 406     toString (Lit int) = toString int
 407     toString (Raw s) = s
 408
 409 instance toString SSMProgram where
 410     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p