diff options
| -rw-r--r-- | Sil/Compile.icl | 234 | ||||
| -rw-r--r-- | Sil/Types.dcl | 17 | ||||
| -rw-r--r-- | Sil/Types.icl | 29 | ||||
| -rw-r--r-- | examples/while.sil | 9 |
4 files changed, 204 insertions, 85 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl index 49546df..56fef05 100644 --- a/Sil/Compile.icl +++ b/Sil/Compile.icl @@ -3,6 +3,7 @@ implementation module Sil.Compile import StdEnum from StdFunc import const, flip, o import StdList +import StdMisc import StdString import Control.Applicative @@ -12,9 +13,11 @@ import Control.Monad.Trans import Data.Error from Data.Func import $ import Data.Functor +import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid +import Data.Tuple from Text import <+ import qualified ABC.Assembler as ABC @@ -61,11 +64,19 @@ where isUseful ('ABC'.Comment _) = False isUseful _ = True -:: Address :== Int +:: Address + = AAddr Int + | BAddr Int + +instance toString Address +where + toString (AAddr i) = "A:" <+ i + toString (BAddr i) = "B:" <+ i :: FunctionSymbol = - { fs_arity :: Int - , fs_rettype :: Type + { fs_arity :: Int + , fs_argtypes :: [Type] + , fs_rettype :: Type } :: CompileState = @@ -73,8 +84,9 @@ where , addresses :: 'M'.Map Name Address , symbols :: 'M'.Map Name FunctionSymbol , returns :: ['ABC'.Assembler] - , stackoffset :: Int - , storedoffsets :: [Int] + , returnType :: Type + , stackoffsets :: (Int, Int) // A and B stack + , storedoffsets :: [(Int, Int)] , typeresolvers :: [TypeResolver] } @@ -85,7 +97,8 @@ where , addresses = 'M'.newMap , symbols = 'M'.newMap , returns = [] - , stackoffset = 0 + , returnType = TVoid + , stackoffsets = (0, 0) , storedoffsets = [] , typeresolvers = [] } @@ -102,8 +115,11 @@ symbols cs = cs.symbols peekReturn :: CompileState -> 'ABC'.Assembler peekReturn cs = hd cs.returns -stackoffset :: CompileState -> Int -stackoffset cs = cs.stackoffset +returnType :: CompileState -> Type +returnType cs = cs.returnType + +stackoffsets :: CompileState -> (Int, Int) +stackoffsets cs = cs.stackoffsets typeresolvers :: CompileState -> [TypeResolver] typeresolvers cs = cs.typeresolvers @@ -115,11 +131,11 @@ fresh n = gets labels >>= \labs -> modify (\cs -> {cs & labels=tl labs}) $> toLabel (n <+ hd labs) -storeStackOffset :: Gen () -storeStackOffset = modify \cs -> {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]} +storeStackOffsets :: Gen () +storeStackOffsets = modify \cs -> {cs & storedoffsets=[cs.stackoffsets:cs.storedoffsets]} -restoreStackOffset :: Gen () -restoreStackOffset = modify \cs=:{storedoffsets=[so:sos]} -> {cs & stackoffset=so, storedoffsets=sos} +restoreStackOffsets :: Gen () +restoreStackOffsets = modify \cs=:{storedoffsets=[so:sos]} -> {cs & stackoffsets=so, storedoffsets=sos} newReturn :: 'ABC'.Assembler -> Gen () newReturn ret = modify \cs -> {cs & returns=[ret:cs.returns]} @@ -133,6 +149,9 @@ removeFromReturn i = modify \cs=:{returns=[r:rs]} -> {cs & returns=[drop i r:rs] popReturn :: Gen () popReturn = modify \cs -> {cs & returns=tl cs.returns} +setReturnType :: Type -> Gen () +setReturnType t = modify \cs -> {cs & returnType=t} + pushTypeResolver :: TypeResolver -> Gen () pushTypeResolver tr = modify \cs -> {cs & typeresolvers=[tr:cs.typeresolvers]} @@ -145,30 +164,51 @@ getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n -> [t:_] -> Just t [] -> Nothing -reserveVar :: Int Name -> Gen Int -reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> comment ("Reserved " <+ i <+ " for " <+ n) $> (i+1) +reserveVar :: Bool (Name, Type) -> Gen Address +reserveVar canBeOnBStack (n,t) = gets stackoffsets >>= put +where + put :: (Int, Int) -> Gen Address + put (aso, bso) = + modify (\cs -> {cs & addresses='M'.put n addr cs.addresses, stackoffsets=so`}) *> + comment ("Reserved " <+ addr <+ " for " <+ n) $> + addr + where + (so`, addr) = case (canBeOnBStack, typeSize t) of + (False, _) -> ((aso+1, bso), AAddr $ aso+1) + (True, {bsize=0}) -> ((aso+1, bso), AAddr $ aso+1) + (True, {btypes}) -> ((aso, bso + length btypes), BAddr $ bso+1) -findVar :: Name -> Gen Int -findVar n = gets stackoffset >>= \so -> +findVar :: Name -> Gen Address +findVar n = gets stackoffsets >>= \(aso, bso) -> gets addresses >>= \addr -> case 'M'.get n addr of - Just i -> comment (n <+ " is at " <+ i <+ ", with so " <+ so <+ " so " <+ (so-i-1)) $> so - i - 1 - Nothing -> error $ UndefinedName n + Just (AAddr i) -> comment (n <+ " is on AStack at " <+ i <+ ", with aso " <+ aso <+ " so " <+ (aso-i)) $> AAddr (aso - i) + Just (BAddr i) -> comment (n <+ " is on BStack at " <+ i <+ ", with bso " <+ bso <+ " so " <+ (bso-i)) $> BAddr (bso - i) + Nothing -> error $ UndefinedName n addFunction :: Function -> Gen () addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols}) where - fs = { fs_arity = length f.f_args - , fs_rettype = f.f_type + fs = { fs_arity = length f.f_args + , fs_argtypes = [a.arg_type \\ a <- f.f_args] + , fs_rettype = f.f_type } cleanup :: Gen () cleanup = gets peekReturn >>= tell -growStack :: Int -> Gen () -growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n}) +growStack :: TypeSize -> Gen () +growStack {asize,bsize} = + modify (\cs -> {cs & stackoffsets=update cs.stackoffsets}) *> + gets stackoffsets >>= \(aso,bso) -> + comment ("Stack offsets: (" <+ aso <+ ", " <+ bso <+ ")") +where + update = appFst ((+) asize) o appSnd ((+) bsize) -shrinkStack :: (Int -> Gen ()) -shrinkStack = growStack o ((-) 0) +shrinkStack :: (TypeSize -> Gen ()) +shrinkStack = growStack o invert +where + invert :: TypeSize -> TypeSize + invert ts = {zero & asize=0-ts.asize, bsize=0-ts.bsize} checkType :: Type Expression -> Gen () checkType t e = getTypeResolver >>= \tr -> case type tr e of @@ -176,11 +216,11 @@ checkType t e = getTypeResolver >>= \tr -> case type tr e of Just (Error err) -> error $ TypeError err e Just (Ok t`) -> if (t == t`) nop (error $ TypeMisMatch t e) -checkTypeName :: Name Expression -> Gen () +checkTypeName :: Name Expression -> Gen Type checkTypeName n e = getTypeResolver >>= \tr -> case type tr n of Nothing -> error $ CouldNotDeduceType $ Name n Just (Error err) -> error $ TypeError err $ Name n - Just (Ok t`) -> checkType t` e + Just (Ok t`) -> checkType t` e $> t` class gen a :: a -> Gen () @@ -209,38 +249,61 @@ where instance gen Function where gen f = - tell [ 'ABC'.Annotation $ 'ABC'.OAnnot args [] + tell [ 'ABC'.Annotation $ toOAnnot` [typeSize a.arg_type \\ a <- f.f_args] , 'ABC'.Label $ toLabel f.f_name ] *> - tell (repeatn retSize 'ABC'.Create) *> growStack retSize *> - foldM reserveVar 0 [a.arg_name \\ a <- f.f_args] *> - growStack (sum [typeSize a.arg_type \\ a <- f.f_args]) *> + tell (repeatn retSize.asize 'ABC'.Create) *> growStack {retSize & bsize=0} *> + mapM_ (reserveVar True) [(a.arg_name, a.arg_type) \\ a <- f.f_args] *> newReturn cleanup` *> pushTypeResolver typeresolver *> + setReturnType f.f_type *> + mainBootstrap *> gen f.f_code *> popTypeResolver *> cleanup *> - modify (\cs -> {cs & stackoffset=0}) *> + modify (\cs -> {cs & stackoffsets=(0, 0)}) *> comment "Reset sos" *> tell ['ABC'.Rtn] *> popReturn where cleanup` = [ 'ABC'.Comment "Cleanup" - , 'ABC'.Pop_a args - , 'ABC'.Annotation $ 'ABC'.DAnnot retSize [] + , 'ABC'.Pop_a (foldr (+~) zero [typeSize a.arg_type \\ a <- f.f_args]).asize + , 'ABC'.Pop_b (foldr (+~) zero [typeSize a.arg_type \\ a <- f.f_args]).bsize + , 'ABC'.Annotation $ toDAnnot retSize ] retSize = typeSize f.f_type - args = length f.f_args typeresolver :: Name -> Maybe (MaybeError TypeError Type) typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n] + mainBootstrap :: Gen () + mainBootstrap = case (f.f_name, (typeSize f.f_type).bsize) of + ("main", 1) -> + fresh "main" >>= \lab -> + tell [ 'ABC'.Annotation $ 'ABC'.DAnnot 0 [] + , 'ABC'.Jsr lab + , 'ABC'.Annotation $ toOAnnot $ typeSize f.f_type + ] *> + BtoAStack type *> + tell [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 [] + , 'ABC'.Rtn + ] *> + comment "Reset sos" *> + modify (\cs -> {cs & stackoffsets=(0, 0)}) *> + tell [ 'ABC'.Label lab ] + with + type = case f.f_type of + TBool -> 'ABC'.BT_Bool + TInt -> 'ABC'.BT_Int + _ -> + nop + instance gen CodeBlock where gen cb = - storeStackOffset *> - gets stackoffset >>= \so -> - foldM reserveVar so [i.init_name \\ i <- cb.cb_init] *> + storeStackOffsets *> + gets stackoffsets >>= \so -> + mapM_ (reserveVar False) [(i.init_name, i.init_type) \\ i <- cb.cb_init] *> mapM_ gen cb.cb_init *> addToReturn cleanup` *> pushTypeResolver typeresolver *> @@ -248,7 +311,7 @@ where popTypeResolver *> tell cleanup` *> removeFromReturn (length cleanup`) *> - restoreStackOffset + restoreStackOffsets where cleanup` = case cb.cb_init of [] -> [] @@ -258,36 +321,48 @@ where typeresolver :: Name -> Maybe (MaybeError TypeError Type) typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n] -instance gen Initialisation -where - gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1 +instance gen Initialisation where gen init = tell ['ABC'.Create] instance gen Statement where gen st=:(Declaration n e) = - checkTypeName n e *> + checkTypeName n e >>= \t -> comment (toString st) *> gen e *> - findVar n >>= \loc -> - tell ['ABC'.Update_a 0 loc, 'ABC'.Pop_a 1] *> // TODO should depend on size of return type - shrinkStack 1 + findVar n >>= + updateLoc t // TODO should depend on size of return type + where + updateLoc :: Type Address -> Gen () + updateLoc t (AAddr i) = case (typeSize t, t) of + ({asize=0}, TInt) -> tell ['ABC'.FillI_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1} + ({asize=0}, TBool) -> tell ['ABC'.FillB_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1} + _ -> tell ['ABC'.Update_a 0 i, 'ABC'.Pop_a 1] *> shrinkStack {zero & asize=1} + updateLoc _ (BAddr i) = tell ['ABC'.Update_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1} gen (Application e) = comment "Application" *> gen e *> getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of - Just (Ok 0) -> nop - Just (Ok sz) -> tell ['ABC'.Pop_a sz] *> shrinkStack sz + Just (Ok sz) -> tell ['ABC'.Pop_a sz.asize, 'ABC'.Pop_b sz.bsize] *> shrinkStack sz Just (Error err) -> error $ TypeError err e Nothing -> error $ CouldNotDeduceType e gen (Return (Just e)) = comment "Return" *> gen e *> - gets stackoffset >>= \so -> - tell [ 'ABC'.Update_a 0 (so-1) - , 'ABC'.Pop_a 1 - ] *> shrinkStack 1 *> + gets returnType >>= \rettype -> + gets stackoffsets >>= \so -> + updateReturnFrame (typeSize rettype) so *> + shrinkStack (typeSize rettype) *> + //gets stackoffset >>= \so -> + //tell [ 'ABC'.Update_a 0 0 //-1 // TODO (so-1) + // , 'ABC'.Pop_a 1 + // ] *> //shrinkStack 1 *> TODO cleanup *> tell ['ABC'.Rtn] + where + updateReturnFrame :: TypeSize (Int, Int) -> Gen () + updateReturnFrame {asize=0,bsize=0} _ = nop + updateReturnFrame {bsize=0} (aso, _) = tell ['ABC'.Update_a 0 (aso-1), 'ABC'.Pop_a 1] // TODO should depend on return type + updateReturnFrame _ (_, bso) = tell ['ABC'.Update_b 0 (bso-1)] // TODO should depend on return type gen (Return Nothing) = comment "Return" *> cleanup *> @@ -305,8 +380,8 @@ where fresh "ifelse" >>= \else -> comment ("(else) if " <+ cond) *> gen cond *> - toBStack 'ABC'.BT_Bool 1 *> tell [ 'ABC'.JmpFalse else ] *> + shrinkStack {zero & bsize=1} *> gen cb *> tell [ 'ABC'.Jmp end , 'ABC'.Label else ] @@ -319,40 +394,44 @@ where fresh "while" >>= \loop -> fresh "whileend" >>= \end -> tell [ 'ABC'.Label loop ] *> gen cond *> - toBStack 'ABC'.BT_Bool 1 *> tell [ 'ABC'.JmpFalse end ] *> + shrinkStack {zero & bsize=1} *> gen do *> tell [ 'ABC'.Jmp loop , 'ABC'.Label end ] instance gen Expression where - gen (Name n) = - findVar n >>= \loc -> - tell ['ABC'.Push_a $ loc] *> growStack 1 - gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0] *> growStack 1 - gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0] *> growStack 1 + gen (Name n) = findVar n >>= getLoc + where + getLoc :: Address -> Gen () + getLoc (AAddr i) = tell ['ABC'.Push_a $ i] *> growStack {zero & asize=1} + getLoc (BAddr i) = tell ['ABC'.Push_b $ i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} //TODO check type + gen (Literal (BLit b)) = + tell ['ABC'.PushB b] *> + growStack {zero & bsize=1,btypes=['ABC'.BT_Bool]} + gen (Literal (ILit i)) = + tell ['ABC'.PushI i] *> + growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of Just i -> liftT $ Error FunctionOnStack _ -> gets symbols >>= \syms -> case 'M'.get n syms of Just fs -> - comment "Retrieve arguments" *> mapM gen args *> + comment "Retrieve arguments" *> + mapM gen args *> comment "Apply function" *> - tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity [] + tell [ 'ABC'.Annotation $ toDAnnot` $ map typeSize fs.fs_argtypes , 'ABC'.Jsr $ toLabel n - , 'ABC'.Annotation $ 'ABC'.OAnnot (typeSize fs.fs_rettype) [] + , 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype ] *> - shrinkStack (fs.fs_arity - typeSize fs.fs_rettype) + growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes) _ -> liftT $ Error $ UndefinedName n gen (BuiltinApp op arg) = gen arg *> gen op - gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op + gen (BuiltinApp2 e1 op e2) = mapM gen [e2,e1] *> gen op instance gen Op1 where - gen op = - toBStack type 1 *> - tell [instr] *> - BtoAStack type + gen op = tell [instr] where instr = case op of Neg -> 'ABC'.NegI @@ -363,10 +442,7 @@ where instance gen Op2 where - gen op = - toBStack 'ABC'.BT_Int 2 *> - tell [instr] *> - BtoAStack rettype + gen op = tell [instr] *> shrinkStack {zero & bsize=1} where instr = case op of Add -> 'ABC'.AddI @@ -384,8 +460,8 @@ where toBStack :: 'ABC'.BasicType Int -> Gen () toBStack t n = tell [push i \\ i <- [0..n-1]] *> - tell (if (n <> 0) ['ABC'.Pop_a n] []) *> - shrinkStack n + tell ['ABC'.Pop_a n] *> + growStack {zero & asize=0-n, bsize=n} where push = case t of 'ABC'.BT_Bool -> 'ABC'.PushB_a @@ -397,7 +473,7 @@ BtoAStack t = , fill 0 0 , 'ABC'.Pop_b 1 ] *> - growStack 1 + growStack {asize=1, bsize=(-1), btypes=[t]} where fill = case t of 'ABC'.BT_Bool -> 'ABC'.FillB_b @@ -408,3 +484,13 @@ comment s = tell ['ABC'.Comment s] toLabel :: a -> 'ABC'.Label | toString a toLabel n = "__sil_" <+ n + +toDAnnot :: TypeSize -> 'ABC'.Annotation +toDAnnot ts = 'ABC'.DAnnot ts.asize ts.btypes + +toDAnnot` :== toDAnnot o foldr (+~) zero + +toOAnnot :: TypeSize -> 'ABC'.Annotation +toOAnnot ts = 'ABC'.OAnnot ts.asize ts.btypes + +toOAnnot` :== toOAnnot o foldr (+~) zero diff --git a/Sil/Types.dcl b/Sil/Types.dcl index 5fd159e..d44a373 100644 --- a/Sil/Types.dcl +++ b/Sil/Types.dcl @@ -1,10 +1,12 @@ definition module Sil.Types -from StdOverloaded import class ==, class toString, class zero +from StdOverloaded import class ==, class +, class toString, class zero from Data.Error import :: MaybeError from Data.Maybe import :: Maybe +from ABC.Assembler import :: BasicType + from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2 :: Type @@ -16,15 +18,26 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2 :: TypeError = IllegalApplication Type Type +:: TypeSize = + { asize :: Int + , bsize :: Int + , btypes :: [BasicType] + } + instance == Type instance toString Type instance toString TypeError +instance zero TypeSize + /** * Size of an expression on the stack */ -typeSize :: Type -> Int +typeSize :: Type -> TypeSize + +(+~) infixl 6 :: TypeSize TypeSize -> TypeSize +(-~) infixl 6 :: TypeSize TypeSize -> TypeSize :: TypeResolver :== Name -> Maybe (MaybeError TypeError Type) diff --git a/Sil/Types.icl b/Sil/Types.icl index 40fc0cb..cd9b9a4 100644 --- a/Sil/Types.icl +++ b/Sil/Types.icl @@ -2,9 +2,12 @@ implementation module Sil.Types from StdFunc import const import StdList +import StdMisc import StdOverloaded import StdString +import GenEq + import Control.Applicative import Control.Monad import Data.Error @@ -12,7 +15,7 @@ from Data.Func import $ import Data.Maybe from Text import <+ -import GenEq +from ABC.Assembler import :: BasicType(..) import Sil.Syntax @@ -30,10 +33,26 @@ instance toString TypeError where toString (IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "." -typeSize :: Type -> Int -typeSize TVoid = 0 -typeSize TBool = 1 -typeSize TInt = 1 +instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]} + +typeSize :: Type -> TypeSize +typeSize TVoid = zero +typeSize TBool = {zero & bsize=1, btypes=[BT_Bool]} +typeSize TInt = {zero & bsize=1, btypes=[BT_Int]} + +(+~) infixl 6 :: TypeSize TypeSize -> TypeSize +(+~) a b = + { asize = a.asize + b.asize + , bsize = a.bsize + b.bsize + , btypes = a.btypes ++ b.btypes + } + +(-~) infixl 6 :: TypeSize TypeSize -> TypeSize +(-~) a b = + { asize = a.asize - b.asize + , bsize = a.bsize - b.bsize + , btypes = abort "btypes after -~\r\n" + } instance zero TypeResolver where zero = const Nothing diff --git a/examples/while.sil b/examples/while.sil index fb2778b..08f27f0 100644 --- a/examples/while.sil +++ b/examples/while.sil @@ -1,11 +1,12 @@ -Void sleep(Int n) { - |~ pushI_a 0 +Int sleep(Int n) { + |~ push_b 0 |~ ccall sleep "I:I" - |~ pop_b 1 + |~ update_b 0 1 } Void print(Int n) { - |~ push_a 0 + |~ create + |~ fillI_b 0 0 |~.d 1 0 |~ jsr _print_graph |~.o 0 0 |