a handful of bugfixes

interpreter/code.c

@@ -166,9 +166,9 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
     if(heap_curr > gc_trigger) gc();
     
     int root_frame_ptr_b = stack_top_b;    
-    
+        
     while(1)
-    {        
+    {      
         assert(expr != NULL);
         assert(stack_top_a < STACK_SIZE_A);
         assert(stack_top_b < STACK_SIZE_B);
@@ -178,7 +178,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         
         switch (expr->type) {
         case CT_APP_PRIM_FAST:
-        {                       
+        {                         
             // careful, "exec" may trigger garbage collection
             // read local variables only after the last exec            
             switch(expr->arg_pattern)
@@ -238,7 +238,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 Thunk* tmp = (Thunk*) alloc_heap(sizeof(Thunk));
                 set_return(root_frame_ptr, tmp);
             }
-                        
+
             ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr);
 
             destroy_stack_frame(root_frame_ptr);
@@ -249,7 +249,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         {           
             PrimEntry* desc = (PrimEntry*) ((AppEntry*) expr)->f;
             int argmask = 1;            
-            
+
             for (int i = 0; i < desc->base.arity; i++) {
 
                 if(desc->boxingMap & argmask)
@@ -270,7 +270,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 Thunk* tmp = (Thunk*) alloc_heap(sizeof(Thunk));
                 set_return(root_frame_ptr, tmp);
             }
-            
+
             desc->exec(root_frame_ptr);
             
             destroy_stack_frame(root_frame_ptr);
@@ -291,7 +291,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         case CT_APP_FUN2:
         {
             Desc* slice = ((AppEntry*) expr)->f;
-                        
+
             int argmask = 1;
             
             arg_from_code(slice, ((AppEntry*) expr)->args[0]);
@@ -304,7 +304,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;
             
@@ -319,7 +319,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         case CT_APP_FUN_TR:
         {            
             Desc* slice = ((AppEntry*) expr)->f;
-            
+
             // TODO: B stack?
             int new_frame_ptr = stack_top_a;
             int argmask = 1;
@@ -522,8 +522,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
                 not_implemented("CAF");
             }
         }
-        case CT_VAR_STRICT:
-        case CT_VAR_UNBOXED:            
+        case CT_VAR_UNBOXED:       
         {
             Thunk* arg = local(frame_ptr, ((VarEntry*) expr)->index);
             follow_thunk(arg);
@@ -531,7 +530,38 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             assert(is_hnf(arg));
 
             // no need to check for array length, thunks in HNF are never overwritten
-            if(get_dst(root_frame_ptr) != NULL && arg->desc->thunk_size <= sizeof(Thunk))
+            if(get_dst(root_frame_ptr) != NULL)
+            {
+                memcpy(get_dst(root_frame_ptr), arg, sizeof(Thunk));
+            }
+            else
+            {
+                if(instackb(arg))
+                {
+                    Thunk* newthunk = (Thunk*) alloc_heap(sizeof (Thunk));
+                    memcpy(newthunk, arg, sizeof(Thunk));
+                    set_return(root_frame_ptr, newthunk);
+                }
+                else
+                {
+                    set_return(root_frame_ptr, arg);
+                }
+            }
+            
+            destroy_stack_frame(root_frame_ptr);
+            destroy_stack_frame_b(root_frame_ptr_b);            
+            return;                                
+        }
+        case CT_VAR_STRICT:     
+        {
+            Thunk* arg = local(frame_ptr, ((VarEntry*) expr)->index);
+            follow_thunk(arg);
+                        
+            assert(is_hnf(arg));
+
+            // no need to check for array length, thunks in HNF are never overwritten
+            // arrays always referenced
+            if(get_dst(root_frame_ptr) != NULL && arg->desc->thunk_size <= sizeof(Thunk) && arg->desc != (Desc*) __ARRAY__)
             {
                 memcpy(get_dst(root_frame_ptr), arg, sizeof(Thunk));
             }
@@ -548,7 +578,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
         case CT_VAR:
         {
             Thunk* thunk = local(frame_ptr, ((VarEntry*) expr)->index);
-
+            
             assert(!instackb(thunk));
             
             follow_thunk(thunk);
@@ -583,11 +613,9 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             }
             case FT_PRIM:
             {
-                int argmask = 1;
-                
                 for (int i = 0; i < thunk->desc->arity; i++) {
                     push_a(thunk->_args[i]);
-                    if(((PrimEntry*)thunk->desc)->boxingMap & argmask) thunk->_args[i]->desc->eval();
+                    thunk->_args[i]->desc->eval();
                     thunk = stack_a[root_frame_ptr-1];
                 }
 
@@ -741,7 +769,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
             push_a(NULL);
             exec(select->expr, frame_ptr, stack_top_a);
             Thunk* cons = pop_a();            
-            
+                        
             expr = select->bodies[((ADTEntry*)cons->desc)->idx];
             
             if(expr != NULL)

interpreter/prim.c

@@ -549,7 +549,7 @@ void __array_create2_b_r(int dst_idx)
     set_return(dst_idx, target);   
 }
 
-void __string_update(int dst_idx)
+void __string_update_copy(int dst_idx)
 {
     Thunk* target = get_dst(dst_idx);
     Thunk* str = arg(3);
@@ -577,6 +577,16 @@ void __string_update(int dst_idx)
     
     set_return(dst_idx, target);   
 }
+void __string_update(int dst_idx)
+{
+    Thunk* arr = arg(3);
+    Thunk* idx = arg(2);
+    Thunk* elem = arg(1);
+            
+    arr->_array._chars[idx->_int] = (char) elem->_int;
+    
+    set_return(dst_idx, arr);   
+}
 
 void __array_update(int dst_idx)
 {
@@ -816,7 +826,7 @@ void __I2S(int dst_idx) {
     int len = strlen(buff);
     
     target = string_create(target, len);
-    memcpy(target->_string_ptr->chars, buff, len);
+    memcpy(&target->_array._chars, buff, len);
     set_return(dst_idx, target);
 }
 
@@ -829,7 +839,7 @@ void __R2S(int dst_idx) {
     int len = strlen(buff);
     
     target = string_create(target, len);
-    memcpy(target->_string_ptr->chars, buff, len);
+    memcpy(target->_array._chars, buff, len);
     set_return(dst_idx, target);
 }
 
@@ -932,11 +942,11 @@ void init_prim() {
     
     add_prim(1, 0b001, 1, "C2I", &__C2I);
     add_prim(1, 0b001, 1, "R2I", &__R2I);
-    add_prim(1, 0b001, 1, "S2I", &__S2I);
+    add_prim(1, 0b000, 1, "S2I", &__S2I);
     add_prim(1, 0b001, 1, "I2C", &__I2C);
     add_prim(1, 0b001, 1, "I2R", &__I2R);
     add_prim(1, 0b001, 1, "R2R", &__R2R);
-    add_prim(1, 0b000, 0, "S2R", &__S2R);
+    add_prim(1, 0b000, 1, "S2R", &__S2R);
             
     add_prim(1, 0b001, 0, "array_create1", &__array_create1);
     add_prim(1, 0b001, 0, "array_create1_lazy", &__array_create1);
@@ -973,6 +983,7 @@ void init_prim() {
     add_prim(1, 0b001, 0, "string_create1", &__string_create1);
     add_prim(2, 0b011, 0, "string_create2", &__string_create2);    
     add_prim(3, 0b110, 0, "string_update", &__string_update);
+    add_prim(3, 0b110, 0, "string_update_copy", &__string_update_copy);
     add_prim(3, 0b110, 0, "string_slice", &__string_slice);
     add_prim(2, 0b000, 0, "string_append", &__string_append);
     add_prim(2, 0b000, 1, "eqS", &__eqS);

interpreter/thunk.c

@@ -82,7 +82,7 @@ void print(bool force) {
                 printf("False");
             }
         } else if ((FunEntry*) thunk->desc == __CHAR__) {
-            printf("%c", (char) thunk->_int);
+            printf("'%c'", (char) thunk->_int);
         } else if ((FunEntry*) thunk->desc == __REAL__) {
             printf("%G", thunk->_real);            
         } else if ((FunEntry*) thunk->desc == __STRING_PTR__) {