basic LET support (LETREC is broken yet)

interpreter/code.c

@@ -141,6 +141,7 @@ void set_create_thunk_fun(Code* code)
         case CT_SELECT_ADT:
         case CT_SELECT_LIT:    
         case CT_IF:
+        case CT_LET:
             code->create_thunk = NULL;
             break;            
     }
@@ -586,6 +587,27 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 continue;     
             }
         }
+        case CT_LET:
+        {
+            for(int i=0; i<expr->nr_bindings; i++)
+            {
+                LetBindingEntry* binding = ((LetEntry*) expr)->bindings[i];
+                
+                // Normal
+                if(binding->type == 0)
+                {
+                    push_a(binding->body->create_thunk(binding->body, frame_ptr));
+                }
+                else // strict (including unboxed))
+                {
+                    push_a(NULL);
+                    exec(binding->body, frame_ptr, stack_top_a);
+                }
+            }
+            
+            expr = ((LetEntry*) expr)->body;
+            continue;
+        }
         }
     }
 }

interpreter/code.h

@@ -9,7 +9,7 @@ enum CodeType {
     CT_APP_PRIM2,
     CT_APP_THUNK, CT_APP_DYN,
     CT_APP_FUN, CT_APP_FUN1, CT_APP_FUN2,
-    CT_SELECT_ADT, CT_SELECT_LIT, CT_IF, 
+    CT_SELECT_ADT, CT_SELECT_LIT, CT_IF, CT_LET, 
     CT_THUNK
 };
 
