Add comparisons; tak example

9 files changed, 139 insertions, 118 deletions

diff --git a/Sjit/Compile.dcl b/Sjit/Compile.dcl
index d373e42..e630178 100644
--- a/Sjit/Compile.dcl
+++ b/Sjit/Compile.dcl
@@ -13,17 +13,24 @@ from Sjit.Syntax import :: Function
 
 	| Call !Int
 	| Jmp !Int
-	| JmpTrue !Int
+	| JmpCond !Cond !Int
 	| Ret
 	| Halt
 
-	| IAdd
-	| IMul
-	| ISub
-	| IDiv
+	| Op !Op
 
 	| PlaceHolder !Int !Int // only used during compilation
 
+:: Op
+	= OAdd | OMul
+	| OSub | ODiv
+
+:: Cond
+	= CEq | CNe
+	| CLt | CLe
+	| CGt | CGe
+	| CTrue
+
 :: Program :== {!Instr}
 
 :: CompileState =
diff --git a/Sjit/Compile.icl b/Sjit/Compile.icl
index 527676f..b5ea1bf 100644
--- a/Sjit/Compile.icl
+++ b/Sjit/Compile.icl
@@ -98,13 +98,10 @@ where
 			Pop n           -> 0-n
 			Call _          ->   0
 			Jmp _           ->   0
-			JmpTrue _       ->   0
+			JmpCond c _     -> if (c=:CTrue) -1 -2
 			Ret             ->  -1
 			Halt            ->  -2
-			IAdd            ->  -1
-			IMul            ->  -1
-			ISub            ->  -1
-			IDiv            ->  -1
+			Op _            ->  -1
 			PlaceHolder _ n ->   n
 
 reserve :: !Int !CompileState -> m (!Int, !CompileState) | Monad m
@@ -152,20 +149,38 @@ where
 	# args = if (args=:[]) [Int 0] args
 	= foldM (flip expr) cs (reverse args) >>= \cs -> case get f cs.funs of
 		Nothing -> case f of
-			"+" -> gen [IAdd] cs
-			"-" -> gen [ISub] cs
-			"*" -> gen [IMul] cs
-			"/" -> gen [IDiv] cs
-			_ -> Left ("undefined function '" +++ toString f +++ "'")
+			"+" -> gen [Op OAdd] cs
+			"-" -> gen [Op OSub] cs
+			"*" -> gen [Op OMul] cs
+			"/" -> gen [Op ODiv] cs
+			_   -> Left ("undefined function '" +++ toString f +++ "'")
 		Just f -> case length args of
 			1 -> gen [Call f] cs
 			n -> gen [Pop (n-1),Call f] cs
+	expr (If (App cond [a,b]) t e) cs | isJust condop =
+		expr a cs >>=
+		expr b >>=
+		reserve -2 >>= \(jmpcond,cs=:{sp=orgsp}) ->
+		expr e cs >>=
+		reserve 0 >>= \(jmpend,cs) ->
+		fillPlaceHolder jmpcond (JmpCond (fromJust condop) cs.pc) {cs & sp=orgsp} >>=
+		expr t >>= \cs ->
+		fillPlaceHolder jmpend (Jmp cs.pc) cs
+	where
+		condop = case cond of
+			"==" -> Just CEq
+			"<>" -> Just CNe
+			"<"  -> Just CLt
+			"<=" -> Just CLe
+			">"  -> Just CGt
+			">=" -> Just CGe
+			_    -> Nothing
 	expr (If b t e) cs =
 		expr b cs >>=
-		reserve -1 >>= \(jmptrue,cs=:{sp=orgsp}) ->
+		reserve -1 >>= \(jmpcond,cs=:{sp=orgsp}) ->
 		expr e cs >>=
 		reserve 0 >>= \(jmpend,cs) ->
-		fillPlaceHolder jmptrue (JmpTrue cs.pc) {cs & sp=orgsp} >>=
+		fillPlaceHolder jmpcond (JmpCond CTrue cs.pc) {cs & sp=orgsp} >>=
 		expr t >>= \cs ->
 		fillPlaceHolder jmpend (Jmp cs.pc) cs
 
@@ -198,8 +213,8 @@ gEncode{|EITHER|} _ fr (RIGHT r) i arr = fr r i arr
 gEncode{|CONS of {gcd_index}|} fx (CONS x) i arr = fx x (i+1) {arr & [i]=gcd_index}
 gEncode{|OBJECT|} fx (OBJECT x) i arr = fx x i arr
 
