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 "1readint" (LAB "1readint" 0 3)
  47         $ extend "isEmpty" (LAB "isempty" 1 4)
  48         $ addFuncs fd 5
  49         where
  50                 addFuncs [] _ = 'Map'.newMap
  51                 addFuncs [(FunDecl _ k args _ _ _):xs] n =
  52                         extend k (LAB k (length args) n) $ addFuncs xs (n+1)
  53
  54 gen :: AST -> Either String String
  55 gen (AST fds) = case evalRWST prog () (defaultAddressBook fds, labelStream) of
  56             Left (Error e) = Left e
  57             Right (_, p) = Right $ toString p
  58     where
  59         prog = tell [
  60                         Instr "bsr" [L "main"] "",
  61                         Instr "halt" [] ""
  62                         ] >>| tell (programContext fds)
  63             >>| mapM_ g fds
  64
  65 programContext :: [FunDecl] -> SSMProgram
  66 programContext x = [Lab "1func"
  67                                 :fS ["1printint" ,"1printchar"
  68                                         ,"read" ,"1readint"
  69                                         ,"isEmpty":map (\(FunDecl _ k _ _ _ _)->k) x] 0] ++ context
  70         where
  71
  72                 fS :: [String] Int -> SSMProgram
  73                 fS [] _ = []
  74                 fS [k:xs] n = [
  75                          Lab $ "1next" +++ toString n
  76                         ,Instr "ldr" [Raw "R5"] ""
  77                         ,Instr "ldc" [Lit n] $ "branch to: " +++ k
  78                         ,Instr "eq" [] ""
  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 "ldc" [Lit 0] ""
 178                         ,Instr "stmh" [Lit 2] ""]
 179     g (FunExpr _ k es fs) = getAdressbook >>= \ab->case 'Map'.get k ab of
 180                 //Identifier points to function
 181                 Just (LAB l arity fn) = if (arity <> (length es))
 182                         //Function is not complete
 183                         (       tell
 184                                         [Instr "ldc" [Lit fn] "Store function number"
 185                                         ,Instr "sth" [] ""
 186                                         ,Instr "ldc" [Lit $ length es] "Store arity"
 187                                         ,Instr "sth" [] ""
 188                                         ,Instr "ajs" [Lit -1] ""]
 189                                 >>| mapM_ g es
 190                                 >>| if (isEmpty es) (pure ()) (tell
 191                                         [Instr "stmh" [Lit $ length es] "Store arguments"
 192                                         ,Instr "ajs" [Lit -1] ""]))
 193                         //Function is complete
 194                         (       mapM_ g es
 195                                 >>| jump "bsr" k
 196                         >>| tell
 197                                         [Instr "ajs" [Lit $ ~(length es)] "Clean arguments"
 198                                         ,Instr "ldr" [Raw "RR"] ""])
 199                 //Identifier points to variable, thus higher order function
 200                 Just (ADDR t arity) = if (arity <> (length es))
 201                         //Function is still  not complete
 202                         ( fresh >>= \finish->fresh >>= \start->tell [
 203                                 //Store function number
 204                                  Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE"
 205                                 ,Instr "ldh" [Lit 0] "get function number"
 206                                 ,Instr "sth" [] "Store"
 207                                 //Store function arity
 208                                 ,Instr "ldl" [Lit t] "get pointer again"
 209                                 ,Instr "ldh" [Lit 1] "get function arity"
 210                                 ,Instr "ldc" [Lit $ length es] "add argument number"
 211                                 ,Instr "add" [] "add"
 212                                 ,Instr "sth" [] "Store"
 213                                 ,Instr "ajs" [Lit -1] "Adjust pointer"
 214                                 //load the arguments
 215                                 ,Instr "ldl" [Lit t] ""
 216                                 ,Instr "ldh" [Lit 1] "Load available arguments"
 217                                 ,Instr "str" [Raw "R5"] "Store available args in register"
 218                                 ,Instr "ldc" [Lit 0] "Store offset"
 219                                 ,Instr "str" [Raw "R6"] "Store offset in register"
 220                                 ,Lab start
 221                                 ,Instr "ldr" [Raw "R5"] ""
 222                                 ,Instr "ldc" [Lit 0] ""
 223                                 ,Instr "eq" [] ""
 224                                 ,Instr "brt" [L finish] "Done pushing arg, bye"
 225                                 //Load heapadress
 226                                 ,Instr "ldl" [Lit t] ""
 227                                 ,Instr "ldr" [Raw "R6"] ""
 228                                 ,Instr "add" [] "Corrected heapaddress"
 229                                 ,Instr "ldh" [Lit 2] "Load argument"
 230                                 ,Instr "sth" [] "And store it immediatly after"
 231                                 //Decrease available arguments
 232                                 ,Instr "ldr" [Raw "R5"] ""
 233                                 ,Instr "ldc" [Lit 1] ""
 234                                 ,Instr "sub" [] ""
 235                                 ,Instr "str" [Raw "R5"] ""
 236                                 //Increase available arguments
 237                                 ,Instr "ldr" [Raw "R6"] ""
 238                                 ,Instr "ldc" [Lit 1] ""
 239                                 ,Instr "add" [] ""
 240                                 ,Instr "str" [Raw "R6"] ""
 241                                 ,Instr "bra" [L start] ""
 242                                 ,Lab finish
 243                                 ]
 244                           >>| mapM_ g es
 245                           >>| tell
 246                                         [Instr "stmh" [Lit $ length es] "Store extra args"
 247                                         ,Instr "ajs" [Lit -1] ""]
 248                         )
 249                         //Function is complete
 250                         ( fresh >>= \finish->fresh >>= \start->tell [
 251                                  Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL"
 252                                 ,Instr "ldh" [Lit 1] "Load available arguments"
 253                                 ,Instr "str" [Raw "R5"] "Store available args in register"
 254                                 ,Instr "ldc" [Lit 0] "Store offset"
 255                                 ,Instr "str" [Raw "R6"] "Store offset in register"
 256
 257                                 ,Lab start
 258                                 ,Instr "ldr" [Raw "R5"] ""
 259                                 ,Instr "ldc" [Lit 0] ""
 260                                 ,Instr "eq" [] ""
 261                                 ,Instr "brt" [L finish] "Done pushing arg, bye"
 262                                 //Load heapadress
 263                                 ,Instr "ldl" [Lit t] ""
 264                                 ,Instr "ldr" [Raw "R6"] ""
 265                                 ,Instr "add" [] "Corrected heapaddress"
 266                                 ,Instr "ldh" [Lit 2] "Load argument"
 267                                 //Decrease available arguments
 268                                 ,Instr "ldr" [Raw "R5"] ""
 269                                 ,Instr "ldc" [Lit 1] ""
 270                                 ,Instr "sub" [] ""
 271                                 ,Instr "str" [Raw "R5"] ""
 272                                 //Increase available arguments
 273                                 ,Instr "ldr" [Raw "R6"] ""
 274                                 ,Instr "ldc" [Lit 1] ""
 275                                 ,Instr "add" [] ""
 276                                 ,Instr "str" [Raw "R6"] ""
 277                                 ,Instr "bra" [L start] ""
 278                                 ,Lab finish
 279                                 ]
 280                           >>| mapM_ g es
 281                           >>| tell
 282                                 [Instr "ldl" [Lit t] ""
 283                                 ,Instr "ldh" [Lit 0] "Get function number"
 284                                 ,Instr "str" [Raw "R5"] ""
 285                                 ,Instr "bsr" [L "1func"] "HIGHER ORDER END"
 286                                 ,Instr "ldl" [Lit t] ""
 287                                 ,Instr "ldh" [Lit 1] ""
 288                                 ,Instr "neg" [] ""
 289                                 ,Instr "ldr" [Raw "SP"] ""
 290                                 ,Instr "add" [] ""
 291                                 ,Instr "ldc" [Lit $ length es + 1] ""
 292                                 ,Instr "sub" [] ""
 293                                 ,Instr "str" [Raw "SP"] ""
 294                                 ,Instr "ldr" [Raw "RR"] ""
 295                                 //RR is nu goed
 296 //                              ,Instr "ajs" [Lit $ ~ (length es)] ""
 297 //                              ,Instr "ldl" [Lit t] ""
 298 //                              ,Instr "ldr" [Raw "RR"] "END OF HIGHERORDERFUNCALL"
 299         //                      ,Instr "ldl" [Lit t] ""
 300         //                      ,Instr "ldh" [Lit $ 1] ""
 301         //                      ,Instr "neg" [] ""
 302         //                      ,Instr "ldr" [Raw "SP"] ""
 303         //                      ,Instr "add" [] ""
 304         //                      ,Instr "ldc" [Lit arity] ""
 305         //                      ,Instr "sub" [] ""
 306         //                      ,Instr "str" [Raw "SP"] ""
 307                                 ]
 308                         )
 309                 Nothing = liftT (Left $ Error "Undefined function!!!")
 310
 311 jump :: String String -> Gen ()
 312 jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
 313         Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
 314         Just (LAB t _ _) = tell [Instr instr [L t] (k +++"()")]
 315         Just (ADDR t arity) = abort "NO ADDRESS JUMPING FFS"
 316
 317 instance g Stmt where
 318     g (IfStmt cond th el) =
 319         fresh >>= \elseLabel->
 320         fresh >>= \endLabel->
 321         g cond >>|
 322        tell [Instr "brf" [L elseLabel] "branch else"] >>|
 323         mapM_ g th >>|
 324         tell [Instr "bra" [L endLabel] "branch end if"] >>|
 325         tell [Lab elseLabel] >>|
 326         mapM_ g el  >>|
 327         tell [Lab endLabel]
 328     g (WhileStmt cond th) =
 329         fresh >>= \startLabel->
 330         fresh >>= \endLabel ->
 331         tell [Lab startLabel] >>|
 332         g cond >>|
 333         tell [Instr "brf" [L endLabel] "branch end while"] >>|
 334         mapM_ g th >>|
 335         tell [Instr "bra" [L startLabel] "branch start while"] >>|
 336         tell [Lab endLabel]
 337     g (AssStmt (VarDef k fs) e) =
 338         g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of
 339             Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"])
 340             Just (LAB t _ _) = liftT (Left $ Error $ "PANIC: cannot assign to function")
 341             Just (ADDR t ar) = tell [Instr "stl" [Lit t] ""]
 342     g (FunStmt k es fs) = mapM_ g es
 343         >>| jump "bsr" k
 344         >>| tell [Instr "ajs" [Lit (~(length es))] ""] //clean up args
 345         >>| mapM_ g fs
 346                 >>| pure ()
 347     g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""]
 348                 >>| tell [Instr "ret" [] ""]
 349     g (ReturnStmt (Just e)) = g e
 350                 >>| tell [Instr "str" [Raw "RR"] ""]
 351                 >>| g (ReturnStmt Nothing)
 352
 353 foldVarDecl :: Int VarDecl -> Gen Int
 354 foldVarDecl x (VarDecl _ mt k e) = g e
 355     >>| annote x k
 356         >>| updateAdressbook (extend k (ADDR x $ arity $ fromJust mt))
 357         >>| pure (x + 1)
 358
 359 arity :: Type -> Int
 360 arity (_ ->> x) = 1 + arity x
 361 arity _ = 0
 362
 363 addVars :: Type [String] -> (Addressbook -> Addressbook)
 364 addVars _ [] = id
 365 addVars (t ->> ts) [x:xs] = \ab->
 366         extend x (ADDR (-2 - (length xs)) (arity t)) (addVars ts xs ab)
 367 addVars t [x] = \ab->
 368         extend x (ADDR -2 0) ab
 369
 370 instance g FunDecl where
 371     g (FunDecl _ k args mt vds stms) =
 372         //varDecls can call the enclosing function, so first reserve a label for it
 373         getAdressbook >>= \oldMap ->
 374                 updateAdressbook (addVars (fromJust mt) args) >>|
 375         tell [Lab k] >>|
 376                 tell [Instr "link" [Lit 0] ""] >>|
 377         //add the vars
 378         foldM foldVarDecl 1 vds  >>|
 379         //and the statements
 380         mapM_ g stms >>|
 381                 //Ugly hack to always return
 382                 g (ReturnStmt Nothing) >>|
 383         updateAdressbook (const oldMap) >>| pure ()
 384
 385 annote :: Int String -> Gen ()
 386 annote pos key =
 387     tell [Instr "annote" [Raw "MP", Lit pos, Lit pos, Raw "black", Raw key] ""]
 388
 389 class print a :: a -> [String]
 390
 391 instance print Instr where
 392     print (Lab l) = [l, ":", "\n"]
 393     print (Instr i args com) = ["\t", i] ++ print args ++ [" ;", com, "\n"]
 394
 395 instance print [Arg] where
 396     print args = (map toString args)
 397
 398 instance toString Arg where
 399     toString (L l) = l
 400     toString (Lit int) = toString int
 401     toString (Raw s) = s
 402
 403 instance toString SSMProgram where
 404     toString p = concat $ intersperse " " $ map (\i-> concat $ intersperse " " $ print i) p