Implement ap

5 files changed, 44 insertions, 5 deletions

diff --git a/snug-clean/src/MIPS/MIPS32.dcl b/snug-clean/src/MIPS/MIPS32.dcl
index 6e5ff44..83f15cb 100644
--- a/snug-clean/src/MIPS/MIPS32.dcl
+++ b/snug-clean/src/MIPS/MIPS32.dcl
@@ -10,6 +10,7 @@ from StdOverloaded import class toString
 	| Instr !Instruction
 	| RawByte !Int
 	| RawWord !Int
+	| RawWordLabel !Label
 	| RawAscii !String
 
 instance toString Line
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
index ca5cbee..655219d 100644
--- a/snug-clean/src/MIPS/MIPS32.icl
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -13,6 +13,7 @@ where
 	toString (Instr i) = "\t" +++ toString i
 	toString (RawByte i) = "\t.byte\t" +++ toString i
 	toString (RawWord i) = "\t.word\t" +++ toString i
+	toString (RawWordLabel l) = "\t.word\t" +++ l
 	toString (RawAscii s) = concat3 "\t.ascii\t\"" s "\"" // TODO: escaping
 
 instance toString Instruction
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 8c23134..dcbc5ad 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -89,8 +89,27 @@ compileDefinition ns globals (DataDef _ _ constructors) =
 	flatten <$> mapM (compileConstructor ns globals) constructors
 compileDefinition ns globals (FunDef id args ret expr) =
 	(++)
+		(if (isEmpty args) [] (
+			[ StartSection "data"
+			, Align 2
+			] ++ flatten
+			[[ Label (closure_label i)
+			// TODO: Ideally we would use the following here:
+			//, RawByte i // pointer arity
+			//, RawByte 0 // basic value arity
+			//, RawByte (length args-i-1) // number of arguments that still have to be curried in minus 1
+			//, RawByte 0 // reserved
+			// But since SPIM does not allow .byte in the text section, we use:
+			, RawWord
+				(i bitor // pointer arity
+				((length args-i-1) << 16)) // number of arguments that still have to be curried in minus 1
+			] \\ i <- [0..length args-1]
+			] ++
+			[ RawWordLabel n_label
+			])) <$>
+	(++)
 		[ StartSection "text"
-		, Global label
+		, Global n_label
 		// TODO: Ideally we would use the following here:
 		//, Align 1
 		//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
@@ -101,11 +120,12 @@ compileDefinition ns globals (FunDef id args ret expr) =
 			(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
 			(length args << 8)) // arity
 		// instead... (end modification)
-		, Label label
+		, Label n_label
 		] <$>
 	map Instr <$> compileExpr ns globals locals expr
 where
-	label = functionLabel ns NodeEntry id
+	closure_label i = closureLabel ns id i
+	n_label = functionLabel ns NodeEntry id
 	locals = 'Data.Map'.fromList
 		[ (id, FrontPtrArg offset)
 		\\ (id,_) <- args
@@ -119,7 +139,7 @@ compileConstructor ns _ (ConstructorDef id args) = pure
 	, Label label
 	, RawByte (length args) // pointer arity
 	, RawByte 0 // basic value arity
-	, RawByte 0 // number of arguments still to be curried in
+	//, RawByte -1 // number of arguments still to be curried in (unused for constructors)
 	]
 where
 	label = constructorLabel ns id
@@ -157,7 +177,17 @@ simulator ns globals locals expr=:(ExpApp _ _) =
 				| info.arity == length args ->
 					mapM_ (simulator ns globals locals) (reverse args) >>|
 					buildThunk (functionLabel ns NodeEntry id) info.arity
-				| otherwise -> fail "arity mismatch in application" // TODO implement
+				| info.arity > length args ->
+					mapM_ (simulator ns globals locals) (reverse args) >>|
+					buildCons (closureLabel ns id (length args)) (length args)
+				| info.arity < length args ->
+					let
+						(closure_args,extra_args) = splitAt info.arity args
+						closure = foldl ExpApp f closure_args
+					in
+					mapM_ (simulator ns globals locals) extra_args >>|
+					simulator ns globals locals closure >>|
+					mapM_ (\_ -> buildThunk (functionLabel "" NodeEntry "ap") 2) extra_args
 		Constructor id ->
 			liftT (lookupConstructor ns id globals) >>= \(ConstructorDef _ arg_types)
 				| length arg_types == length args ->
diff --git a/snug-clean/src/Snug/Compile/ABI.dcl b/snug-clean/src/Snug/Compile/ABI.dcl
index 6de2953..c7fe7ad 100644
--- a/snug-clean/src/Snug/Compile/ABI.dcl
+++ b/snug-clean/src/Snug/Compile/ABI.dcl
@@ -21,3 +21,4 @@ TempImm :== T 0
 
 constructorLabel :: !Namespace !ConstructorIdent -> Label
 functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
+closureLabel :: !Namespace !SymbolIdent !Int -> Label
diff --git a/snug-clean/src/Snug/Compile/ABI.icl b/snug-clean/src/Snug/Compile/ABI.icl
index 66a8d5c..225f09c 100644
--- a/snug-clean/src/Snug/Compile/ABI.icl
+++ b/snug-clean/src/Snug/Compile/ABI.icl
@@ -20,11 +20,15 @@ where
 	e = case entry_point of
 		NodeEntry -> 'n'
 
+closureLabel :: !Namespace !SymbolIdent !Int -> Label
+closureLabel ns id nargs = constructorLabel ns (concat3 id "@" (toString nargs))
+
 escapeLabel :: !String -> String
 escapeLabel s = {#c \\ c <- escape [c \\ c <-: s]}
 where
 	escape [] = []
 	escape [c:cs] | isAlphanum c = [c:escape cs]
+	// Symbols allowed in snug but not in symbol names:
 	escape ['_':cs] = ['__':escape cs]
 	escape ['`':cs] = ['_B':escape cs]
 	escape [':':cs] = ['_C':escape cs]
@@ -36,3 +40,5 @@ where
 	escape ['+':cs] = ['_P':escape cs]
 	escape ['\'':cs] = ['_Q':escape cs]
 	escape ['~':cs] = ['_T':escape cs]
+	// Symbols not allowed in snug but used internally:
+	escape ['@':cs] = ['_c':escape cs] // see closureLabel