diff options
Diffstat (limited to 'Sil/Compile.icl')
| -rw-r--r-- | Sil/Compile.icl | 112 |
1 files changed, 81 insertions, 31 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl index 2609f7c..4c0d02d 100644 --- a/Sil/Compile.icl +++ b/Sil/Compile.icl @@ -40,21 +40,23 @@ compile prog = case evalRWST (gen prog) () zero of } :: CompileState = - { labels :: ['ABC'.Label] - , addresses :: 'M'.Map Name Address - , symbols :: 'M'.Map Name FunctionSymbol - , returns :: ['ABC'.Assembler] - , stackoffset :: Int + { labels :: ['ABC'.Label] + , addresses :: 'M'.Map Name Address + , symbols :: 'M'.Map Name FunctionSymbol + , returns :: ['ABC'.Assembler] + , stackoffset :: Int + , storedoffsets :: [Int] } instance zero CompileState where zero = - { labels = ["_l" <+ i \\ i <- [0..]] - , addresses = 'M'.newMap - , symbols = 'M'.newMap - , returns = [] - , stackoffset = 0 + { labels = ["_l" <+ i \\ i <- [0..]] + , addresses = 'M'.newMap + , symbols = 'M'.newMap + , returns = [] + , stackoffset = 0 + , storedoffsets = [] } labels :: CompileState -> ['ABC'.Label] @@ -84,12 +86,19 @@ peekReturn cs = hd cs.returns stackoffset :: CompileState -> Int stackoffset cs = cs.stackoffset +storeStackOffset :: CompileState -> CompileState +storeStackOffset cs = {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]} + +restoreStackOffset :: CompileState -> CompileState +restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos} +where [so:sos] = cs.storedoffsets + :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a -fresh :: Gen 'ABC'.Label -fresh = gets labels +fresh :: a -> Gen 'ABC'.Label | toString a +fresh n = gets labels >>= \labs -> modify (\cs -> {cs & labels=tl labs}) - *> pure (hd labs) + *> pure (n <+ hd labs) reserveVar :: Int Name -> Gen Int reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1) @@ -130,11 +139,14 @@ where , 'ABC'.Label f.f_name ] *> foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *> - modify (newReturn cleanup) *> + modify (newReturn cleanup`) *> gen f.f_code *> + cleanup *> + shrinkStack (args - 1) *> + tell ['ABC'.Rtn] *> modify popReturn where - cleanup = case f.f_args of + cleanup` = case f.f_args of [] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 [] ] _ -> [ 'ABC'.Comment "Cleanup" @@ -147,13 +159,15 @@ where instance gen CodeBlock where - gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *> + gen cb = + modify storeStackOffset *> + foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *> mapM_ gen cb.cb_init *> modify (addToReturn cleanup`) *> mapM_ gen cb.cb_content *> - cleanup *> - tell ['ABC'.Rtn] *> - modify (removeFromReturn $ length cleanup`) + tell cleanup` *> + modify (removeFromReturn $ length cleanup`) *> + modify restoreStackOffset where cleanup` = case cb.cb_init of [] -> [] @@ -164,7 +178,7 @@ where instance gen Initialisation where - gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] + gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1 instance gen Statement where @@ -176,6 +190,28 @@ where gen (Return (Just app)) = comment "Return" *> gen app *> cleanup *> tell ['ABC'.Rtn] gen (Return Nothing) = comment "Return" *> cleanup *> tell ['ABC'.Rtn] gen (MachineStm s) = tell ['ABC'.Raw s] + gen (If c t Nothing) = + fresh "ifend" >>= \end -> + comment "condition" *> + gen c *> + toBStack 'ABC'.BT_Bool 1 *> + tell [ 'ABC'.JmpFalse end ] *> + comment "if-true" *> + gen t *> + tell [ 'ABC'.Label end ] + gen (If c t (Just e)) = + fresh "else" >>= \else -> fresh "ifend" >>= \end -> + comment "condition" *> + gen c *> + toBStack 'ABC'.BT_Bool 1 *> + tell [ 'ABC'.JmpFalse else ] *> + comment "if-true" *> + gen t *> + tell [ 'ABC'.Jmp end + , 'ABC'.Label else ] *> + comment "if-false" *> + gen e *> + tell [ 'ABC'.Label end ] instance gen Application where @@ -197,10 +233,10 @@ where , 'ABC'.Jsr n , 'ABC'.Annotation $ 'ABC'.OAnnot 1 [] ] *> - shrinkStack fs.fs_arity + shrinkStack (fs.fs_arity - 1) _ -> liftT $ Error $ UndefinedName n - gen (BuiltinApp op arg) = gen arg *> gen op *> growStack 1 - gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op *> growStack 1 + gen (BuiltinApp op arg) = gen arg *> gen op + gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op instance gen Op1 where @@ -217,24 +253,38 @@ where gen op = toBStack 'ABC'.BT_Int 2 *> tell [instr] *> - BtoAStack 'ABC'.BT_Int + BtoAStack rettype where instr = case op of - Add -> 'ABC'.AddI - Sub -> 'ABC'.SubI - Mul -> 'ABC'.MulI - Div -> 'ABC'.DivI - Rem -> 'ABC'.RemI + Add -> 'ABC'.AddI + Sub -> 'ABC'.SubI + Mul -> 'ABC'.MulI + Div -> 'ABC'.DivI + Rem -> 'ABC'.RemI + Equals -> 'ABC'.EqI + LogOr -> 'ABC'.AddI // TODO remove hack + LogAnd -> 'ABC'.MulI // TODO remove hack + rettype = case op of + Equals -> 'ABC'.BT_Bool + _ -> 'ABC'.BT_Int toBStack :: 'ABC'.BasicType Int -> Gen () -toBStack t n = tell [push i \\ i <- [0..n-1]] *> tell ['ABC'.Pop_a (n-1)] +toBStack t n = + tell [push i \\ i <- [0..n-1]] *> + tell (if (n <> 0) ['ABC'.Pop_a n] []) *> + shrinkStack n where push = case t of 'ABC'.BT_Bool -> 'ABC'.PushB_a 'ABC'.BT_Int -> 'ABC'.PushI_a BtoAStack :: 'ABC'.BasicType -> Gen () -BtoAStack t = tell [fill 0 0, 'ABC'.Pop_b 1] +BtoAStack t = + tell [ 'ABC'.Create + , fill 0 0 + , 'ABC'.Pop_b 1 + ] *> + growStack 1 where fill = case t of 'ABC'.BT_Bool -> 'ABC'.FillB_b |