+ set in VarEntry whether its strict and use this to avoid unnecessary "eval"s

+ "eval" where cannot be avoided

interpreter/code.c

@@ -92,8 +92,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 if(slice->type == FT_PRIM)
                 {
                     for (int i = 0; i < basethunk->desc->arity; i++) {
-                        // TODO: eval
-                        push_a(basethunk->_args[i]);
+                        push_a(eval(basethunk->_args[i]));
                     }
                     
                     for (int i = 0; i < expr->nr_args; i++) {
@@ -110,13 +109,28 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                     int new_frame_ptr = stack_top_a;                    
                     
                     for (int i = 0; i < basethunk->desc->arity; i++) {
-                        // TODO: eval
-                        push_a(basethunk->_args[i]);
+                        
+                        if(is_strict_fun_arg((FunEntry*) slice, i))
+                        {
+                            push_a(eval(basethunk->_args[i]));
+                        }
+                        else
+                        {
+                            push_a(basethunk->_args[i]);
+                        }
                     }
                     
                     for (int i = 0; i < expr->nr_args; i++) {
-                        // TODO: eval
-                        push_a(create_thunk(((AppEntry*) expr)->args[i], frame_ptr));
+                        
+                        if(is_strict_fun_arg((FunEntry*) slice, basethunk->desc->arity + i))
+                        {
+                            push_a(NULL);
+                            exec(((AppEntry*) expr)->args[i], frame_ptr, stack_top_a);
+                        }
+                        else
+                        {
+                            push_a(create_thunk(((AppEntry*) expr)->args[i], frame_ptr));
+                        }
                     } 
                     
                     expr = ((FunEntry*) slice)->body;
@@ -200,7 +214,16 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         case CT_VAR:
             if (expr->local_type == VAR_LOCAL) {
                 Thunk* thunk = local(frame_ptr, ((VarEntry*) expr)->index);
-                                
+            
+                if(((VarEntry*) expr)->base.strict)
+                {
+                    assert(is_hnf(thunk));
+                    
+                    set_return(root_frame_ptr, thunk);
+                    destroy_stack_frame(root_frame_ptr);
+                    return;                    
+                }
+                
                 while (thunk->desc == (Desc*) __FORWARD_PTR__) {
                     thunk = thunk->_forward_ptr;
                 }
@@ -217,8 +240,15 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                     // Here frame_ptr == root_frame_ptr
                     
                     for (int i = 0; i < thunk->desc->arity; i++) {
-                        // TODO: handle strictness
-                        push_a(thunk->_args[i]);
+
+                        if(is_strict_fun_arg((FunEntry*) thunk->desc, i))
+                        {
+                            push_a(eval(thunk->_args[i]));
+                        }
+                        else
+                        {
+                            push_a(thunk->_args[i]);
+                        }
                     }
                     
                     expr = ((FunEntry*) thunk->desc)->body;
@@ -227,8 +257,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 else if(thunk->desc->type == FT_PRIM) {
 
                     for (int i = 0; i < thunk->desc->arity; i++) {
-                        // TODO: handle strictness
-                        push_a(thunk->_args[i]);
+                        push_a(eval(thunk->_args[i]));
                     }
 
                     ((PrimEntry*) thunk->desc)->exec(root_frame_ptr);
@@ -261,7 +290,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         {
             push_a(NULL);
             exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
-            Thunk* pattern = eval(pop_a());
+            Thunk* pattern = pop_a();
 
             assert(is_hnf(pattern));
             assert(pattern->desc->type == FT_ADT);            
@@ -304,7 +333,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
 
             push_a(&tmp);
             exec(((IfEntry*) expr)->cond, frame_ptr, stack_top_a);
-            Thunk* cond = eval(pop_a());
+            Thunk* cond = pop_a();
             
             if (readB(cond)) {
                 expr = ((IfEntry*) expr)->texpr;

interpreter/code.h

@@ -12,8 +12,9 @@
 struct Code {
     unsigned int type : 3;
     unsigned int local_type : 3;
-    unsigned int nr_args : 5; // used in AppEntry
-    unsigned int nr_cases : 5; // used in SelectEntry
+    unsigned int nr_args : 5;       // used in AppEntry
+    unsigned int nr_cases : 5;      // used in SelectEntry
+    unsigned int strict : 1;        // used in VarEntry
 };
 
 #define LIT_INT   			1

interpreter/debug.h

 #ifndef DEBUG_H
 #define	DEBUG_H
 
-#define DEBUG
+// Adjoxo: 2200
+
+//#define DEBUG
+#define BENCHMARK
 
 #ifndef DEBUG
 #define NDEBUG

interpreter/main.c

@@ -29,7 +29,7 @@ int main ( int argc, char *argv[] )
     init_desc();
     init_prim();
 
-    char* input = "..\\tests\\Braun.bsapl";
+    char* input = "..\\tests\\fib.bsapl";
     
     if ( argc == 2 )
     {
@@ -79,27 +79,29 @@ int main ( int argc, char *argv[] )
 
     Code* expr = parseTerm(&exprstream);
     
-#ifdef DEBUG
+#ifdef BENCHMARK
     struct timeval t1, t2;
     gettimeofday(&t1, NULL);
 #endif
-        
+            
     push_a(NULL);
     exec(expr, stack_top_a, stack_top_a);    
-    Thunk* res = eval(pop_a());
+    Thunk* res = pop_a();
 
-#ifdef DEBUG
+#ifdef BENCHMARK
     gettimeofday(&t2, NULL);
-#endif    
-    
+#endif
+
     print(res, true);
 
-#ifdef DEBUG
+#ifdef BENCHMARK
     // compute and print the elapsed time in millisec
     double elapsedTime = (t2.tv_sec - t1.tv_sec) * 1000.0;      // sec to ms
-    elapsedTime += (t2.tv_usec - t1.tv_usec) / 1000.0;   // us to ms
-    
+    elapsedTime += (t2.tv_usec - t1.tv_usec) / 1000.0;   // us to ms    
     printf("\n\nexecution time: %G ms\n", elapsedTime);
+#endif
+    
+#ifdef DEBUG    
     print_stat();
 #endif
     

interpreter/mem.h

@@ -15,12 +15,12 @@ extern Thunk  stack_b[STACK_SIZE_B];
 #define pop_a() stack_a[--stack_top_a]
 #define push_a(r) stack_a[stack_top_a++]=(r)
 
-#define local(base, idx) stack_a[base+idx-1]
+#define local(base, idx) stack_a[base+idx]
 #define set_return(base, r) stack_a[base-1]=(r)
 #define destroy_stack_frame(base) stack_top_a = base
 #define get_dst(base) stack_a[base-1]
 
-#define alloc_b(nr) stack_top_b+=nr
+#define alloc_b() &stack_b[stack_top_b++]
 
 #define destroy_stack_frame_b(base) stack_top_b = base
 

interpreter/parse.c

@@ -277,8 +277,10 @@ VarEntry* parseVar(char **ptr, VarEntry* target) {
 
     switch (type) {
         case 'L': // Local var
+        case 'S': // Strict local var    
         {
             entry->base.local_type = VAR_LOCAL;
+            entry->base.strict = type == 'S';
             if (!parseInt(ptr, &entry->index)) return 0;
             break;
         }

interpreter/thunk.c

@@ -39,50 +39,50 @@ int thunk_size(Thunk* thunk) {
     }
 }
 
-struct Thunk* updateI(Thunk* target, int i) {
-    if (target == NULL) target = (Thunk*) alloc_heap(sizeof (Thunk));
-
-    // always can be overwritten with boxed integer
-    target->desc = (Desc*) __INT__;
-    target->_int = i;
-    return target;
-}
-
+#ifdef DEBUG
 int readI(Thunk* thunk) {
     assert(thunk != NULL);
-
-#ifdef DEBUG    
+    
     if (thunk->desc != (Desc*) __INT__) {
-        printf("readI: not an integer\n");
+        printf("readI: not an integer: ");
         printDesc(thunk->desc);
         exit(-1);
     }
-#endif
     
     return thunk->_int;
 }
 
-struct Thunk* updateB(Thunk* target, int b) {
-    if (target == NULL) target = (Thunk*) alloc_heap(sizeof (Thunk));
-
-    // always can be overwritten with boxed integer
-    target->desc = (Desc*) __BOOL__;
-    target->_bool = b;
-    return target;
-}
-
 int readB(Thunk* thunk) {
     assert(thunk != NULL);
     
-#ifdef DEBUG    
+    
     if (thunk->desc != (Desc*) __BOOL__) {
-        printf("readB: not a boolean\n");
+        printf("readB: not a boolean: ");
+        printDesc(thunk->desc);
         exit(-1);
     }
-#endif
     
     return thunk->_bool;
 }
+#endif
+
+struct Thunk* updateI(Thunk* target, int i) {
+    if (target == NULL) target = (Thunk*) alloc_heap(sizeof (Thunk));
+
+    // always can be overwritten with boxed integer
+    target->desc = (Desc*) __INT__;
+    target->_int = i;
+    return target;
+}
+
+struct Thunk* updateB(Thunk* target, int b) {
+    if (target == NULL) target = (Thunk*) alloc_heap(sizeof (Thunk));
+
+    // always can be overwritten with boxed integer
+    target->desc = (Desc*) __BOOL__;
+    target->_bool = b;
+    return target;
+}
 
 struct Thunk* updateT(Thunk* target, Thunk* source) {
     if (target == NULL) target = (Thunk*) alloc_heap(sizeof (Thunk));
@@ -130,8 +130,14 @@ struct Thunk* eval(Thunk* thunk) {
         int frame_ptr = stack_top_a;
 
         for (int i = 0; i < thunk->desc->arity; i++) {
-            // TODO: handle strictness
-            push_a(thunk->_args[i]);
+            if(is_strict_fun_arg((FunEntry*) thunk->desc, i))
+            {
+                push_a(eval(thunk->_args[i]));
+            }
+            else
+            {
+                push_a(thunk->_args[i]);
+            }
         }
         exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);
         thunk = pop_a();
@@ -141,7 +147,7 @@ struct Thunk* eval(Thunk* thunk) {
         int frame_ptr = stack_top_a;
 
         for (int i = 0; i < thunk->desc->arity; i++) {
-            push_a(thunk->_args[i]);
+            push_a(eval(thunk->_args[i]));
         }
 
         ((PrimEntry*) thunk->desc)->exec(frame_ptr);        

interpreter/thunk.h

@@ -29,14 +29,21 @@ typedef struct __attribute__((packed)) Thunk {
 
 Thunk* forward_to(Thunk* target, Thunk* thunk);
 
-struct Thunk* updateI(Thunk* target, int i);
-int readI(Thunk* thunk);
+#ifdef DEBUG
 
-struct Thunk* updateB(Thunk* target, int b);
+int readI(Thunk* thunk);
 int readB(Thunk* thunk);
 
-struct Thunk* updateT(Thunk* target, Thunk* source);
+#else
 
+#define readI(thunk) thunk->_int
+#define readB(thunk) thunk->_bool
+
+#endif
+
+struct Thunk* updateI(Thunk* target, int i);
+struct Thunk* updateB(Thunk* target, int b);
+struct Thunk* updateT(Thunk* target, Thunk* source);
 struct Thunk* updateF(Thunk* target, Desc* f);
 
 bool is_hnf(Thunk* thunk);

precompiler/precompiler.icl

@@ -14,7 +14,7 @@ from Text.Unicode.UChar import instance toChar UChar
 import System.CommandLine
 import System.File
 
-:: VarType = Local Int | Fun String
+:: VarType = Local Int Bool | Fun String
 
 :: Context = { vars       :: Map String VarType
 			 , localcount :: Int
@@ -22,15 +22,18 @@ import System.File
 
 newContext = {vars = newMap, localcount = 0}
 
+registerArgs vars idx [] = vars
+registerArgs vars idx [v:vs] = registerArgs (put (unpackVar v) (Local idx (isStrictVar v)) vars) (idx + 1) vs
+
 registerLocals vars idx [] = vars
-registerLocals vars idx [v:vs] = registerLocals (put (unpackVar v) (Local (idx+1)) vars) (idx + 1) vs
+registerLocals vars idx [v:vs] = registerLocals (put (unpackVar v) (Local idx (isStrictVar v)) vars) (idx + 1) vs
 
 calcStrictness [] = 0
 calcStrictness [StrictVar _ _:vs] = (1 << (length vs)) + calcStrictness vs
 calcStrictness [NormalVar _ _:vs] = calcStrictness vs
 
 sFunc ctx (FTFunc name body params) a 
-	# ctx = {ctx & vars = registerLocals ctx.vars 0 params, localcount = length params}
+	# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params}
 	= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params) <++ sTerm ctx body
 
 sFunc ctx (FTCAF name body) a 
@@ -69,8 +72,9 @@ sSelectCase ctx (PDefault, expr) a
 
 sVar ctx var a
 	= case get varName ctx.vars of
-		(Just (Local i)) = a <++ "L" <++ sNum i
-		_				 = a <++ "F" <++ sText varName
+		(Just (Local i True))  = a <++ "S" <++ sNum i
+		(Just (Local i False)) = a <++ "L" <++ sNum i
+		_				       = a <++ "F" <++ sText varName
 where
 	varName = unpackVar var