update to new SAPL

interpreter/code.c

@@ -15,6 +15,7 @@
 #include "mem.h"
 #include "desc.h"
 #include "gc.h"
+#include "prim.h"
 
 // For compressing the source code a bit
 
@@ -58,6 +59,7 @@ void create_thunk_app_static(Code* expr, Thunk** target, int frame_ptr)
     assert(thunk->desc->arity == expr->nr_args);
 
     for (int i = 0; i < expr->nr_args; i++) {
+          assert(((AppEntry*) expr)->args[i]->create_thunk != NULL);
          ((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], &thunk->_args[i], frame_ptr);
     }                     
 }
@@ -121,6 +123,18 @@ void create_thunk_thunk(Code* expr, Thunk** target, int frame_ptr)
     assert(!instackb(*target));
 }
 
+void create_thunk_select(Code* expr, Thunk** target, int frame_ptr)
+{
+    Thunk* thunk = (Thunk*) alloc_heap(sizeof(AppEntry) + sizeof(Thunk*) * 2);
+    *target = thunk;
+    thunk->desc = (Desc*) selectDesc;
+
+    ((SelectEntry*) expr)->expr->create_thunk(((SelectEntry*) expr)->expr, &thunk->_args[0], frame_ptr);
+    thunk->_args[1] = &((SelectEntry*) expr)->idx;
+    
+    *target = thunk;
+}
+
 void set_create_thunk_fun(Code* code)
 {
     switch(code->type)
@@ -147,10 +161,13 @@ void set_create_thunk_fun(Code* code)
         case CT_THUNK:
             code->create_thunk = create_thunk_thunk;
             break;
-        case CT_SELECT_ADT:
-        case CT_SELECT_LIT:    
-        case CT_SELECT_STR:
-        case CT_SELECT_REC:
+        case CT_SELECT:
+            code->create_thunk = create_thunk_select;
+            break;
+        case CT_CASE_ADT:
+        case CT_CASE_LIT:    
+        case CT_CASE_STR:
+        case CT_CASE_REC:
         case CT_IF:
         case CT_LET:
             code->create_thunk = NULL;
@@ -320,7 +337,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         case CT_APP_FUN:
         {            
             Desc* slice = ((AppEntry*) expr)->f;
-
+            
             int new_frame_ptr = stack_top_a;
             int argmask = 1;
             
@@ -421,9 +438,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             while(totalArity > baseDesc->arity)
             {
                 // must be an FT_FUN
-                                
-                Desc* d = (*bt)->desc;
-                
+                                                
                 int remainingNrArgs = totalArity - baseDesc->arity;        
                 slice = get_slice(baseDesc, baseDesc->arity);
               
@@ -709,16 +724,16 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             destroy_stack_frame_b(root_frame_ptr_b);
             return;               
         }
-        case CT_SELECT_LIT:
+        case CT_CASE_LIT:
         {
             placeholder();
-            exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
+            exec(((CaseEntry*) expr)->expr, frame_ptr, stack_top_a);
             Thunk* lit = pop_a();
             
             bool handled = false;
             
             for (int i = 0; i < expr->nr_cases; i++) {
-                SelectLitCaseEntry* caseEntry = &((SelectEntry*) expr)->cases[i];
+                CaseLitCaseEntry* caseEntry = &((CaseEntry*) expr)->cases[i];
 
                 // NULL means "default", we accept it anyway
                 if(caseEntry->lit != NULL)
@@ -746,22 +761,44 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             
             if(handled) continue;
             
-            if(((SelectEntry*) expr)->fallback != NULL)
+            if(((CaseEntry*) expr)->fallback != NULL)
             {
-                stack_top_a -= ((SelectEntry*) expr)->fallback_nrargs;
-                expr = ((SelectEntry*) expr)->fallback;
+                stack_top_a -= ((CaseEntry*) expr)->fallback_nrargs;
+                expr = ((CaseEntry*) expr)->fallback;
                 
                 continue;
             }
             
             abort("no match");
         }
-        case CT_SELECT_STR:
-        {                        
-            SelectEntry* select = (SelectEntry*) expr;
+        case CT_SELECT:
+        {
+            push_a(NULL);
+            exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
+            Thunk* cons = pop_a();
             
+            push_a(cons->_args[((SelectEntry*) expr)->idx._int]);
+            peek_a()->desc->eval();
+            Thunk* ret = pop_a();
+
+            if(get_dst(root_frame_ptr) != NULL && ret->desc->thunk_size <= sizeof(Thunk))
+            {
+                memcpy(get_dst(root_frame_ptr), ret, sizeof(Thunk));
+            }
+            else
+            {   
+                forward_thunk(ret, root_frame_ptr);
+                set_return(root_frame_ptr, ret);
+            }
+                          
+            destroy_stack_frame(root_frame_ptr);
+            destroy_stack_frame_b(root_frame_ptr_b);
+            return;
+        }
+        case CT_CASE_STR:
+        {                        
             push_a(NULL);
-            exec(select->expr, frame_ptr, stack_top_a);
+            exec(((CaseEntry*) expr)->expr, frame_ptr, stack_top_a);
             Thunk* str = pop_a();
             
             int length;
@@ -781,7 +818,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             bool handled = false;
             
             for (int i = 0; i < expr->nr_cases; i++) {
-                SelectLitCaseEntry* caseEntry = &((SelectEntry*) expr)->cases[i];
+                CaseLitCaseEntry* caseEntry = &((CaseEntry*) expr)->cases[i];
 
                 // NULL means "default", we accept it anyway
                 if(caseEntry->lit != NULL)
@@ -807,30 +844,30 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             
             if(handled) continue;
             
-            if(((SelectEntry*) expr)->fallback != NULL)
+            if(((CaseEntry*) expr)->fallback != NULL)
             {
-                stack_top_a -= ((SelectEntry*) expr)->fallback_nrargs;
-                expr = ((SelectEntry*) expr)->fallback;
+                stack_top_a -= ((CaseEntry*) expr)->fallback_nrargs;
+                expr = ((CaseEntry*) expr)->fallback;
                 
                 continue;
             }
             
             abort("no match");
         }
-        case CT_SELECT_ADT:
+        case CT_CASE_ADT:
         {                        
-            SelectEntry* select = (SelectEntry*) expr;
+            CaseEntry* caseEntry = (CaseEntry*) expr;
             
             push_a(NULL);
-            exec(select->expr, frame_ptr, stack_top_a);
+            exec(caseEntry->expr, frame_ptr, stack_top_a);
             Thunk* cons = pop_a();            
                                     
-            expr = select->bodies[((ADTEntry*)cons->desc)->idx];
+            expr = caseEntry->bodies[((ADTEntry*)cons->desc)->idx];
             
             if(expr != NULL)
             {
                 // Skip the arguments in the case of a default 
-                if(!(select->default_map & 1<<((ADTEntry*)cons->desc)->idx))
+                if(!(caseEntry->default_map & 1<<((ADTEntry*)cons->desc)->idx))
                 {
                     for (int i = 0; i < cons->desc->arity; i++) {
                         push_a(cons->_args[i]);
@@ -840,25 +877,25 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 continue;
             }
             
-            if(select->fallback != NULL)
+            if(caseEntry->fallback != NULL)
             {
-                stack_top_a -= select->fallback_nrargs;
-                expr = select->fallback;
+                stack_top_a -= caseEntry->fallback_nrargs;
+                expr = caseEntry->fallback;
                 
                 continue;
             }
             
             abort("no match");
         }
-        case CT_SELECT_REC:
+        case CT_CASE_REC:
         {                        
-            SelectEntry* select = (SelectEntry*) expr;
+            CaseEntry* caseEntry = (CaseEntry*) expr;
             
             push_a(NULL);
-            exec(select->expr, frame_ptr, stack_top_a);
+            exec(caseEntry->expr, frame_ptr, stack_top_a);
             Thunk* cons = pop_a();            
             
-            expr = select->bodies[0];
+            expr = caseEntry->bodies[0];
             
             if(expr != NULL)
             {
@@ -927,6 +964,7 @@ void eval_hnf()
 void eval_fun()
 {
     Thunk* thunk = peek_a();    
+    
     int frame_ptr = stack_top_a;
     int argmask = 1;
     
@@ -942,7 +980,7 @@ void eval_fun()
         argmask <<= 1;
     }
 
-    exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);
+    exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);    
 }
 
 void eval_prim()

interpreter/code.h

@@ -15,10 +15,11 @@ enum CodeType {
     CT_APP_FUN1, 
     CT_APP_FUN2, 
     CT_APP_FUN_TR,      // tail recursive 
-    CT_SELECT_ADT, 
-    CT_SELECT_LIT, 
-    CT_SELECT_STR,
-    CT_SELECT_REC,      // Record field selection
+    CT_SELECT,
+    CT_CASE_ADT, 
+    CT_CASE_LIT, 
+    CT_CASE_STR,
+    CT_CASE_REC,      // Record field selection
     CT_IF, 
     CT_LET, 
     CT_THUNK            // constant, always fits the B stack
@@ -53,12 +54,18 @@ struct AppEntry {
     struct Code* args[];
 };
 
-struct SelectLitCaseEntry {
+struct SelectEntry {
+    struct Code base;
+    struct Code* expr;
+    Thunk idx; 
+};
+
+struct CaseLitCaseEntry {
     struct Code* body;    
     struct ThunkEntry* lit; // NULL -> default
 };
 
-struct SelectEntry {
+struct CaseEntry {
     struct Code base;
     struct Code* expr;
     
@@ -71,7 +78,7 @@ struct SelectEntry {
     
     union
     {
-        struct SelectLitCaseEntry cases[];
+        struct CaseLitCaseEntry cases[];
         struct Code* bodies[];
     };
 };

interpreter/desc.c

@@ -3,6 +3,7 @@
 #include <stdbool.h>
 #include <assert.h>
 
+#include "debug.h"
 #include "desc.h"
 #include "khash.h"
 #include "mem.h"

interpreter/main.c

@@ -74,7 +74,7 @@ int main ( int argc, char *argv[] )
     
     parse(&line, len);
     
-    input = "..\\tests\\static_os.bsapl";
+    input = "..\\tests\\jurrien.bsapl";
     
     if ( argc == 2 )
     {

interpreter/parse.c

@@ -511,13 +511,13 @@ Code* parseApp(char **ptr, bool dynamic, bool tr) {
     }
 }
 
-SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
+CaseEntry* parseCase(char **ptr, Code* fallback, int fallback_nrargs) {
     Code* expr = parseTerm(ptr);
-
+    
     int nrCases;
     if (!parseInt(ptr, &nrCases)) return 0;
-
-    struct SelectEntry* entry = NULL;    
+    
+    struct CaseEntry* entry = NULL;    
     
     char type = **ptr;
 
@@ -556,11 +556,11 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
         Code* firstBody = (Code*) parseFallbackBody(ptr, child_fallback, 
             child_fallback_base_nrargs + firstCase->arity);   
         
-        entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (Code*) * nrConses);
+        entry = (CaseEntry*) alloc_code(sizeof (CaseEntry) + sizeof (Code*) * nrConses);
         
         if(firstCase->type == FT_ADT)
         {
-            entry->base.type = CT_SELECT_ADT;
+            entry->base.type = CT_CASE_ADT;
             entry->base.nr_cases = nrConses;
             entry->default_map = 0xFFFFFFFF;
             
@@ -585,15 +585,15 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
         }
         else
         {
-            entry->base.type = CT_SELECT_REC;
+            entry->base.type = CT_CASE_REC;
             entry->base.nr_cases = 1;
             entry->bodies[0] = firstBody;
         }
     }
     else
     {
-        entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (SelectLitCaseEntry) * nrCases);
-        entry->base.type = CT_SELECT_LIT;
+        entry = (CaseEntry*) alloc_code(sizeof (CaseEntry) + sizeof (CaseLitCaseEntry) * nrCases);
+        entry->base.type = CT_CASE_LIT;
         entry->base.nr_cases = nrCases;
         
         if(isDefault)
@@ -610,7 +610,7 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
             // String literal is the third case for efficiency reasons
             if(i == 0 && entry->cases[i].lit->thunk.desc == (Desc*) __STRING_PTR__) 
             {
-                entry->base.type = CT_SELECT_STR;
+                entry->base.type = CT_CASE_STR;
             }
             
             entry->cases[i].body = (Code*) parseFallbackBody(ptr, child_fallback, child_fallback_base_nrargs);
@@ -640,10 +640,10 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
 
     char type = **ptr;
     
-    if(type == 'S')
+    if(type == 'C')
     {
         (*ptr)++;
-        return (Code*) parseSelect(ptr, fallback, fallback_nrargs);
+        return (Code*) parseCase(ptr, fallback, fallback_nrargs);
     }
     else if(type == 'I')
     {
@@ -656,6 +656,18 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
     }
 }
 
+SelectEntry* parseSelect(char **ptr) {
+    
+    struct SelectEntry* entry = (SelectEntry*) alloc_code(sizeof (SelectEntry));
+    entry->expr = parseTerm(ptr);
+    entry->base.type = CT_SELECT;
+    entry->idx.desc = (Desc*) __INT__;
+    if (!parseInt(ptr, &entry->idx._int)) return 0;
+    
+    set_create_thunk_fun((Code*) entry);
+    return entry;
+}
+
 LetEntry* parseLet(char **ptr) {
     Code* body = parseTerm(ptr);
     
@@ -713,7 +725,9 @@ Code* parseTerm(char **ptr) {
         case 'D': // Dynamic application
             return (Code*) parseApp(ptr, true, false);
         case 'S': // Select
-            return (Code*) parseSelect(ptr, NULL, 0);
+            return (Code*) parseSelect(ptr);
+        case 'C': // Case
+            return (Code*) parseCase(ptr, NULL, 0);
         case 'I': // If
             return (Code*) parseIf(ptr, NULL, 0);
         case 'E': // Let

interpreter/prim.c

@@ -372,6 +372,7 @@ void __array_select(int dst_idx)
     int pos = readI(arg(1));
 
     Thunk* elem = arr->_array._elems[pos];
+    elem->desc->eval();
     
     if(target != NULL)
     {
@@ -583,55 +584,90 @@ void __string_update_copy(int dst_idx)
 
 void __string_update(int dst_idx)
 {
+    Thunk* target = get_dst(dst_idx);
     Thunk* arr = arg(3);
     int idx = readI(arg(2));
     char elem = readC(arg(1));
             
     arr->_array._chars[idx] = (char) elem;
+
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = arr;
+    }
     
     set_return(dst_idx, arr);   
 }
 
 void __array_update(int dst_idx)
 {
+    Thunk* target = get_dst(dst_idx);
     Thunk* arr = arg(3);
     int idx = readI(arg(2));
     Thunk* elem = arg(1);
             
     arr->_array._elems[idx] = elem;
     
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = arr;
+    }
+
     set_return(dst_idx, arr);   
 }
 
 void __array_update_b_i(int dst_idx)
 {
+    Thunk* target = get_dst(dst_idx);
     Thunk* arr = arg(3);
     int idx = readI(arg(2));
     int elem = readI(arg(1));
             
     arr->_array._ints[idx] = elem;
+
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = arr;
+    }
     
     set_return(dst_idx, arr);   
 }
 
 void __array_update_b_b(int dst_idx)
 {
+    Thunk* target = get_dst(dst_idx);
     Thunk* arr = arg(3);
     int idx = readI(arg(2));
     int elem = readB(arg(1));
             
     arr->_array._bools[idx] = (unsigned char) elem;
+
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = arr;
+    }
     
     set_return(dst_idx, arr);   
 }
 
 void __array_update_b_r(int dst_idx)
 {
+    Thunk* target = get_dst(dst_idx);
     Thunk* arr = arg(3);
     int idx = readI(arg(2));
     double elem = readR(arg(1));
             
     arr->_array._reals[idx] = elem;
+
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = arr;
+    }
     
     set_return(dst_idx, arr);   
 }
@@ -874,7 +910,27 @@ void __abort(int dst_idx)
     exit(-1);
 }
 
-void add_prim(int arity, int boxingMap, int unboxableReturn,  char* name, void (*exec)(int)) {
+void __select(int dst_idx)
+{
+    Thunk* target = get_dst(dst_idx);
+    Thunk* cons = arg(2);
+    int idx = readI(arg(1));
+
+    push_a(cons->_args[idx]);
+    cons->_args[idx]->desc->eval();
+    
+    Thunk* ret = pop_a();
+    
+    if(target != NULL)
+    {
+        target->desc = (Desc*) __FORWARD_PTR__;
+        target->_forward_ptr = ret;
+    }
+    
+    set_return(dst_idx, ret);
+}
+
+PrimEntry* add_prim(int arity, int boxingMap, int unboxableReturn,  char* name, void (*exec)(int)) {
     int nameLength = strlen(name);
 
     // before the PrimEntry there are "arity" number of SliceEntries
@@ -897,6 +953,7 @@ void add_prim(int arity, int boxingMap, int unboxableReturn,  char* name, void (
     if (arity > 0) gen_slices(entry_base, (Desc*) entry, arity);
 
     add_desc(entry->name, (Desc*) entry);
+    return entry;
 }
 
 void init_prim() {
@@ -995,4 +1052,9 @@ void init_prim() {
     
     add_prim(1, 0b000, 0, "_trace", &__trace);
     add_prim(1, 0b000, 0, "abort", &__abort);
+    selectDesc = add_prim(2, 0b001, 0, "_select", &__select);
 }
+
+// For lazy select
+PrimEntry* selectDesc;
+

interpreter/prim.h

 #ifndef __PRIM_H
 #define __PRIM_H
 
+#include "desc.h"
+
 void init_prim();
 
+extern PrimEntry* selectDesc;
+
 #endif // __PRIM_H
\ No newline at end of file

interpreter/thunk.h

 #ifndef __THUNK_H
 #define __THUNK_H
 
+#include "debug.h"
 #include "desc_base.h"
 
 #define max(a,b) \

precompiler/precompiler.icl

@@ -3,7 +3,9 @@ module precompiler
 import Sapl.SaplParser
 import Sapl.SaplTokenizer
 import Sapl.Transform.Let
-
+import Sapl.Optimization.StrictnessPropagation
+import Sapl.Transform.AddSelectors
+import Lifting, Prims
 import StdBool, StdList, StdOrdList, StdFile, StdFunc, StdArray, StdDebug
 
 import Text.StringAppender, Text 
@@ -15,6 +17,7 @@ from Text.Unicode.UChar import instance toChar UChar, instance toInt UChar
 import System.CommandLine
 import System.File
 
+
 :: TypeInfo = Normal | Strict | UnBoxable 
 :: VarType = Local Int TypeInfo
 
@@ -25,10 +28,10 @@ import System.File
 			 }
 
 // Fusion of function applications for some very basic cases
-simplify (SApplication var1 [SApplication var2 args]) | unpackVar var1 == "not" && unpackVar var2 == "eqI"
-	= SApplication (NormalVar "neqI" 0) args
-simplify (SApplication var1 [SApplication var2 args]) | unpackVar var1 == "not" && unpackVar var2 == "ltI"
-	= SApplication (NormalVar "geI" 0) args
+simplify (SApplication (SVar var1) [SApplication (SVar var2) args]) | unpackVar var1 == "not" && unpackVar var2 == "eqI"
+	= SApplication (SVar (NormalVar "neqI" 0)) args
+simplify (SApplication (SVar var1) [SApplication (SVar var2) args]) | unpackVar var1 == "not" && unpackVar var2 == "ltI"
+	= SApplication (SVar (NormalVar "geI" 0)) args
 simplify x = x
 
 unBoxableType (Type "I") = True
@@ -63,7 +66,7 @@ sFunc ctx (FTFunc name body params) a
 	# 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
+	<++ sTerm ctx (addSelectors body)
 
 sFunc ctx (FTCAF name body) a 
 	# ctx = {ctx & inspine = False, currentFun = (unpackVar name)}
@@ -94,9 +97,13 @@ sTerm ctx t a = sTermS ctx (simplify t) a
 where
 	sTermS ctx (SLit lit) a = a <++ "L" <++ lit
 	sTermS ctx (SVar var) a = a <++ sVarApp ctx var