-derive gEncodedSize Instr
-derive gEncode Instr
+derive gEncodedSize Cond, Op, Instr
+derive gEncode Cond, Op, Instr
 
 encode :: !a -> *{#Int} | gEncodedSize{|*|}, gEncode{|*|} a
 encode x
diff --git a/Sjit/Run.dcl b/Sjit/Run.dcl
index aff22fc..371f4f5 100644
--- a/Sjit/Run.dcl
+++ b/Sjit/Run.dcl
@@ -2,5 +2,4 @@ definition module Sjit.Run
 
 from Sjit.Compile import :: CompileState
 
-interpret :: !CompileState -> Int
 exec :: !CompileState -> Int
diff --git a/Sjit/Run.icl b/Sjit/Run.icl
index ad03e02..8bd3972 100644
--- a/Sjit/Run.icl
+++ b/Sjit/Run.icl
@@ -7,57 +7,6 @@ from Data.Map import :: Map(..), get
 
 import Sjit.Compile
 
-interpret :: !CompileState -> Int
-interpret cs = exec 0 []
-where
-	prog = get_program cs
-	sz = size prog
-
-	exec :: !Int ![Int] -> Int
-	exec i stack
-	| i < 0 || i >= sz = abort "out of bounds\n"
-	| otherwise = case prog.[i] of
-		PushI n   -> exec (i+1) [n:stack]
-		PushRef r -> exec (i+1) [stack!!r:stack]
-		Put n     -> case stack of
-			[val:stack] -> exec (i+1) (take (n-1) stack ++ [val:drop n stack])
-		Pop n     -> exec (i+1) (drop n stack)
-		Call f    -> exec f [i+1:stack]
-		Jmp f     -> exec f stack
-		JmpTrue f -> case stack of
-			[0:stack] -> exec (i+1) stack
-			[_:stack] -> exec f stack
-		Ret -> case stack of
-			[ret:stack] -> exec ret stack
-		Halt -> case stack of
-			[r] -> r
-			_   -> abort (toString (length stack) +++ " values left on stack\n")
-
-		IAdd -> case stack of
-			[a:b:stack] -> exec (i+1) [a+b:stack]
-		IMul -> case stack of
-			[a:b:stack] -> exec (i+1) [a*b:stack]
-		ISub -> case stack of
-			[a:b:stack] -> exec (i+1) [a-b:stack]
-		IDiv -> case stack of
-			[a:b:stack] -> exec (i+1) [a/b:stack]
-
-	get_program :: !CompileState -> Program
-	get_program cs
-	# prog = loop 0 cs.blocks (createArray (sum [size b \\ b <|- cs.blocks]) Halt)
-	# prog & [1] = Call (fromJust (get "main" cs.funs))
-	= prog
-	where
-		loop :: !Int ![!Program!] !*Program -> .Program
-		loop i [!b:bs!] prog
-		# (i,prog) = copy i 0 (size b-1) b prog
-		= loop i bs prog
-		where
-			copy :: !Int !Int !Int !Program !*Program -> *(!Int, !*Program)
-			copy i _ -1 _ prog = (i, prog)
-			copy i bi n b prog = copy (i+1) (bi+1) (n-1) b {prog & [i]=b.[bi]}
-		loop _ [!!] prog = prog
-
 exec :: !CompileState -> Int
 exec {jitst} = exec jitst.code_start
 where
diff --git a/Sjit/Syntax.icl b/Sjit/Syntax.icl
index 90aeb39..e382696 100644
--- a/Sjit/Syntax.icl
+++ b/Sjit/Syntax.icl
@@ -5,9 +5,12 @@ import StdEnv
 import Control.Applicative
 import Control.Monad
 import Data.Either
+from Data.Foldable import class Foldable(foldr1)
 from Data.Func import $
 import Data.Functor
 import Data.GenEq
+from Data.List import instance Foldable []
+import Data.Maybe
 import Text.Parsers.Simple.Core
 
 :: Token
@@ -60,13 +63,15 @@ where
 
 		n | isFunnyIdent n
 			# (i,n) = readIdent isFunnyIdent [] i e s
-			-> lex [TIdent n:tks] i e s
+			# tk = case n of
+				"=" -> TEq
+				n   -> TIdent n
+			-> lex [tk:tks] i e s
 
 		n | isDigit n
 			# (i,n) = readInt [] i e s
 			-> lex [TInt n:tks] i e s
 
-		'=' -> lex [TEq:        tks] (i+1) e s
 		',' -> lex [TComma:     tks] (i+1) e s
 		'(' -> lex [TParenOpen: tks] (i+1) e s
 		')' -> lex [TParenClose:tks] (i+1) e s
@@ -77,7 +82,7 @@ where
 	isIdent c = isAlpha c || c == '_'
 
 	isFunnyIdent :: !Char -> Bool
-	isFunnyIdent c = isMember c ['+-*/']
+	isFunnyIdent c = isMember c ['+-*/<>=']
 
 	readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String)
 	readIdent ok cs i e s
