Use StateT for CompileM; incorporate Globals and add label generator

1 files changed, 67 insertions, 55 deletions

diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 1bb7ff7..0dd2959 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -19,7 +19,12 @@ import Snug.Compile.ABI
 import Snug.Compile.Simulate
 import Snug.Syntax
 
-:: CompileM a :== MaybeError String a
+:: CompileM a :== StateT CompileState (MaybeError String) a
+
+:: CompileState =
+	{ fresh_ident :: !Int
+	, globals     :: !Globals
+	}
 
 :: Locals :== Map SymbolIdent LocalLocation
 
@@ -38,12 +43,12 @@ where
 
 compile :: !Namespace ![Definition] -> MaybeError String [Line]
 compile ns defs =
-	flatten <$> mapM (compileDefinition ns globals) defs
+	flatten <$> evalStateT (mapM (compileDefinition ns) defs) init
 where
-	globals = combineGlobals
-		[ builtin
-		, gatherGlobals ns defs
-		]
+	init =
+		{ fresh_ident = 0
+		, globals = combineGlobals [builtin, gatherGlobals ns defs]
+		}
 
 	builtin =
 		{ constructors = 'Data.Map'.fromList
@@ -52,42 +57,49 @@ where
 		, functions = 'Data.Map'.newMap
 		}
 
-combineGlobals :: ![Globals] -> Globals
-combineGlobals sets =
-	{ constructors = 'Data.Map'.unions [g.constructors \\ g <- sets]
-	, functions = 'Data.Map'.unions [g.functions \\ g <- sets]
-	}
-
-gatherGlobals :: !Namespace ![Definition] -> Globals
-gatherGlobals ns defs =
-	{ constructors = 'Data.Map'.fromList
-		[ ({ns=ns, id=id}, cons)
-		\\ DataDef _ _ conses <- defs
-		, cons=:(ConstructorDef id _) <- conses
-		]
-	, functions = 'Data.Map'.fromList
-		[ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))})
-		\\ FunDef id args ret _ <- defs
-		]
-	}
-
-lookupConstructor :: !Namespace !ConstructorIdent !Globals -> MaybeError String ConstructorDef
-lookupConstructor ns id globs = mb2error
-	(concat4 "Unknown constructor " ns "." id)
-	('Data.Map'.get {ns=ns, id=id} globs.constructors)
+	combineGlobals :: ![Globals] -> Globals
+	combineGlobals sets =
+		{ constructors = 'Data.Map'.unions [g.constructors \\ g <- sets]
+		, functions = 'Data.Map'.unions [g.functions \\ g <- sets]
+		}
 
-lookupFunction :: !Namespace !SymbolIdent !Globals -> MaybeError String FunctionInfo
-lookupFunction ns id globs = mb2error
-	(concat4 "Unknown symbol " ns "." id)
-	('Data.Map'.get {ns=ns, id=id} globs.functions)
+	gatherGlobals :: !Namespace ![Definition] -> Globals
+	gatherGlobals ns defs =
+		{ constructors = 'Data.Map'.fromList
+			[ ({ns=ns, id=id}, cons)
+			\\ DataDef _ _ conses <- defs
+			, cons=:(ConstructorDef id _) <- conses
+			]
+		, functions = 'Data.Map'.fromList
+			[ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))})
+			\\ FunDef id args ret _ <- defs
+			]
+		}
 
-compileDefinition :: !Namespace !Globals !Definition -> CompileM [Line]
-compileDefinition _ _ (TypeDef _ _) = pure
+freshLabel :: CompileM Label
+freshLabel = state \st -> ("_l" +++ toString (st.fresh_ident), {st & fresh_ident=st.fresh_ident+1})
+
+lookupConstructor :: !Namespace !ConstructorIdent -> CompileM ConstructorDef
+lookupConstructor ns id =
+	gets (\s -> s.globals) >>= \globals ->
+	liftT $ mb2error
+		(concat4 "Unknown constructor " ns "." id)
+		('Data.Map'.get {ns=ns, id=id} globals.constructors)
+
+lookupFunction :: !Namespace !SymbolIdent -> CompileM FunctionInfo
+lookupFunction ns id =
+	gets (\s -> s.globals) >>= \globals ->
+	liftT $ mb2error
+		(concat4 "Unknown symbol " ns "." id)
+		('Data.Map'.get {ns=ns, id=id} globals.functions)
+
+compileDefinition :: !Namespace !Definition -> CompileM [Line]
+compileDefinition _ (TypeDef _ _) = pure
 	[]
