diff options
| -rw-r--r-- | Sil/Compile.icl | 73 |
1 files changed, 36 insertions, 37 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl index e930c44..af82f3e 100644 --- a/Sil/Compile.icl +++ b/Sil/Compile.icl @@ -82,40 +82,15 @@ addresses cs = cs.addresses symbols :: CompileState -> 'M'.Map Name FunctionSymbol symbols cs = cs.symbols -newReturn :: 'ABC'.Assembler CompileState -> CompileState -newReturn ret cs = {cs & returns=[ret:cs.returns]} - -addToReturn :: 'ABC'.Assembler CompileState -> CompileState -addToReturn ret cs=:{returns=[r:rs]} = {cs & returns=[ret ++ r:rs]} - -removeFromReturn :: Int CompileState -> CompileState -removeFromReturn i cs=:{returns=[r:rs]} = {cs & returns=[drop i r:rs]} - -popReturn :: CompileState -> CompileState -popReturn cs = {cs & returns=tl cs.returns} - peekReturn :: CompileState -> 'ABC'.Assembler 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 - typeresolvers :: CompileState -> [TypeResolver] typeresolvers cs = cs.typeresolvers -pushTypeResolver :: TypeResolver CompileState -> CompileState -pushTypeResolver tr cs = {cs & typeresolvers=[tr:cs.typeresolvers]} - -popTypeResolver :: CompileState -> CompileState -popTypeResolver cs = {cs & typeresolvers=tl cs.typeresolvers} - :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a fresh :: a -> Gen 'ABC'.Label | toString a @@ -123,6 +98,30 @@ fresh n = gets labels >>= \labs -> modify (\cs -> {cs & labels=tl labs}) $> n <+ hd labs +storeStackOffset :: Gen () +storeStackOffset = modify \cs -> {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]} + +restoreStackOffset :: Gen () +restoreStackOffset = modify \cs=:{storedoffsets=[so:sos]} -> {cs & stackoffset=so, storedoffsets=sos} + +newReturn :: 'ABC'.Assembler -> Gen () +newReturn ret = modify \cs -> {cs & returns=[ret:cs.returns]} + +addToReturn :: 'ABC'.Assembler -> Gen () +addToReturn ret = modify \cs=:{returns=[r:rs]} -> {cs & returns=[ret ++ r:rs]} + +removeFromReturn :: Int -> Gen () +removeFromReturn i = modify \cs=:{returns=[r:rs]} -> {cs & returns=[drop i r:rs]} + +popReturn :: Gen () +popReturn = modify \cs -> {cs & returns=tl cs.returns} + +pushTypeResolver :: TypeResolver -> Gen () +pushTypeResolver tr = modify \cs -> {cs & typeresolvers=[tr:cs.typeresolvers]} + +popTypeResolver :: Gen () +popTypeResolver = modify \cs -> {cs & typeresolvers=tl cs.typeresolvers} + getTypeResolver :: Gen TypeResolver getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n -> case catMaybes $ map (flip ($) n) trs of @@ -174,10 +173,10 @@ where , 'ABC'.Fill "_" 0 "main" 0 , 'ABC'.Jmp "_driver" ] *> - modify (pushTypeResolver typeresolver) *> + pushTypeResolver typeresolver *> mapM_ addFunction p.p_funs *> mapM_ gen p.p_funs *> - modify popTypeResolver + popTypeResolver where typeresolver :: Name -> Maybe (MaybeError TypeError Type) typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of @@ -191,14 +190,14 @@ where , 'ABC'.Label f.f_name ] *> foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *> - modify (newReturn cleanup`) *> - modify (pushTypeResolver typeresolver) *> + newReturn cleanup` *> + pushTypeResolver typeresolver *> gen f.f_code *> - modify popTypeResolver *> + popTypeResolver *> cleanup *> modify (\cs -> {cs & stackoffset=0}) *> tell ['ABC'.Rtn] *> - modify popReturn + popReturn where cleanup` = case f.f_args of [] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot retSize [] @@ -218,16 +217,16 @@ where instance gen CodeBlock where gen cb = - modify storeStackOffset *> + storeStackOffset *> foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *> mapM_ gen cb.cb_init *> - modify (addToReturn cleanup`) *> - modify (pushTypeResolver typeresolver) *> + addToReturn cleanup` *> + pushTypeResolver typeresolver *> mapM_ gen cb.cb_content *> - modify popTypeResolver *> + popTypeResolver *> tell cleanup` *> - modify (removeFromReturn $ length cleanup`) *> - modify restoreStackOffset + removeFromReturn (length cleanup`) *> + restoreStackOffset where cleanup` = case cb.cb_init of [] -> [] |