@@ -102,12 +107,19 @@ where
 
 expr :: Parser Token Expr
 expr
-	= leftAssoc (tok "+" <|> tok "-")
-	$ leftAssoc (tok "*" <|> tok "/")
+	= rightAssoc (toks ["==","<>","<","<=",">",">="])
+	$ leftAssoc (toks ["+","-"])
+	$ leftAssoc (toks ["*","/"])
 	$ noInfix
 where
 	tok :: !String -> Parser Token String
 	tok s = pToken (TIdent s) $> s
+	toks = foldr1 (<|>) o map tok
+
+	rightAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
+	rightAssoc opp exprp = exprp >>= \e1 ->
+		optional (opp >>= \op -> rightAssoc opp exprp >>= \e -> pure (op,e)) >>=
+		pure o maybe e1 (\(op,e2) -> App op [e1,e2])
 
 	leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
 	leftAssoc opp exprp = exprp >>= \e1 ->
diff --git a/sjit_c.c b/sjit_c.c
index caae10f..21a4b70 100644
--- a/sjit_c.c
+++ b/sjit_c.c
@@ -12,18 +12,27 @@ enum instr {
 
 	Call,
 	Jmp,
-	JmpTrue,
+	JmpCond,
 	Ret,
 	Halt,
 
-	IAdd,
-	IMul,
-	ISub,
-	IDiv
+	Op
 };
 
