aboutsummaryrefslogtreecommitdiff
path: root/Sil/Compile.icl
diff options
context:
space:
mode:
Diffstat (limited to 'Sil/Compile.icl')
-rw-r--r--Sil/Compile.icl113
1 files changed, 95 insertions, 18 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index afdfe90..e930c44 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,7 +1,7 @@
implementation module Sil.Compile
import StdEnum
-from StdFunc import o
+from StdFunc import const, flip, o
import StdList
import StdString
@@ -11,6 +11,7 @@ import Control.Monad.RWST
import Control.Monad.Trans
import Data.Error
from Data.Func import $
+import Data.Functor
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
@@ -19,14 +20,24 @@ from Text import <+
import qualified ABC.Assembler as ABC
import Sil.Syntax
+import Sil.Types
import Sil.Util.Printer
instance toString CompileError
where
- toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
- toString VariableLabel = "Variable stored at label."
- toString FunctionOnStack = "Function stored on the stack."
- toString UnknownError = "Unknown error."
+ toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
+ toString VariableLabel = "Variable stored at label."
+ toString FunctionOnStack = "Function stored on the stack."
+ toString (TypeError err e) = "Type error in '" <+ e <+ "': " <+ err
+ toString (CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'."
+ toString (TypeMisMatch t e) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
+ toString UnknownError = "Unknown error."
+
+error :: CompileError -> RWST r w s (MaybeError CompileError) a
+error e = RWST \_ _ -> Error e
+
+nop :: RWST r w s m () | Monoid w & Monad m
+nop = RWST \_ s -> pure ((), s, mempty)
compile :: Program -> MaybeError CompileError 'ABC'.Assembler
compile prog = case evalRWST (gen prog) () zero of
@@ -47,6 +58,7 @@ compile prog = case evalRWST (gen prog) () zero of
, returns :: ['ABC'.Assembler]
, stackoffset :: Int
, storedoffsets :: [Int]
+ , typeresolvers :: [TypeResolver]
}
instance zero CompileState
@@ -58,6 +70,7 @@ where
, returns = []
, stackoffset = 0
, storedoffsets = []
+ , typeresolvers = []
}
labels :: CompileState -> ['ABC'.Label]
@@ -94,15 +107,30 @@ 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
fresh n = gets labels
>>= \labs -> modify (\cs -> {cs & labels=tl labs})
- *> pure (n <+ hd labs)
+ $> n <+ hd labs
+
+getTypeResolver :: Gen TypeResolver
+getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n ->
+ case catMaybes $ map (flip ($) n) trs of
+ [t:_] -> Just t
+ [] -> Nothing
reserveVar :: Int Name -> Gen Int
-reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
+reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) $> (i+1)
addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
@@ -120,6 +148,18 @@ growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})
shrinkStack :: (Int -> Gen ())
shrinkStack = growStack o ((-) 0)
+checkType :: Type Expression -> Gen ()
+checkType t e = getTypeResolver >>= \tr -> case type tr e of
+ Nothing -> error $ CouldNotDeduceType e
+ Just (Error err) -> error $ TypeError err e
+ Just (Ok t`) -> if (t == t`) nop (error $ TypeMisMatch t e)
+
+checkTypeName :: Name Expression -> Gen ()
+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
+
class gen a :: a -> Gen ()
instance gen Program
@@ -134,8 +174,15 @@ where
, 'ABC'.Fill "_" 0 "main" 0
, 'ABC'.Jmp "_driver"
] *>
+ modify (pushTypeResolver typeresolver) *>
mapM_ addFunction p.p_funs *>
- mapM_ gen p.p_funs
+ mapM_ gen p.p_funs *>
+ modify popTypeResolver
+ where
+ typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+ typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
+ [] -> Nothing
+ [f:_] -> type (const Nothing) f
instance gen Function
where
@@ -145,7 +192,9 @@ where
] *>
foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
modify (newReturn cleanup`) *>
+ modify (pushTypeResolver typeresolver) *>
gen f.f_code *>
+ modify popTypeResolver *>
cleanup *>
modify (\cs -> {cs & stackoffset=0}) *>
tell ['ABC'.Rtn] *>
@@ -163,6 +212,9 @@ where
args = length f.f_args
locals = length f.f_code.cb_init
+ typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+ typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n]
+
instance gen CodeBlock
where
gen cb =
@@ -170,7 +222,9 @@ where
foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
mapM_ gen cb.cb_init *>
modify (addToReturn cleanup`) *>
+ modify (pushTypeResolver typeresolver) *>
mapM_ gen cb.cb_content *>
+ modify popTypeResolver *>
tell cleanup` *>
modify (removeFromReturn $ length cleanup`) *>
modify restoreStackOffset
@@ -180,27 +234,49 @@ where
_ -> [ 'ABC'.Pop_a locals ]
locals = length cb.cb_init
+ 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 Statement
where
- gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
- Just i -> comment (toString st) *> gen app *>
- tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> shrinkStack 1
+ gen st=:(Declaration n e) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+ Just i -> checkTypeName n e *>
+ comment (toString st) *>
+ gen e *>
+ tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> // TODO should depend on size of return type
+ shrinkStack 1
_ -> liftT $ Error $ UndefinedName n
- gen (Application e) = comment "Application" *> gen e *> tell ['ABC'.Pop_a 1] *> shrinkStack 1
- gen (Return (Just e)) = comment "Return" *> gen e *> cleanup *> tell ['ABC'.Rtn]
- gen (Return Nothing) = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
- gen (MachineStm s) = tell ['ABC'.Raw s]
- gen (If blocks else) =
+ 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 (Error err) -> error $ TypeError err e
+ Nothing -> error $ CouldNotDeduceType e
+ gen (Return (Just e)) =
+ comment "Return" *>
+ gen e *>
+ cleanup *>
+ tell ['ABC'.Rtn]
+ gen (Return Nothing) =
+ comment "Return" *>
+ cleanup *>
+ tell ['ABC'.Rtn]
+ gen (MachineStm s) =
+ tell ['ABC'.Raw s]
+ gen (If blocks else) =
fresh "ifend" >>= \end ->
mapM_ (genifblock end) blocks *>
genelse end else
where
genifblock :: 'ABC'.Label (Expression, CodeBlock) -> Gen ()
genifblock end (cond, cb) =
+ checkType TBool cond *>
fresh "ifelse" >>= \else ->
gen cond *>
toBStack 'ABC'.BT_Bool 1 *>
@@ -213,6 +289,7 @@ where
genelse end Nothing = tell ['ABC'.Label end]
genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
gen (While cond do) =
+ checkType TBool cond *>
fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
tell [ 'ABC'.Label loop ] *>
gen cond *>
@@ -240,9 +317,9 @@ where
comment "Apply function" *>
tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
, 'ABC'.Jsr n
- , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
+ , 'ABC'.Annotation $ 'ABC'.OAnnot (typeSize fs.fs_rettype) []
] *>
- shrinkStack (fs.fs_arity - 1)
+ shrinkStack (fs.fs_arity - typeSize fs.fs_rettype)
_ -> liftT $ Error $ UndefinedName n
gen (BuiltinApp op arg) = gen arg *> gen op
gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:19:46 +0000