From ed32c6288c14d540b5c6270858bf2f8202d579e0 Mon Sep 17 00:00:00 2001
From: Camil Staps
Date: Tue, 25 Dec 2018 00:34:39 +0100
Subject: Better use of monads

---
 Makefile         |  2 +-
 Sjit/Compile.dcl | 13 +++++-----
 Sjit/Compile.icl | 72 ++++++++++++++++++++++++++++++++++----------------------
 3 files changed, 52 insertions(+), 35 deletions(-)

diff --git a/Makefile b/Makefile
index c7c7faa..7d9a4ae 100644
--- a/Makefile
+++ b/Makefile
@@ -17,7 +17,7 @@ Clean\ System\ Files/sjit_c.o: sjit_c.c
 	$(CC) $(CFLAGS) -c $< -o '$@'
 
 clean:
-	$(RM) -r $(BIN) Clean\ System\ Files
+	$(RM) -r $(BIN) Clean\ System\ Files Sjit/Clean\ System\ Files
 
 .PHONY: all test clean
 
diff --git a/Sjit/Compile.dcl b/Sjit/Compile.dcl
index 166b5c4..7cb74e3 100644
--- a/Sjit/Compile.dcl
+++ b/Sjit/Compile.dcl
@@ -23,12 +23,13 @@ from Sjit.Syntax import :: Function
 :: Program :== {!Instr}
 
 :: CompileState =
-	{ vars   :: !Map String Int
-	, funs   :: !Map String Int
-	, sp     :: !Int
-	, pc     :: !Int
-	, blocks :: ![!Program!]
-	, jitst  :: !JITState
+	{ vars      :: !Map String Int
+	, funs      :: !Map String Int
+	, sp        :: !Int
+	, pc        :: !Int
+	, blocks    :: ![!Program!]
+	, new_block :: ![!Instr!]
+	, jitst     :: !JITState
 	}
 
 :: JITState =
diff --git a/Sjit/Compile.icl b/Sjit/Compile.icl
index 96db7f2..4f10096 100644
--- a/Sjit/Compile.icl
+++ b/Sjit/Compile.icl
@@ -40,12 +40,13 @@ bootstrap
 # is = {i \\ i <- flatten [is \\ (_,is) <- header]}
 =
 	( is,
-	{ vars   = newMap
-	, funs   = fromList bs_funs
-	, sp     = 0
-	, pc     = len_bs
-	, blocks = [!is!]
-	, jitst  = appendProgram False is (initJITState 1000)
+	{ vars      = newMap
+	, funs      = fromList bs_funs
+	, sp        = 0
+	, pc        = len_bs
+	, blocks    = [!is!]
+	, new_block = [!!]
+	, jitst     = appendProgram False is (initJITState 1000)
 	})
 where
 	bootstrap_funs :: (!Int, ![(String, Int)])
@@ -83,6 +84,29 @@ where
 			ccall init_jit "II:Vpp"
 		}
 
+class toInstrs a :: !a -> [Instr]
+instance toInstrs Instr where toInstrs i = [i]
+instance toInstrs [a] | toInstrs a where toInstrs xs = [i \\ x <- xs, i <- toInstrs x]
+
+gen :: !newis !CompileState -> m CompileState | Monad m & toInstrs newis
+gen newis cs = pure (foldr add cs (toInstrs newis))
+where
+	add i cs = {cs & new_block=[!i:cs.new_block!], sp=sp, pc=cs.pc+1}
+	where
+		sp = cs.sp + case i of
+			PushRef _ -> 1
+			PushI _ -> 1
+			Put _ -> -1
+			Pop n -> 0-n
+			Call _ -> 1
+			JmpRelTrue _ -> 0
+			Ret -> -1
+			Halt -> -2
+			IAddRet -> -1
+			IMulRet -> -1
+			ISubRet -> -1
+			IDivRet -> -1
+
 compile :: !Function !CompileState -> Either String CompileState
 compile f cs
 # cs & funs = put f.fun_name cs.pc cs.funs
@@ -90,36 +114,28 @@ compile f cs
 # cs & vars = foldr (uncurry put) cs.vars [(v,sp) \\ v <- f.fun_args & sp <- [cs.sp+1..]]
 = case expr f.fun_expr cs of
 	Left e -> Left e
-	Right (is,cs)
-		# is = {i \\ i <- reverse [Ret:Put (max 1 (length f.fun_args)+1):is]}
+	Right cs
+		# is = {i \\ i <|- Reverse [!Ret:Put (max 1 (length f.fun_args)+1):cs.new_block!]}
 		-> Right
 			{ cs
-			& vars   = vars
-			, pc     = cs.pc+2
-			, blocks = cs.blocks ++| [!is!]
-			, jitst  = appendProgram (f.fun_name == "main") is cs.jitst
+			& vars      = vars
+			, pc        = cs.pc+2
+			, blocks    = cs.blocks ++| [!is!]
+			, new_block = [!!]
+			, jitst     = appendProgram (f.fun_name == "main") is cs.jitst
 			}
 where
-	expr :: !Expr !CompileState -> Either String (![Instr], !CompileState)
-	expr (Int i) cs = Right ([PushI i], {cs & sp=cs.sp+1, pc=cs.pc+1})
-	expr (Bool b) cs = Right ([PushI (if b 1 0)], {cs & sp=cs.sp+1, pc=cs.pc+1})
+	expr :: !Expr !CompileState -> Either String CompileState
+	expr (Int i) cs = gen (PushI i) cs
+	expr (Bool b) cs = gen (PushI (if b 1 0)) cs
 	expr (Var v) cs = case get v cs.vars of
-		Just i  -> Right ([PushRef (i-cs.sp)], {cs & sp=cs.sp+1, pc=cs.pc+1})
+		Just i  -> gen (PushRef (i-cs.sp)) cs
 		Nothing -> Left ("undefined variable '" +++ v +++ "'")
 	expr (App f args) cs
 	# args = if (args=:[]) [Int 0] args
-	= case mapStM expr args {cs & sp=cs.sp+1} of
-		Left e -> Left e
-		Right (iss,cs) -> case get f cs.funs of
-			Just f  -> Right
-				( [Pop (length args-1):Call f:flatten iss]
-				, {cs & sp=cs.sp+2-length args, pc=cs.pc+2}
-				)
-			Nothing -> Left ("undefined function '" +++ toString f +++ "'")
-
-	mapStM :: !(a st -> m (b, st)) ![a] !st -> m ([b], st) | Monad m
-	mapStM _ [] st = pure ([], st)
-	mapStM f [x:xs] st = f x st >>= \(y,st) -> mapStM f xs st >>= \(ys,st) -> pure ([y:ys],st)
+	= foldM (flip expr) {cs & sp=cs.sp+1} (reverse args) >>= \cs -> case get f cs.funs of
+		Nothing -> Left ("undefined function '" +++ toString f +++ "'")
+		Just f  -> gen [Pop (length args-1),Call f] cs
 
 generic gEncodedSize a :: !a -> Int
 gEncodedSize{|Int|} _ = 1
-- 
cgit v1.2.3