-static inline uint32_t instr_size(enum instr instr) {
-	switch (instr) {
+enum op {
+	OAdd, OMul,
+	OSub, ODiv
+};
+
+enum cond {
+	CEq, CNe,
+	CLt, CLe,
+	CGt, CGe,
+	CTrue
+};
+
+static inline uint32_t instr_size(uint64_t *pgm) {
+	switch (*pgm) {
 		case PushRef: return 5+1;
 		case PushI:   return 7+1;
 		case Put:     return 1+5;
@@ -31,17 +40,25 @@ static inline uint32_t instr_size(enum instr instr) {
 
 		case Call:    return 5;
 		case Jmp:     return 5;
-		case JmpTrue: return 1+3+6;
+		case JmpCond: switch (pgm[1]) {
+			case CTrue: return 1+3+6;
+			default:    return 1+1+3+6;
+		}
 		case Ret:     return 1;
 		case Halt:    return 1+1;
 
-		case IAdd:
-		case ISub:    return 1+4+3+4;
-		case IMul:    return 1+4+4+4;
-		case IDiv:    return 1+4+3+3+4;
+		case Op: switch (pgm[1]) {
+			case OAdd:
+			case OSub: return 1+4+3+4;
+			case OMul: return 1+4+4+4;
+			case ODiv: return 1+4+3+3+4;
+			default:
+				fprintf(stderr,"unknown operator %d\n",(int)pgm[1]);
+				exit(1);
+		}
 
 		default:
-			fprintf(stderr,"unknown instruction %d\n",instr);
+			fprintf(stderr,"unknown instruction %d\n",(int)*pgm);
 			exit(1);
 	}
 }
@@ -127,21 +144,41 @@ static inline void gen_instr(char *full_code, char **code_p, uint64_t **pgm_p, u
 			pgm+=2;
 			code+=5;
 			break;
-		case JmpTrue:
-			arg=pgm[1];
+		case JmpCond:
+		{
+			enum cond cond=pgm[1];
+			arg=pgm[2];
 #ifdef DEBUG_JIT_INSTRUCTIONS
-			fprintf(stderr,"JmpTrue %lu -> %d\n",arg,mapping[arg]-(uint32_t)(&code[10]-full_code));
+			fprintf(stderr,"JmpCond %d %lu -> %d\n",(int)cond,arg,mapping[arg]-(uint32_t)(&code[10]-full_code));
 #endif
 			code[0]='\x59'; /* pop rcx */
-			code[1]='\x48'; /* test rcx,rcx */
-			code[2]='\x85';
-			code[3]='\xc9';
-			code[4]='\x0f'; /* jne ARG */
-			code[5]='\x85';
-			*(uint32_t*)&code[6]=mapping[arg]-(&code[10]-full_code);
-			pgm+=2;
-			code+=10;
+			if (cond==CTrue) {
+				code[1]='\x48'; /* test rcx,rcx */
+				code[2]='\x85';
+				code[3]='\xc9';
+				code+=4;
+			} else {
+				code[1]='\x58'; /* pop rax */
+				code[2]='\x48'; /* cmp rax,rcx */
+				code[3]='\x3b';
+				code[4]='\xc1';
+				code+=5;
+			}
+			code[0]='\x0f'; /* jcc */
+			switch (cond) {
+				case CEq: code[1]='\x84'; break;
+				case CTrue:
+				case CNe: code[1]='\x85'; break;
+				case CLt: code[1]='\x8c'; break;
+				case CLe: code[1]='\x8e'; break;
+				case CGt: code[1]='\x8f'; break;
+				case CGe: code[1]='\x8d'; break;
+			}
+			*(uint32_t*)&code[2]=mapping[arg]-(&code[6]-full_code);
+			pgm+=3;
+			code+=6;
 			break;
+		}
 		case Ret:
 #ifdef DEBUG_JIT_INSTRUCTIONS
 			fprintf(stderr,"Ret\n");
@@ -160,32 +197,30 @@ static inline void gen_instr(char *full_code, char **code_p, uint64_t **pgm_p, u
 			code+=2;
 			break;
 
-		case IAdd:
-		case IMul:
-		case ISub:
-		case IDiv:
+		case Op:
+			arg=pgm[1];
 #ifdef DEBUG_JIT_INSTRUCTIONS
-			fprintf(stderr,"I<Op>\n");
+			fprintf(stderr,"Op %d\n",(int)arg);
 #endif
 			/* pop rax */
 			code[0]='\x58';
 			/* mov rcx,[rsp] */
 			code[1]='\x48'; code[2]='\x8b'; code[3]='\x0c'; code[4]='\x24';
-			switch (*pgm) {
-				case IAdd:
-				case ISub:
+			switch (arg) {
+				case OAdd:
+				case OSub:
 					/* {add,sub} rax,rcx */
 					code[5]='\x48';
-					code[6]=*pgm==IAdd ? '\x01' : '\x29';
+					code[6]=arg==OAdd ? '\x01' : '\x29';
 					code[7]='\xc8';
 					code+=8;
 					break;
-				case IMul:
+				case OMul:
 					/* imul rax,rcx */
 					code[5]='\x48'; code[6]='\x0f'; code[7]='\xaf'; code[8]='\xc1';
 					code+=9;
 					break;
-				case IDiv:
+				case ODiv:
 					/* xor rdx,rdx */
 					code[5]='\x48'; code[6]='\x31'; code[7]='\xd2';
 					/* idiv rcx */
@@ -195,7 +230,7 @@ static inline void gen_instr(char *full_code, char **code_p, uint64_t **pgm_p, u
 			}
 			/* mov [rsp],rax */
 			code[0]='\x48'; code[1]='\x89'; code[2]='\x04'; code[3]='\x24';
-			pgm++;
+			pgm+=2;
 			code+=4;
 			break;
 
@@ -222,19 +257,20 @@ char *jit_append(char *code_block, uint32_t code_len, char *code_ptr,
 
 	uint64_t *pgm_p=pgm;
 	for (i=n_instr; i<n_instr+len; i++) {
-		enum instr instr=(enum instr)*pgm_p;
-
 		mapping[i]=code_i;
-		code_i+=instr_size(instr);
+		code_i+=instr_size(pgm_p);
 
-		switch (instr) {
+		switch (*pgm_p) {
+			case JmpCond:
+				pgm_p+=3;
+				break;
 			case PushRef:
 			case PushI:
 			case Put:
 			case Pop:
 			case Call:
 			case Jmp:
-			case JmpTrue:
+			case Op:
 				pgm_p+=2;
 				break;
 			default:
diff --git a/test/fib.test b/test/fib.test
index cb5a5fa..e005688 100644
--- a/test/fib.test
+++ b/test/fib.test
@@ -1,2 +1,2 @@
-fib n = if n (if (n-1) (fib(n-1) + fib(n-2)) 1) 1
+fib n = if (n < 2) 1 (fib(n-1) + fib(n-2))
 fib(30)
diff --git a/test/tak.result b/test/tak.result
new file mode 100644
index 0000000..ec63514
--- /dev/null
+++ b/test/tak.result
@@ -0,0 +1 @@
+9
diff --git a/test/tak.test b/test/tak.test
new file mode 100644
index 0000000..62a86b0
--- /dev/null
+++ b/test/tak.test
@@ -0,0 +1,2 @@
+tak x y z = if (x <= y) z tak(tak(x-1,y,z), tak(y-1,z,x), tak(z-1,x,y))
+tak(24,16,8)