@@ -17,6 +17,7 @@ struct Code {
     CodeType type : 5;
     unsigned int nr_args : 5;       // used in AppEntry
     unsigned int nr_cases : 5;      // used in SelectEntry
+    unsigned int nr_bindings : 8;   // used in LetEntry
     unsigned int strict : 1;        // used in VarEntry
     unsigned int arg_pattern : 3;
     struct Thunk* (*create_thunk)(Code*, int);
@@ -68,6 +69,17 @@ struct IfEntry {
     struct Code* fexpr;
 };
 
+struct LetBindingEntry {
+    struct Code* body;
+    int type; // 0 - normal, 1 - strict, 2 - unboxable
+};
+
+struct LetEntry {
+    struct Code base;
+    struct Code* body;
+    struct LetBindingEntry* bindings[];
+};
+
 typedef Thunk* (*create_thunk_fun)(Code*, int);
 
 void set_create_thunk_fun(Code* code);

interpreter/debug.h

 #ifndef DEBUG_H
 #define	DEBUG_H
 
-//#define DEBUG
-//#define BENCHMARK
+#define DEBUG
+#define BENCHMARK
 
 #ifndef DEBUG
 #define NDEBUG

interpreter/parse.c

@@ -574,7 +574,46 @@ IfEntry* parseIf(char **ptr) {
     set_create_thunk_fun((Code*) entry);    
     return entry;
 }
+
+LetEntry* parseLet(char **ptr) {
+    Code* body = parseTerm(ptr);
     
+    int nrBindings;
+    if (!parseInt(ptr, &nrBindings)) return 0;
+        
+    struct LetEntry* entry = (LetEntry*) alloc_code(sizeof (LetEntry) + sizeof (Code*) * nrBindings);
+    entry->base.type = CT_LET;   
+    entry->base.nr_bindings = nrBindings;
+    entry->body = body;
+  
+    for(int i=0; i<nrBindings; i++)
+    {
+        struct LetBindingEntry* binding = (LetBindingEntry*) alloc_code(sizeof (LetBindingEntry));
+
+        char typeChar = *(*ptr)++;
+
+        switch (typeChar) {
+            case 'L': // Local var
+                binding->type = 0;
+                break;
+            case 'S': // Strict local var    
+                binding->type = 1;
+                break;
+            case 'U': // Strict unboxable var    
+                binding->type = 2;
+                break;            
+            default:
+                return 0;
+        }
+
+        binding->body =  parseTerm(ptr);
+        entry->bindings[i] = binding;
+    }
+
+    set_create_thunk_fun((Code*) entry);    
+    return entry;
+}
+
 Code* parseTerm(char **ptr) {
     // 1. Type char
     char type = *(*ptr)++;
@@ -594,6 +633,8 @@ Code* parseTerm(char **ptr) {
             return (Code*) parseSelect(ptr, NULL, 0);
         case 'I': // If
             return (Code*) parseIf(ptr);
+        case 'E': // Let
+            return (Code*) parseLet(ptr);            
         default:
             printf("parseTerm: unhandled term type\n");
             exit(-1);

precompiler/precompiler.icl

@@ -47,11 +47,8 @@ typeInfo (TypedVar (StrictVar _ _) type) | unBoxableType type
 	
 typeInfo _ = Normal
 
-registerArgs vars idx [] = vars
-registerArgs vars idx [v:vs] = registerArgs (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
-
-registerLocals vars idx [] = vars
-registerLocals vars idx [v:vs] = registerLocals (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
+registerVars vars idx [] = vars
+registerVars vars idx [v:vs] = registerVars (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
 
 calcStrictness [] _ = 0
 calcStrictness [TypedVar (StrictVar _ _) _:vs] idx = (1 << idx) + calcStrictness vs (idx + 1)
@@ -62,7 +59,7 @@ calcBoxing [TypedVar (StrictVar _ _) type:vs] idx | unBoxableType type = (1 << i
 calcBoxing [_:vs] idx = calcBoxing vs (idx + 1)
 
 sFunc ctx (FTFunc name body params) a 
-	# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params, inspine = True, currentFun = (unpackVar name)}
+	# ctx = {ctx & vars = registerVars ctx.vars 0 params, localcount = length params, inspine = True, currentFun = (unpackVar name)}
 	= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params) 
 	<++ sNum (calcStrictness params 0) <++ sNum (calcBoxing params 0) 
 	<++ sTerm ctx body
@@ -99,6 +96,9 @@ where
 	sTermS ctx (SApplication var terms) a = a <++ appType ctx var <++ sList (sTerm {ctx & inspine = False}) terms <++ sVar ctx var
 	sTermS ctx (SSelect expr cs) a = a <++ "S" <++ sTerm {ctx & inspine = False} expr <++ sList (sSelectCase ctx) (sortBy selectCaseOrder cs)
 	sTermS ctx (SIf cond texpr fexpr) a = a <++ "I" <++ sTerm {ctx & inspine = False} cond <++ sTerm ctx texpr <++ sTerm ctx fexpr
+	sTermS ctx (SLet body bindings) a 
+		# ctx = {ctx & vars = registerVars ctx.vars ctx.localcount (map unpackBindVar bindings), localcount = ctx.localcount + length bindings}
+		= a <++ "E" <++ sTerm ctx body <++ sList (sLetDef {ctx & inspine = False}) bindings
 
 isLocalVar ctx var = member (unpackVar var) ctx.vars
 
@@ -106,31 +106,35 @@ appType ctx var | isLocalVar ctx var
   = "D"
     
 appType {inspine, currentFun} var = if (inspine && unpackVar var == currentFun) "T" "A" // T: tail recursive 
+    
+sLetDef ctx (SaplLetDef var binding) a = a <++ sVarFlag ctx (Local 0 (typeInfo var)) <++ sTerm ctx binding
   
 // TODO: find constructor for strictness info
 sSelectCase ctx (PCons varName params, expr) a
-	# ctx = {ctx & vars = registerLocals ctx.vars ctx.localcount (map (\p->TypedVar p NoType) params), localcount = ctx.localcount + length params}
+	# ctx = {ctx & vars = registerVars ctx.vars ctx.localcount (map (\p->TypedVar p NoType) params), localcount = ctx.localcount + length params}
 	= a <++ "C" <++ sText varName <++ sTerm ctx expr
 sSelectCase ctx (PLit lit, expr) a
 	= a <++ "L" <++ lit <++ sTerm ctx expr
 sSelectCase ctx (PDefault, expr) a
 	= a <++ "D" <++ sTerm ctx expr
 
+sVarFlag ctx var a
+	= case var of
+		(Local i Strict)    = a <++ "S"
+		(Local i UnBoxable) = a <++ "U"		
+		(Local i Normal)    = a <++ "L"
+
 sVar ctx var a
 	= case get varName ctx.vars of
-		(Just (Local i Strict))    = a <++ "S" <++ sNum i
-		(Just (Local i UnBoxable)) = a <++ "U" <++ sNum i		
-		(Just (Local i Normal))    = a <++ "L" <++ sNum i
-		_				           = a <++ "F" <++ sText varName
+		(Just l=:(Local i _)) = a <++ sVarFlag ctx l <++ sNum i
+		_				      = a <++ "F" <++ sText varName
 where
 	varName = unpackVar var
 
 sVarApp ctx var a
 	= case get varName ctx.vars of
-		(Just (Local i Strict))    = a <++ "VS" <++ sNum i
-		(Just (Local i UnBoxable)) = a <++ "VU" <++ sNum i		
-		(Just (Local i Normal))    = a <++ "VL" <++ sNum i
-		_				           = a <++ "A" <++ sList (sTerm ctx) [] <++ sVar ctx var
+		(Just l=:(Local i _)) = a <++ "V" <++ sVarFlag ctx l <++ sNum i
+		_				      = a <++ "A" <++ sList (sTerm ctx) [] <++ sVar ctx var
 where
 	varName = unpackVar var
 

tests/let1.exp

+[13]
\ No newline at end of file

tests/let1.sapl

+main = lettests.Start
+lettests.Start::I = lettests.test1
+lettests.test1::I = let x = addI 1 2, y = addI 4 6 in addI x y

tests/let2.exp

+[30]
\ No newline at end of file

tests/let2.sapl

+main = lettests.Start
+lettests.Start::I = lettests.test2 2 4
+lettests.test2::I !x_0::I !y_1::I = let r = 3, s = 6 in addI (multI r x_0) (multI s y_1)

tests/let3.exp

+[30]
\ No newline at end of file

tests/let3.sapl

+main = lettests.Start
+lettests.Start::I = lettests.test3 2 4
+lettests.test3::I !x_0::I !y_1::I = let r = multI 3 x_0, s = multI 6 y_1 in addI r s

tests/let4.exp

+[438]
\ No newline at end of file

tests/let4.sapl

+main = lettests.Start
+lettests.Start::I = lettests.test4 2 4
+lettests.test4::I !x_0::I !y_1::I = let r_1_0 = multI 3 x_0, s_1_1 = multI (multI 6 y_1) r_1_0 in addI (addI r_1_0 s_1_1) (multI 2 s_1_1)