Compiling seems to work

2 files changed, 89 insertions, 23 deletions

diff --git a/ABCMachine b/ABCMachine
-Subproject c83e5d354b9c66491e707f3d6580709fd68a11c
+Subproject bfd43976b9afa83b7625e9c2491b21af3d61198
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 495f277..fc9bc9b 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -27,19 +27,21 @@ where
 	toString UnknownError      = "Unknown error."
 
 compile :: Program -> MaybeError CompileError 'ABC'.Assembler
-compile prog = case evalRWST start () zero of
+compile prog = case evalRWST (gen prog) () zero of
 	Error e  -> Error e
 	Ok (_,p) -> Ok p
-where
-	start = mapM_ gen prog.p_funs
 
-:: Address
-	= LabelAddr String
-	| StackAddr Int
+:: Address :== Int
+
+:: FunctionSymbol =
+	{ fs_arity :: Int
+	}
 
 :: CompileState =
 	{ labels    :: ['ABC'.Label]
 	, addresses :: 'M'.Map Name Address
+	, symbols   :: 'M'.Map Name FunctionSymbol
+	, returns   :: ['ABC'.Assembler]
 	}
 
 instance zero CompileState
@@ -47,6 +49,8 @@ where
 	zero =
 		{ labels    = ["_l" <+ i \\ i <- [0..]]
 		, addresses = 'M'.newMap
+		, symbols   = 'M'.newMap
+		, returns   = []
 		}
 
 labels :: CompileState -> ['ABC'.Label]
@@ -55,6 +59,18 @@ labels cs = cs.labels
 addresses :: CompileState -> 'M'.Map Name Address
 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]}
+
+popReturn :: CompileState -> CompileState
+popReturn cs = {cs & returns=tl cs.returns}
+
+peekReturn :: CompileState -> 'ABC'.Assembler
+peekReturn cs = hd cs.returns
+
 :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
 
 fresh :: Gen 'ABC'.Label
@@ -63,19 +79,66 @@ fresh = gets labels
 	*> pure (hd labs)
 
 reserveVar :: Int Name -> Gen Int
-reserveVar i n = modify (\cs -> {cs & addresses='M'.put n (StackAddr i) cs.addresses}) *> pure (i+1)
+reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
+
+addFunction :: Function -> Gen ()
+addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name {fs_arity=length f.f_args} cs.symbols})
+
+cleanup :: Gen ()
+cleanup = gets peekReturn >>= tell
 
 class gen a :: a -> Gen ()
 
+instance gen Program
+where
+	gen p =
+		tell [ 'ABC'.Annotation $ 'ABC'.RawAnnot ["comp", "920", "01011101001"]
+		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["start", "__sil_boot"]
+		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["endinfo"]
+		     , 'ABC'.Annotation $ 'ABC'.RawAnnot ["module", "m_sil_compiled", "\"sil_compiled\""]
+		     , 'ABC'.Label "__sil_boot"
+		     , 'ABC'.Create
+		     , 'ABC'.Fill "_" 0 "main" 0
+		     , 'ABC'.Jmp "_driver"
+		     ] *>
+		mapM_ addFunction p.p_funs *>
+		mapM_ gen p.p_funs
+
 instance gen Function
 where
-	gen f = tell ['ABC'.Label f.f_name] *> gen f.f_code
+	gen f =
+		tell [ 'ABC'.Annotation $ 'ABC'.OAnnot args []
+		     , 'ABC'.Label f.f_name
+		     ] *>
+		foldM reserveVar (length f.f_code.cb_init) [a.arg_name \\ a <- reverse f.f_args] *>
+		modify (newReturn cleanup) *>
+		gen f.f_code *>
+		modify popReturn
+	where
+		cleanup = case f.f_args of
+			[] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
+			      ]
+			_  -> [ 'ABC'.Comment "Cleanup"
+			      , 'ABC'.Update_a 0 args
+			      , 'ABC'.Pop_a args
+			      , 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
+			      ]
+		args = length f.f_args
 
 instance gen CodeBlock
 where
 	gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
 		mapM_ gen cb.cb_init *>
-		mapM_ gen cb.cb_content
+		mapM_ gen cb.cb_content *>
+		cleanup
+	where
+		cleanup = case cb.cb_init of
+			[] -> tell []
+			_  -> comment "Cleanup" *> tell
+			      [ 'ABC'.Update_a 0 locals
+			      , 'ABC'.Pop_a locals
+			      ]
+		locals = length cb.cb_init
 
 instance gen Initialisation
 where
@@ -84,28 +147,31 @@ where
 instance gen Statement
 where
 	gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
-		Just (StackAddr i) -> comment (toString st) *> gen app *>
-		                      tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1]
-		Just (LabelAddr _) -> liftT $ Error VariableLabel
-		_                  -> liftT $ Error $ UndefinedName n
+		Just i -> comment (toString st) *> gen app *>
+		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1]
+		_      -> liftT $ Error $ UndefinedName n
 	gen (Application app)   = comment "Application" *> gen app
-	gen (Return (Just app)) = comment "Return" *> gen app *> tell ['ABC'.Rtn]
-	gen (Return Nothing)    = comment "Return" *> tell ['ABC'.Rtn]
+	gen (Return (Just app)) = comment "Return" *> gen app *> cleanup *> tell ['ABC'.Rtn]
+	gen (Return Nothing)    = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
 
 instance gen Application
 where
 	gen (Name n) = gets addresses >>= \addrs -> case 'M'.get n addrs of
-		Just (StackAddr i) -> tell ['ABC'.Push_a i]
-		Just (LabelAddr _) -> liftT $ Error VariableLabel
-		_                  -> liftT $ Error $ UndefinedName n
+		Just i -> tell ['ABC'.Push_a i]
+		_      -> liftT $ Error $ UndefinedName n
 	gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0]
 	gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0]
 	gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
-		Just (LabelAddr l) ->
-			comment "Retrieve arguments" *> mapM gen args *>
-			comment "Apply function" *> tell ['ABC'.Jsr l]
-		Just (StackAddr _) -> liftT $ Error FunctionOnStack
-		_                  -> liftT $ Error $ UndefinedName n
+		Just i -> liftT $ Error FunctionOnStack
+		_      -> gets symbols >>= \syms -> case 'M'.get n syms of
+			Just fs ->
+				comment "Retrieve arguments" *> mapM gen args *>
+				comment "Apply function" *>
+				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
+				     , 'ABC'.Jsr n
+				     , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
+				     ]
+			_ -> liftT $ Error $ UndefinedName n
 
 comment :: String -> Gen ()
 comment s = tell ['ABC'.Comment s]