working stack-passed args impl; working gtn

devices/sdl2.c

@@ -9,7 +9,7 @@
 #define HEIGHT 1080
 #define BPP 2
 #define DEPTH 16
-#define SCALE 1
+#define SCALE 2
 
 SDL_Surface* win_surf;
 SDL_Surface* pixels_surf;

sledge/alloc.c

@@ -127,7 +127,7 @@ void mark_tree(Cell* c) {
     }
     else if (c->tag & TAG_STREAM) {
       Stream* s = (Stream*)c->addr;
-      mark_tree(s->path);
+      //mark_tree(s->path);
     }
     else if (c->tag & TAG_FS) {
       Filesystem* fs = (Filesystem*)c->next;
@@ -170,11 +170,11 @@ Cell* collect_garbage(env_t* global_env, void* stack_end, void* stack_pointer) {
 
   // (def foo (fn (do (let a 1) (let b 2) (+ a b) (gc))))
 
-  printf("[gc] stack at: %p, stack end: %p\r\n",stack_pointer,stack_end);
+  //printf("[gc] stack at: %p, stack end: %p\r\n",stack_pointer,stack_end);
 
   // FIXME: how low can we safely go?
   int sw_state = 0;
-  for (jit_word_t* a=(jit_word_t*)stack_end; a>(jit_word_t*)stack_pointer+1; a--) {
+  for (jit_word_t* a=(jit_word_t*)stack_end; a>=(jit_word_t*)stack_pointer; a--) {
     jit_word_t item = *a;
     jit_word_t next_item = *(a-1);
     if (next_item&STACK_FRAME_MARKER) {
@@ -186,12 +186,13 @@ Cell* collect_garbage(env_t* global_env, void* stack_end, void* stack_pointer) {
         // FIXME total hack, need type information for stack
         // maybe type/signature byte frame header?
         if ((Cell*)item>cell_heap) {
+          printf("[gc] stack %p\r\n",item);
           mark_tree((Cell*)item);
         }
       }
     }
 
-    if (sw_state==2) {
+    /*if (sw_state==2) {
       printf(KMAG "%p: 0x%08lx\r\n" KWHT,a,item);
     }
     else if (sw_state==1) {
@@ -199,9 +200,9 @@ Cell* collect_garbage(env_t* global_env, void* stack_end, void* stack_pointer) {
     }
     else {
       printf(KWHT "%p: 0x%08lx\r\n" KWHT,a,item);
-    }
+    }*/
   }
-  printf("[gc] stack walk complete -------------------------------\r\n");
+  //printf("[gc] stack walk complete -------------------------------\r\n");
 
   sm_enum(global_env, collect_garbage_iter, NULL);
   mark_tree(get_fs_list());

sledge/alloc.h

@@ -9,7 +9,7 @@
 #define env_t StrMap
 
 // functions store a pointer to their own definition ORed with this marker on the stack
-#define STACK_FRAME_MARKER 0x1
+#define STACK_FRAME_MARKER 0xf000000000000001
 
 enum cell_allocator_t {
   CA_STACK,

sledge/compiler_new.c

@@ -9,7 +9,7 @@
 #define env_t StrMap
 static env_t* global_env = NULL;
 
-//#define CHECK_BOUNDS
+#define CHECK_BOUNDS
 
 env_entry* lookup_global_symbol(char* name) {
   env_entry* res;
@@ -251,7 +251,7 @@ int analyze_fn(Cell* expr, Cell* parent, int num_lets) {
   return num_lets;
 }
 
-static int debug_mode = 1;
+static int debug_mode = 0;
 
 int compile_expr(Cell* expr, Frame* frame, int return_type) {
   if (!expr) return 0;
@@ -482,80 +482,80 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_andr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_BITOR: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_orr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_BITXOR: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_xorr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_SHL: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_shlr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_SHR: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_shrr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_ADD: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_addr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_SUB: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_subr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_MUL: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_mulr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_DIV: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_divr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_MOD: {
       load_int(ARGR0,argdefs[0], frame);
       load_int(R2,argdefs[1], frame);
       jit_modr(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_GT: {
@@ -565,8 +565,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_movi(ARGR0,0);
       jit_movi(R2,1);
       jit_movneg(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_LT: {
@@ -576,8 +576,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_movi(ARGR0,0);
       jit_movi(R2,1);
       jit_movneg(ARGR0,R2);
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int, "alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_DEF: {
@@ -632,6 +632,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       
       jit_str_stack(R0,PTRSZ*(fn_frame[offset].slot+frame->sp));
       
+      if (compiled_type == TAG_INT && return_type == TAG_ANY) {
+        jit_movr(ARGR0,R0);
+        jit_call(alloc_int, "alloc_int");
+        compiled_type = TAG_ANY;
+      }
+      
       break;
     }
     case BUILTIN_FN: {
@@ -640,6 +646,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
         return 0;
       }
       
+      // body
+      Cell* fn_body = argdefs[argi-2].cell;
+
+      // estimate stack space for locals
+      int num_lets = analyze_fn(fn_body,NULL,0);
+      
       // scan args (build signature)
       Cell* fn_args = alloc_nil();
       Arg fn_new_frame[MAXFRAME];
@@ -650,13 +662,23 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
         fn_new_frame[i].name = NULL;
       }
 
+      int spillover = 1;
+      int spo_count = 0;
+
       int fn_argc = 0;
       for (int j=argi-3; j>=0; j--) {
         Cell* arg = alloc_cons(alloc_sym(argdefs[j].cell->addr),alloc_int(TAG_ANY));
         fn_args = alloc_cons(arg,fn_args);
-        
-        fn_new_frame[j].type = ARGT_REG;
-        fn_new_frame[j].slot = j;
+
+        if (spillover) {
+          fn_new_frame[j].type = ARGT_STACK;
+          fn_new_frame[j].slot = num_lets + 2 + ((argi-3)-j);
+          spo_count++;
+        }
+        else {
+          fn_new_frame[j].type = ARGT_REG;
+          fn_new_frame[j].slot = j;
+        }
         fn_new_frame[j].name = argdefs[j].cell->addr;
         fn_argc++;
 
@@ -666,8 +688,6 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       //lisp_write(fn_args, sig_debug, sizeof(sig_debug));
       //printf("signature: %s\n",sig_debug);
 
-      // body
-      Cell* fn_body = argdefs[argi-2].cell;
 
       //lisp_write(fn_body, sig_debug, sizeof(sig_debug));
       
@@ -683,8 +703,6 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_label(label_fn);
       jit_movi(R2,(jit_word_t)lambda|STACK_FRAME_MARKER);
       jit_push(R2,R2);
-
-      int num_lets = analyze_fn(fn_body,NULL,0);
       
       jit_dec_stack(num_lets*PTRSZ);
 
@@ -788,8 +806,16 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
     case BUILTIN_DO: {
       args = orig_args;
       Cell* arg;
+      
       while ((arg = car(args))) {
-        int tag = compile_expr(arg, frame, return_type);
+        int tag;
+        if (car(cdr(args))) {
+          // discard all returns except for the last one
+          tag = compile_expr(arg, frame, TAG_VOID);
+        } else {
+          tag = compile_expr(arg, frame, return_type);
+        }
+        
         if (!tag) return 0;
         args = cdr(args);
       }
@@ -926,8 +952,8 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       
       jit_movr(ARGR0, R3);
       
-      if (return_type == TAG_INT) return TAG_INT;
-      jit_call(alloc_int,"alloc_int");
+      if (return_type == TAG_ANY) jit_call(alloc_int, "alloc_int");
+      else compiled_type = TAG_INT;
       break;
     }
     case BUILTIN_PUT: {
@@ -1040,7 +1066,12 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       load_cell(ARGR0,argdefs[0], frame);
       jit_addi(ARGR0,PTRSZ); // fetch size -> R0
       jit_ldr(ARGR0);
-      jit_call(alloc_int,"alloc_int");
+      if (return_type == TAG_ANY) {
+        jit_call(alloc_int, "alloc_int");
+      } else if (return_type == TAG_INT) {
+        jit_movr(R0,ARGR0);
+        compiled_type = TAG_INT;
+      }
       
       break;
     }
@@ -1127,29 +1158,49 @@ int compile_expr(Cell* expr, Frame* frame, int return_type) {
       jit_push(LBDREG, LBDREG+argi-2);
       frame->sp+=(1+argi-2);
     }*/
+
+    int spillover = 1;
+    int spo_adjust = 0;
     
     for (int j=0; j<argi-1; j++) {
-      if (argdefs[j].type == ARGT_REG) {
-        if (argdefs[j].slot<j) {
-          // 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);
-        } else {
-          // no need to move a reg into itself
-          if (argdefs[j].slot!=j) {
-            load_cell(LBDREG+j, argdefs[j], frame);
+      if (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) {
+            // 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);
+          } else {
+            // no need to move a reg into itself
+            if (argdefs[j].slot!=j) {
+              load_cell(LBDREG+j, argdefs[j], frame);
+            }
           }
         }
-      }
-      else {
-        load_cell(LBDREG+j, argdefs[j], frame);
+        else {
+          load_cell(LBDREG+j, argdefs[j], frame);
+        }
       }
     }
+    
     jit_lea(R0,op_env);
     jit_ldr(R0); // load cell
     jit_addi(R0,PTRSZ); // &cell->next
     jit_ldr(R0); // cell->next
     jit_callr(R0);
+    if (spo_adjust) {
+      jit_inc_stack(spo_adjust*PTRSZ);
+      frame->sp-=spo_adjust;
+    }
 
     pop_frame_regs(frame->f);
     frame->sp-=pushed;

sledge/jit_x64.c

@@ -49,18 +49,22 @@ void jit_movi(int reg, uint64_t imm) {
 }
 
 void jit_movr(int dreg, int sreg) {
+  if (dreg == sreg) return;
   fprintf(jit_out, "movq %s, %s\n", regnames[sreg], regnames[dreg]);
 }
 
 void jit_movneg(int dreg, int sreg) {
+  if (dreg == sreg) return;
   fprintf(jit_out, "cmovs %s, %s\n", regnames[sreg], regnames[dreg]);
 }
 
 void jit_movne(int dreg, int sreg) {
+  if (dreg == sreg) return;
   fprintf(jit_out, "cmovne %s, %s\n", regnames[sreg], regnames[dreg]);
 }
 
 void jit_moveq(int dreg, int sreg) {
+  if (dreg == sreg) return;
   fprintf(jit_out, "cmoveq %s, %s\n", regnames[sreg], regnames[dreg]);
 }
 
@@ -227,7 +231,7 @@ void jit_pop(int r1, int r2) {
 void debug_handler(char* line, Frame* frame) {
   printf("@ %s\r\n",line);
   
-  if (frame) {
+  if (0 && frame) {
     if (frame->f) {
       for (int i=0; i<MAXFRAME; i++) {
         char* typestr = "UNKNOWN";

sledge/os/shell.l

@@ -527,6 +527,8 @@
 
 (def buffer-read (list))
 
+(def zz (fn (import "/sd/tests/gtn.l")))
+
 (def main (fn (do
   (let blink 0)
   (let running 1)

sledge/tests/fib.l

@@ -1,9 +1,15 @@
 (
 (def fib (fn on (do
   (let i 1)
+  (print i)
   (let j 1)
+  (print j)
   (let r 1)
+  (print r)
   (let n on)
+  (print on)
+  (print n)
+  (print (gt n 2))
 
   (while (gt n 2) (do
     (let r (+ i j))

sledge/tests/gtn.l

@@ -9,6 +9,7 @@
 (def solidmap (alloc (* screen-w screen-h)))
 
 (def fill (fn buf from to c (do
+  (print (list "fill" (size buf) from to c))
   (let i from)
   (while (lt i (+ to 1)) (do
     (put buf i c)
@@ -17,30 +18,35 @@
 )))
 
 (def buf-render (fn b bx by (do
-  (blit-str b bx by)
+  (let y 0)
+  (while (lt y screen-h) (do
+    (blit-str (substr b (* y screen-w) screen-w) bx (+ by (* y 16)))
+    (let y (+ y 1))
+  ))
+  0
 )))
 
 ; symbols ------------------------------------------------------
 
-(def sym-block 0x2b1b)
-(def sym-umbrella 0x2614)
-(def sym-coffee 0x2615)
-(def sym-scissors 0x2700)
-(def sym-zigzag 0x2307)
-(def sym-dog 0x2620)
-(def sym-pot 0x1013)
-(def sym-pill 0x1005)
-(def sym-egg 0x1810)
-(def sym-ear 0x1028)
-(def sym-rabbit 0x0c20)
-(def sym-table 0x213f)
-(def sym-salad 0x2e19)
-(def sym-hot 0x2668)
-(def sym-fish 0x1864)
-(def sym-disc 0x105c)
-(def sym-potb 0x1053)
-(def sym-person 0x3020)
-(def sym-blockb 0x2b12)
+(def sym-block (get "#" 0))
+(def sym-umbrella  (get "m" 0))
+(def sym-coffee  (get "c" 0))
+(def sym-scissors  (get "x" 0))
+(def sym-zigzag  (get "z" 0))
+(def sym-dog  (get "D" 0))
+(def sym-pot  (get "p" 0))
+(def sym-pill  (get "." 0))
+(def sym-egg  (get "o" 0))
+(def sym-ear  (get "e" 0))
+(def sym-rabbit  (get "R" 0))
+(def sym-table  (get "T" 0))
+(def sym-salad  (get "s" 0))
+(def sym-hot  (get "~" 0))
+(def sym-fish  (get "<" 0))
+(def sym-disc  (get "0" 0))
+(def sym-potb  (get "p" 0))
+(def sym-person  (get "@" 0))
+(def sym-blockb  (get "=" 0))
 
 ; structures -----------------------------------------------------------
 
@@ -48,12 +54,12 @@
 
 (def make-tile (fn rune color solid (cons rune (cons color (cons solid nil)))))
 
-(def tile-space (make-tile sym-block 0 0))
+(def tile-space (make-tile 32 0 0))
 (def tile-wall (make-tile sym-block 12 1))
-(def tile-asphalt (make-tile sym-block 11 0))
-(def tile-floor-yellow (make-tile sym-block 7 0))
-(def tile-floor-wood (make-tile sym-block 8 0))
-(def tile-floor-woodl (make-tile sym-block 9 0))
+(def tile-asphalt (make-tile (get "." 0) 11 0))
+(def tile-floor-yellow (make-tile (get "_" 0) 7 0))
+(def tile-floor-wood (make-tile (get "_" 0) 8 0))
+(def tile-floor-woodl (make-tile (get "_" 0) 9 0))
 (def tile-dog (make-tile sym-dog 1 0))
 (def tile-pot (make-tile sym-pot 1 0))
 (def tile-pill (make-tile sym-pill 1 0))
@@ -68,7 +74,7 @@
 ; coffee
 
 (def put-tile (fn x y tile (do
-  (put screen (+ x (* screen-w y))  (car tile))
+  (put screen   (+ x (* screen-w y))  (car tile))
   (put colormap (+ x (* screen-w y)) (car (cdr tile)))
   (put solidmap (+ x (* screen-w y)) (car (cdr (cdr tile))))
 )))
@@ -182,8 +188,8 @@
 )))
 
 (def handle-game-key (fn k (do
-  (if (eq k 19) (player-east)
-      (if (eq k 20) (player-west)
+  (if (eq k 20) (player-east)
+      (if (eq k 19) (player-west)
         (if (eq k 17) (player-north)
           (if (eq k 18) (player-south)
               
@@ -206,7 +212,7 @@
   (let aa (car ad))
   
   (while aa (do
-    (blit-char (actor-rune aa) (* 16 (actor-x aa)) (* 16 (actor-y aa)))
+    (blit-char (actor-rune aa) (* 8 (actor-x aa)) (* 16 (actor-y aa)))
     
     (let ad (cdr ad))
     (let aa (car ad))
@@ -219,8 +225,8 @@
 
   (if (eq state state-init) (do
     (fill colormap 0 (- screen-size 1) 0)
-    (fill screen 0 (* (- screen-size 1) 2) 32)
-    (fill screen 0 (- screen-size 1) sym-block)
+    (fill screen 0 (- screen-size 1) 32)
+    ;(fill screen 0 (- screen-size 1) sym-block)
 
     (fill-tile-rect 0 0 60 12 tile-asphalt)