extensive testing, rewrite of argument passing, fixes editor and gtn

sledge/compiler_new.c

@@ -27,8 +27,6 @@ Cell* insert_symbol(Cell* symbol, Cell* cell, env_t** env) {
   env_entry* e;
   int found = sm_get(*env, symbol->ar.addr, (void**)&e);
   
-  //printf("sm_get res: %d\r\n",found);
-  
   if (found) {
     e->cell = cell;
     //printf("[insert_symbol] update %s entry at %p (cell: %p value: %d)\r\n",symbol->ar.addr,e,e->cell,e->cell->ar.value);
@@ -95,20 +93,6 @@ void load_int(int dreg, Arg arg, Frame* f) {
     // argument is a constant like 123, "foo"
     jit_movi(dreg, (jit_word_t)arg.cell->ar.value);
   }
-  else if (arg.type == ARGT_CELL) {
-    if (arg.cell == NULL) {
-      // not sure what this is
-      //if (dreg!=R0) jit_movr(dreg, R0);
-      if (dreg!=R1+arg.slot) {
-        jit_movr(dreg, R1+arg.slot); // FIXME: really true?
-      }
-      jit_ldr(dreg);
-    } else {
-      // argument is a cell pointer
-      jit_lea(dreg, arg.cell);
-      jit_ldr(dreg);
-    }
-  }
   else if (arg.type == ARGT_ENV) {
     // argument is an environment table entry, load e->cell->ar.value
     jit_lea(dreg, arg.env);
@@ -117,20 +101,22 @@ void load_int(int dreg, Arg arg, Frame* f) {
   }
   else if (arg.type == ARGT_REG) {
     // argument comes from a register
-    jit_movr(dreg, LBDREG+arg.slot);
+    jit_movr(dreg, arg.slot);
     jit_ldr(dreg);
   }
-  else if (arg.type == ARGT_INT) {
-    if (dreg!=R1+arg.slot) {
-      jit_movr(dreg, R1+arg.slot); // FIXME: really true?
+  else if (arg.type == ARGT_REG_INT) {
+    if (dreg!=arg.slot) {
+      jit_movr(dreg, arg.slot);
     }
   }
   else if (arg.type == ARGT_STACK) {
-    jit_ldr_stack(dreg, PTRSZ*(arg.slot+f->sp));
+    //printf("loading int from stack slot %d + sp %d to reg %d\n",arg.slot,f->sp,dreg);
+    jit_ldr_stack(dreg, PTRSZ*(f->sp-arg.slot));
     jit_ldr(dreg);
   }
   else if (arg.type == ARGT_STACK_INT) {
-    jit_ldr_stack(dreg, PTRSZ*(arg.slot+f->sp));
+    //printf("loading int from stack_int sp %d - slot %d to reg %d\n",f->sp,arg.slot,dreg);
+    jit_ldr_stack(dreg, PTRSZ*(f->sp-arg.slot));
   }
   else {
     jit_movi(dreg, 0xdeadbeef);
@@ -138,40 +124,36 @@ void load_int(int dreg, Arg arg, Frame* f) {
 }
 
 void load_cell(int dreg, Arg arg, Frame* f) {
-  if (arg.type == ARGT_CELL || arg.type == ARGT_CONST) {
-    if (arg.cell == NULL) {
-      // not sure what this is
-      jit_movr(dreg, R1+arg.slot); // FIXME: really true?
-    } else {
-      // argument is a cell pointer
-      jit_lea(dreg, arg.cell);
-    }
+  if (arg.type == ARGT_CONST) {
+    // argument is a constant like 123, "foo"
+    jit_movi(dreg, (jit_word_t)arg.cell);
   }
   else if (arg.type == ARGT_ENV) {
     jit_lea(dreg, arg.env);
     jit_ldr(dreg);
   }
   else if (arg.type == ARGT_REG) {
-    jit_movr(dreg, LBDREG+arg.slot);
+    jit_movr(dreg, arg.slot);
+  }
+  else if (arg.type == ARGT_REG_INT) {
+    jit_call(alloc_int, "alloc_int");
+    jit_movr(dreg,R0);
   }
   else if (arg.type == ARGT_STACK) {
-    jit_ldr_stack(dreg, PTRSZ*(arg.slot+f->sp));
+    //printf("loading cell from stack slot %d + sp %d to reg %d\n",arg.slot,f->sp,dreg);
+    jit_ldr_stack(dreg, PTRSZ*(f->sp-arg.slot));
   }
   else if (arg.type == ARGT_STACK_INT) {
-    // FIXME possible ARGR0 clobbering
     int adjust = 0;
+    //printf("loading cell from stack_int sp %d - slot %d + adjust %d = %d to reg %d\n",f->sp,arg.slot,adjust,f->sp-arg.slot+adjust,dreg);
     if (dreg!=ARGR0) {jit_push(ARGR0,ARGR0); adjust++;}
     if (dreg!=R0) {jit_push(R0,R0); adjust++;}
-    jit_ldr_stack(ARGR0, PTRSZ*(arg.slot+f->sp+adjust));
+    jit_ldr_stack(ARGR0, PTRSZ*(f->sp-arg.slot+adjust));
     jit_call(alloc_int, "alloc_int");
     jit_movr(dreg,R0);
     if (dreg!=R0) jit_pop(R0,R0);
     if (dreg!=ARGR0) jit_pop(ARGR0,ARGR0);
   }
-  else if (arg.type == ARGT_INT) {
-    jit_call(alloc_int, "alloc_int");
-    jit_movr(dreg,R0);
-  }
   else {
     printf("arg.type: %d\r\n",arg.type);
     jit_movi(dreg, 0xdeadcafe);
@@ -285,6 +267,15 @@ int compatible_type(int given, int required) {
   return 0;
 }
 
+int clean_return(int args_pushed, Frame* frame, int compiled_type) {
+  if (args_pushed) {
+    jit_inc_stack(args_pushed*PTRSZ);
+    frame->sp-=args_pushed;
+  }
+
+  return compiled_type;
+}
+
 int compile_expr(Cell* expr, Frame* frame, int return_type) {
   int compiled_type = TAG_ANY;
   Arg* fn_frame = frame->f;
@@ -293,6 +284,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
   
   int is_let = 0;
   int argi = 0;
+  int args_pushed = 0;
   Arg argdefs[MAXARGS];
 
   if (!expr) return 0;
@@ -427,7 +419,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       if (!signature_args) {
         // any number of arguments allowed
         argdefs[argi].cell = arg;
-        argdefs[argi].type = ARGT_CELL;
+        argdefs[argi].type = ARGT_STACK;
       }
       else if (sig_tag == TAG_LAMBDA) {
         // lazy evaluation by form
@@ -435,32 +427,40 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
         argdefs[argi].type = ARGT_LAMBDA;
       }
       else if (arg->tag == TAG_CONS) {
+        int k;
         // eager evaluation
         // nested expression
         if (argi>0) {
           // save registers
           // FIXME RETHINK
 
-          jit_push(R1,R1+argi-1);
-          frame->sp+=(1+argi-1);
+          //jit_push(R1,R1+argi-1);
+          //frame->sp+=(1+argi-1);
         }
         given_tag = compile_expr(arg, frame, sig_tag);
         if (given_tag<1) return given_tag; // failure
         
         argdefs[argi].cell = NULL; // cell is in R0 at runtime
-        argdefs[argi].slot = argi;
+        argdefs[argi].slot = ++frame->sp; // record sp at this point
+
+        /*for (k=0; k<argi; k++) {
+          if (argdefs[k].type == ARGT_STACK || argdefs[k].type == ARGT_STACK_INT) {
+            argdefs[k].slot++;
+          }
+        }*/
 
         if (given_tag == TAG_INT) {
-          argdefs[argi].type = ARGT_INT;
-          jit_movr(R1+argi,ARGR0);
+          argdefs[argi].type = ARGT_STACK_INT;
         } else {
-          argdefs[argi].type = ARGT_CELL;
-          jit_movr(R1+argi,R0);
+          argdefs[argi].type = ARGT_STACK;
         }
+        jit_push(R0,R0);
+        //frame->sp++;
+        args_pushed++;
         
         if (argi>0) {
-          jit_pop(R1,R1+argi-1);
-          frame->sp-=(1+argi-1);
+          //jit_pop(R1,R1+argi-1);
+          //frame->sp-=(1+argi-1);
         }
       }
       else if (given_tag == TAG_SYM && sig_tag != TAG_SYM) {
@@ -490,12 +490,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       else if (compatible_type(given_tag, sig_tag) || sig_tag==TAG_ANY) {
         argdefs[argi].cell = arg;
         argdefs[argi].slot = argi-1;
-        argdefs[argi].type = ARGT_CELL;
+        argdefs[argi].type = ARGT_CONST;
 
         if (given_tag == TAG_SYM || given_tag == TAG_CONS || given_tag == TAG_INT || given_tag == TAG_STR || given_tag == TAG_BYTES) {
-          argdefs[argi].type = ARGT_CONST;
-          //printf("const arg of type %d at %p\n",arg->tag,arg);
+          //argdefs[argi].type = ARGT_CONST;
         }
+        //printf("const arg of type %d at %p\n",arg->tag,arg);
       } else {
         // check if we can typecast
         // else, fail with type error
@@ -518,6 +518,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
     argi++;
   } while (argi<MAXARGS && (args = cdr(args)) && (!signature_args || (signature_args = cdr(signature_args))));
 
+  // args are prepared, execute op
+
   if (op->tag == TAG_BUILTIN) {
     switch (op->ar.value) {
     case BUILTIN_BITAND: {
@@ -708,7 +710,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
 
       // el cheapo type inference
       if (1 &&
-          (argdefs[1].type == ARGT_INT ||
+          (argdefs[1].type == ARGT_REG_INT ||
            argdefs[1].type == ARGT_STACK_INT ||
            (argdefs[1].type == ARGT_CONST && argdefs[1].cell->tag == TAG_INT) ||
            (fidx>=0 && fn_frame[fidx].type == ARGT_STACK_INT) // already defined as int TODO: error on attempted type change
@@ -739,13 +741,13 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
         } else {
           fn_frame[offset].type = ARGT_STACK;
         }
-        fn_frame[offset].slot = frame->locals;
+        fn_frame[offset].slot = -frame->locals;
         //printf("++ frame entry %s, new stack-local idx %d, is_int %d\n",fn_frame[offset].name,fn_frame[offset].slot,is_int);
         frame->locals++;
       }
 
       if (!is_reg) {
-        jit_str_stack(R0,PTRSZ*(fn_frame[offset].slot+frame->sp));
+        jit_str_stack(R0,PTRSZ*(frame->sp-fn_frame[offset].slot));
       }
       
       if (compiled_type == TAG_INT && return_type == TAG_ANY) {
@@ -755,8 +757,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       }
 
       if (is_reg) {
-        jit_movr(LBDREG + fn_frame[offset].slot, R0);
-        printf("let %s to reg: %d\r\n",fn_frame[offset].name, LBDREG + fn_frame[offset].slot);
+        jit_movr(fn_frame[offset].slot, R0);
+        printf("let %s to reg: %d\r\n",fn_frame[offset].name, fn_frame[offset].slot);
       }
       
       break;
@@ -801,12 +803,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
 
         if (j>=ARG_SPILLOVER) { // max args passed in registers
           fn_new_frame[j].type = ARGT_STACK;
-          fn_new_frame[j].slot = num_lets + j - 1;
+          fn_new_frame[j].slot = -num_lets - j + 1;
           spo_count++;
         }
         else {
           fn_new_frame[j].type = ARGT_REG;
-          fn_new_frame[j].slot = j;
+          fn_new_frame[j].slot = j + LBDREG;
         }
         fn_new_frame[j].name = argdefs[j].cell->ar.addr;
         fn_argc++;
@@ -880,10 +882,11 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_cmpi(R0,0);
       jit_je(label_skip);
 
+      // then
       tag = compile_expr(argdefs[1].cell, frame, return_type);
       if (!tag) return 0;
 
-      // else?
+      // else
       if (argdefs[2].cell) {
         char label_end[64];
         sprintf(label_end,"Lendif_%d",++label_skip_count);
@@ -1295,24 +1298,24 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
 
     int pushed = push_frame_regs(frame->f);
     frame->sp+=pushed;
-
+    
     for (j=argi-2; j>=0; j--) {
       if (j>=ARG_SPILLOVER) {
         // pass arg on stack
-          
+
         load_cell(R0, argdefs[j], frame);
         jit_push(R0,R0);
         spo_adjust++;
-
         frame->sp++;
       } else {
         // pass arg in reg (LBDREG + slot)
         
         if (argdefs[j].type == ARGT_REG) {
-          if (argdefs[j].slot<j) {
+          if (1 || argdefs[j].slot<j+LBDREG) {
+            int offset = ((pushed+spo_adjust) - (argdefs[j].slot-LBDREG) - 1);
             // register already clobbered, load from stack
-            printf("-- loading clobbered reg %d from stack to reg %d\n",argdefs[j].slot,LBDREG+j);
-            jit_ldr_stack(LBDREG+j, (pushed-1-argdefs[j].slot)*PTRSZ);
+            //printf("-- loading clobbered reg %d from stack offset %d to reg %d\n",argdefs[j].slot,offset,LBDREG+j);
+            jit_ldr_stack(LBDREG+j, offset*PTRSZ);
           } else {
             // no need to move a reg into itself
             if (argdefs[j].slot!=j) {
@@ -1345,7 +1348,7 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
 #endif
 
   // at this point, registers R1-R6 are filled, execute
-  return compiled_type;
+  return clean_return(args_pushed, frame, compiled_type);
 }
 
 env_t* get_global_env() {

sledge/compiler_new.h

@@ -10,11 +10,10 @@ typedef void* (*funcptr)();
 
 typedef enum arg_t {
   ARGT_CONST,
-  ARGT_CELL,
   ARGT_ENV,
   ARGT_LAMBDA,
   ARGT_REG,
-  ARGT_INT,
+  ARGT_REG_INT,
   ARGT_STACK,
   ARGT_STACK_INT
 } arg_t;

sledge/jit_m68k.c

@@ -434,6 +434,12 @@ void jit_je(char* label) {
   jit_emit_branch(label);
 }
 
+void jit_jne(char* label) {
+  code[code_idx++] = 0x66; // bne
+  code[code_idx++] = 0x00;
+  jit_emit_branch(label);
+}
+
 void jit_jneg(char* label) {
   code[code_idx++] = 0x6b; // bmi
   code[code_idx++] = 0x00;

sledge/jit_x64.c

@@ -263,7 +263,6 @@ void debug_handler(char* line, Frame* frame) {
         if (a.type) {
           switch (a.type) {
           case ARGT_CONST: typestr = "CONST"; break;
-          case ARGT_CELL: typestr = "CELL"; break;
           case ARGT_ENV: typestr = "ENV"; break;
           case ARGT_LAMBDA: typestr = "LAMBDA"; break;
           case ARGT_REG: {
@@ -272,7 +271,7 @@ void debug_handler(char* line, Frame* frame) {
             typestr = buf;
             break;
           }
-          case ARGT_INT: typestr = "INT"; break;
+          case ARGT_REG_INT: typestr = "INT"; break;
           case ARGT_STACK: typestr = "STACK"; break;
           case ARGT_STACK_INT: typestr = "STACK_INT"; break;
           }

sledge/os/lib.l

@@ -25,6 +25,7 @@
 )))
 
 (def split (fn str sepstr (do
+  (print (list "split" str sepstr))
   (let sep (get sepstr 0))
   (let result (quote ()))
   (let sz (size str))
@@ -51,10 +52,11 @@
   (let i 0)
   (let c 0)
 
-  ;(print (list "copy: " buf from to num))
+  (print (list "copy: " buf from to num))
   
   (if (lt from to)
-    (do 
+    (do
+      (print "mode1")
       (let i (- num 1)) 
       (while (gt i -1) (do
         (let c (get buf (+ from i)))
@@ -62,6 +64,7 @@
         (let i (- i 1))
       )) 0)
     (do
+      (print "mode2")
       (let i 0)
       (while (lt i num) (do
         (let c (get buf (+ from i)))
@@ -78,7 +81,9 @@
   (let p (+ pos 0))
   (let from (+ pos 1))
   (let num (- (size buf) pos))
+  (print (list "remove" buf pos p from (- num 1)))
   (copy buf from p num)
+  (print "copied")
   (put buf (- (size buf) 1) 0)
   buf
 )))
@@ -97,7 +102,7 @@
   (let i 0)
   (let sz (size s))
   (let c (get s 0))
-  (while (* (gt c 0) (lt i sz)) (do
+  (while (and (gt c 0) (lt i sz)) (do
     (let i (+ i 1))
     (let c (get s i))
   ))

sledge/tests/tests.l

@@ -27,19 +27,13 @@
 (test 13 (= 3 (size (do 1 2 "foo"))))
 
 (def fib (fn n 0))
-(def fib (fn n (if (lt n 3) 1
-                 (+ (fib (- n 1)) (fib (- n 2))) )))
+(def fib (fn n (if (lt n 3) 1 (+ (fib (- n 1)) (fib (- n 2))) )))
 
 (test 14 (= (fib 10) 55))
 
 (def foo (fn a b (+ a b)))
 (test 15 (do (def a 5) (def b 6) (= (foo (+ a 1) (- b 2)) 10)))
 
-(def func-a (fn xx yy (* (+ xx 1) (+ yy 1))))
-(def func-b (fn x y (func-a x y)))
-
-(test 16 (= 12 (strlen (concat "hello" "worlden"))))
-
 (test 17 (= (get [65] 0) (get "beef" 1)))
 (test 18 (= (get [66] 0) (get "beef" 3)))
 
@@ -48,3 +42,55 @@
 (test 21 (eq 666 (* -1 -666)))
 
 (test 22 (= (get (substr "hellaz" 1 3) 0) 101))
+
+(def fun1 (fn a b c (list a b c)))
+(def fun2 (fn a b c (fun1 c a b)))
+
+(print (fun2 2 3 1))
+
+(test 23 (= 5 (+ (+ (+ 1 1) 1) (+ 1 1))))
+(test 24 (= 4 (+ (+ 1 1) (+ 1 1))))
+(test 25 (= 3 (+ (+ 1 1) 1)))
+
+(def func-a (fn xx yy (* (+ xx 1) (+ yy 1))))
+(def func-b (fn x y (func-a x y)))
+(test 26 (= (func-b 5 5) 36))
+
+(test 16 (= 12 (strlen (concat "hello" "worlden"))))
+
+(def lett (fn g (do
+  (let a 23)
+  (let b 46)
+  (let c 66)
+  (let d 72)
+  (let e "foo")
+  (list g a b c d e g)
+)))
+
+(print (lett 6))
+
+(def spillover (fn a b c d e f (do
+  (print (list a b c d e f))
+  (print (list f e d c b a))
+)))
+(spillover 1 2 3 4 5 6)
+
+(def fa (fn x y z w (do
+  (let a 8)
+  (let b 9)
+  (print a)
+  (print b)
+  (print x)
+  (print y)
+  (print z)
+  
+  (print (list "fa: " a b x y z w))
+)))
+
+(def fb (fn a b (do
+  (print a)
+  (print b)
+  (fa a b "3" "4")
+)))
+
+(fb 1 2)

sledge/writer.c

@@ -75,10 +75,10 @@ char* write_(Cell* cell, char* buffer, int in_list, int bufsize) {
   } else if (cell->tag == TAG_LAMBDA) {
     char tmp_args[TMP_BUF_SIZE];
     char tmp_body[TMP_BUF_SIZE*2];
-    tmp_args[0]=0;
-    tmp_body[0]=0;
     Cell* args = car(cell->ar.addr);
     int ai = 0;
+    tmp_args[0]=0;
+    tmp_body[0]=0;
     while (args && car(car(args))) {
       ai += snprintf(tmp_args+ai, TMP_BUF_SIZE-ai, "%s ", (char*)(car(car(args)))->ar.addr);
       args = cdr(args);