-compileDefinition ns globals (DataDef _ _ constructors) =
+compileDefinition ns (DataDef _ _ constructors) =
 	(++) [StartSection "data"] <$>
-	flatten <$> mapM (compileConstructor ns globals) constructors
-compileDefinition ns globals (FunDef id args ret expr) =
+	flatten <$> mapM (compileConstructor ns) constructors
+compileDefinition ns (FunDef id args ret expr) =
 	(++)
 		(if (isEmpty args) [] (
 			[ StartSection "data"
@@ -132,8 +144,8 @@ where
 		& offset <- [0..]
 		]
 
-compileConstructor :: !Namespace !Globals !ConstructorDef -> CompileM [Line]
-compileConstructor ns _ (ConstructorDef id args) = pure
+compileConstructor :: !Namespace !ConstructorDef -> CompileM [Line]
+compileConstructor ns (ConstructorDef id args) = pure
 	[ Global label
 	, Align 1
 	, Label label
@@ -144,54 +156,54 @@ compileConstructor ns _ (ConstructorDef id args) = pure
 where
 	label = constructorLabel ns id
 
-compileExpr :: !Namespace !Globals !Locals !Expression -> CompileM [Instruction]
-compileExpr ns globals locals expr =
+compileExpr :: !Namespace !Locals !Expression -> CompileM [Instruction]
+compileExpr ns locals expr =
 	case simulate [SVRegOffset FrontEvalPtr 0] expr` of
 		Error e -> fail ("Compiling an expression failed: " +++ e)
 		Ok instrs -> pure instrs
 where
-	expr` = simulator ns globals locals expr >>| indirectAndEval
+	expr` = simulator ns locals expr >>| indirectAndEval
 
-simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
-simulator _ _ _ (BasicValue bv) =
+simulator :: !Namespace !Locals !Expression -> Simulator ()
+simulator _ _ (BasicValue bv) =
 	pushBasicValue bv >>|
 	buildCons (constructorLabel "" (label bv)) 1
 where
 	label (BVInt _) = "INT"
 	label (BVChar _) = "CHAR"
-simulator ns globals locals (Symbol id) =
+simulator ns locals (Symbol id) =
 	case 'Data.Map'.get id locals of
 		?Just (FrontPtrArg i) ->
 			stackSize >>= \n ->
 			pushArg (n-1) i
 		?None ->
-			liftT (lookupFunction ns id globals) >>= \info -> case info.arity of
+			liftT (lookupFunction ns id) >>= \info -> case info.arity of
 				0 ->
 					buildThunk (functionLabel ns NodeEntry id) 0
 				_ ->
 					fail "symbol with arity > 0" // TODO implement
-simulator ns globals locals expr=:(ExpApp _ _) =
+simulator ns locals expr=:(ExpApp _ _) =
 	case f of
 		Symbol id -> // TODO include locals
-			liftT (lookupFunction ns id globals) >>= \info
+			liftT (lookupFunction ns id) >>= \info
 				| info.arity == length args ->
-					mapM_ (simulator ns globals locals) (reverse args) >>|
+					mapM_ (simulator ns locals) (reverse args) >>|
 					buildThunk (functionLabel ns NodeEntry id) info.arity
 				| info.arity > length args ->
-					mapM_ (simulator ns globals locals) (reverse args) >>|
+					mapM_ (simulator ns 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_ (simulator ns locals) extra_args >>|
+					simulator ns locals closure >>|
 					mapM_ (\_ -> buildThunk (functionLabel "" NodeEntry "ap") 2) extra_args
 		Constructor id ->
-			liftT (lookupConstructor ns id globals) >>= \(ConstructorDef _ arg_types)
+			liftT (lookupConstructor ns id) >>= \(ConstructorDef _ arg_types)
 				| length arg_types == length args ->
-					mapM_ (simulator ns globals locals) (reverse args) >>|
+					mapM_ (simulator ns locals) (reverse args) >>|
 					buildCons (constructorLabel ns id) (length args)
 				| otherwise -> fail ("arity mismatch in application of " +++ id) // TODO implement
 		_ -> // TODO