Fix pattern-matching for (value-list (#%apply ...)), etc.

Fix assertion in gc_object_left_behind() to work in Gen-0 collection.
Add (weak-box?) and (make-weak-box) primitives. (unbox) now works for both.
Add option to just simplify the input (stops before reduce-function).
Default to writing .rla without indentation, comments, or newlines.

compiler.scm

@@ -7,10 +7,12 @@
 
 (require (file "libcompiler/reader.scm"))
 (require (file "libcompiler/compiler.scm"))
+(require (file "libcompiler/simplifier.scm"))
 (require (file "libcompiler/writer.scm"))
 
 ;(require profile)
 ;(profile (begin
+(define reduce-code? (make-parameter #t))
 (define map-bytecode? (make-parameter #t))
 
 (define source-file
@@ -18,8 +20,13 @@
     #:once-each
     [("-O") ol "Set the optimization level"
                (optimize? (>= (string->number ol) 1))]
+    [("-S" "--simplify-only") "Stop before reducing code to lowest terms"
+                              (map-bytecode? #f)
+                              (reduce-code? #f)]
     [("-R" "--reduce-only") "Stop before mapping forms to VM bytecode"
                             (map-bytecode? #f)]
+    [("-v" "--verbose") "Output verbose intermediate (.rla) representation"
+                        (verbose-rla? #t)]
     #:args source-file
     (if (null? source-file)
         "-"
@@ -39,7 +46,9 @@
     (begin
       (write-rla-value (compile-function source-module))
       (write-char #\Newline))
-    (pretty-print (reduce-function source-module)))
+    (if (reduce-code?)
+      (pretty-print (reduce-function source-module))
+      (pretty-print (simplify-lambda source-module))))
 ;) #:delay 0.002)
 
 ; vim:set sw=2 expandtab:

doc/bytecode.txt

@@ -13,25 +13,27 @@ unary-expr: up to 255, 1 out, 1 in
   03 (set! out (car   in))
   04 (set! out (cdr   in))
 
-  08 (set! out (boolean?     in))  ; value => bool
+  08 (set! out (boolean?      in))  ; value => bool
-  09 (set! out (fixnum?      in))  ; value => bool
+  09 (set! out (fixnum?       in))  ; value => bool
-  0a (set! out (box?         in))  ; value => bool
+  0a (set! out (box?          in))  ; value => bool
-  0b (set! out (pair?        in))  ; value => bool
+  0b (set! out (pair?         in))  ; value => bool
-  0c (set! out (vector?      in))  ; value => bool
+  0c (set! out (vector?       in))  ; value => bool
-  0d (set! out (byte-string? in))  ; value => bool
+  0d (set! out (byte-string?  in))  ; value => bool
-  0e (set! out (struct?      in))  ; value => bool
+  0e (set! out (struct?       in))  ; value => bool
-  0f (set! out (float?       in))  ; value => bool
+  0f (set! out (float?        in))  ; value => bool
-  10 (set! out (builtin?     in))  ; value => bool
+  10 (set! out (builtin?      in))  ; value => bool
+  11 (set! out (weak-box?     in))  ; value => bool
 
-  18 (set! out (make-box     in))  ; value => box
+  18 (set! out (make-box      in))  ; value => box
-  19 (set! out (make-struct  in))  ; metastruct => struct
+  19 (set! out (make-struct   in))  ; metastruct => struct
-  1a (set! out (make-float   in))  ; fixnum => float
+  1a (set! out (make-float    in))  ; fixnum => float
-  1b (set! out (lambda       in))  ; template-or-lambda => lambda
+  1b (set! out (make-lambda   in))  ; template-or-lambda => lambda
+  1c (set! out (make-weak-box in))  ; value => weak-box
 
-  20 (set! out (not          in))  ; if in == #f then #t else #f
+  20 (set! out (not           in))  ; if in == #f then #t else #f
-  21 (set! out (bit-not      in))  ; one's complement / bitwise negation
+  21 (set! out (bit-not       in))  ; one's complement / bitwise negation
-  22 (set! out (fix-         in))  ; two's complement / arithmetic negation
+  22 (set! out (fix-          in))  ; two's complement / arithmetic negation
-  23 (set! out (float-       in))  ; floating-point negation
+  23 (set! out (float-        in))  ; floating-point negation
 
   28 (set! out (vector-size      in))
   29 (set! out (byte-string-size in))

gc.c

@@ -643,6 +643,7 @@ static void collect_gen0_garbage(void)
       while (object_ptr < gc_gen1_free_ptr)
       {
         object_ptr += gc_align(transfer_children((object_t*)object_ptr));
+        assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range);
       }
 
       /* These have to be examined after normal reachability has been determined */
@@ -659,6 +660,7 @@ static void collect_gen0_garbage(void)
       while (object_ptr < gc_gen1_free_ptr)
       {
         object_ptr += gc_align(transfer_children((object_t*)object_ptr));
+        assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range);
       }
 
       update_weak_box_list();
@@ -759,6 +761,7 @@ static inline bool gc_object_left_behind(value_t v)
   /* Must provide a reference to the original location, not the new one (if moved). */
   assert(!is_object(v) ||
          is_gen0_object(v) ||
+         gc_in_gen0_collection ||
          (gc_gen1_range_of(_get_object(v)) != gc_gen1_current_range));
 
   return is_object(v) &&
@@ -1102,21 +1105,19 @@ static void update_weak_box_list(void)
   {
     if (gc_object_left_behind(*wb))
     {
-      /* Box is no longer reachable; remove it from the list by updating 'next' pointer. */
+      /* Box is no longer reachable; remove it from the list by updating *wb. */
-      assert(is_weak_box(*wb));
+      *wb = get_weak_box(*wb)->next;
-      *wb = _get_weak_box(*wb)->next;
     }
     else
     {
-      /* The box itself is reachable; need to update 'next' pointer to new location */
+      /* The box itself is reachable; may need to update *wb to new location */
       if (gc_object_has_moved(*wb))
       {
         *wb = _get_object(*wb)->forward;
       }
 
-      /* Move on to next box's 'next' pointer */
+      /* Move on to next box */
-      assert(is_weak_box(*wb));
+      wb = &get_weak_box(*wb)->next;
-      wb = &_get_weak_box(*wb)->next;
     }
   }
 }

interp.c

@@ -394,7 +394,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uin
   switch (subcode)
   {
   case 0x01: return ST1;
-  case 0x02: return get_box(ST1)->value;
+  case 0x02: return is_weak_box(ST1) ? _get_weak_box(ST1)->value : get_box(ST1)->value;
   case 0x03: return get_pair(ST1)->car;
   case 0x04: return get_pair(ST1)->cdr;
   case 0x08: return boolean_value(is_boolean(ST1));
@@ -406,6 +406,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uin
   case 0x0e: return boolean_value(is_struct(ST1));
   case 0x0f: return boolean_value(is_float(ST1));
   case 0x10: return boolean_value(is_builtin_fn(ST1));
+  case 0x11: return boolean_value(is_weak_box(ST1));
   case 0x18: return make_box(ST1);
   case 0x19: {
                fixnum_t nslots;
@@ -415,6 +416,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uin
              }
   case 0x1a: return make_float((native_float_t)get_fixnum(ST1));
   case 0x1b: return make_lambda(state, ST1);
+  case 0x1c: return make_weak_box(ST1);
   case 0x20: return boolean_value(!_get_boolean(ST1));
   case 0x21: return fixnum_value(~get_fixnum(ST1));
   case 0x22: return fixnum_value(-get_fixnum(ST1));

libcompiler/primitives.scm

@@ -32,10 +32,12 @@
     (#%struct?          #x0e struct?)
     (#%float?           #x0f float?)
     (#%builtin?         #x10 builtin?)
+    (#%weak-box?        #x11 weak-box?)
     (#%make-box         #x18 make-box)
     (#%make-struct      #x19 make-struct)
     (#%make-float       #x1a make-float)
     (#%make-lambda      #x1b make-lambda)
+    (#%make-weak-box    #x1c make-weak-box)
     (#%not              #x20 not)
     (#%bit-not          #x21 bit-not)
     (#%fix-             #x22 fix-)

libcompiler/simplifier.scm

@@ -153,8 +153,8 @@
             ,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp))))
                    (reverse simple-vals))
             ,tmp))]
-      [(or `(#%apply _ _)
+      [(or `(#%apply . ,_)
-           `(#%call/cc _))
+           `(#%call/cc . ,_))
        `(#%value-list ,values-form)]
       [(? value-form?)
        (simplify-value-list `(value-list (values ,values-form)))]

libcompiler/writer.scm

@@ -6,18 +6,29 @@
 
 (provide write-rla-value
          current-indent
-         current-indent-step)
+         current-indent-step
+         verbose-rla?)
 
 (define current-indent (make-parameter 0))
 (define current-indent-step (make-parameter 2))
+(define verbose-rla? (make-parameter #f))
 
 (define hex-digits "0123456789abcdef")
 
-(define (new-line port)
+(define (hard-new-line port)
   (write-char #\Newline port)
   (for ([i (in-range 0 (current-indent))])
     (write-char #\Space port)))
 
+(define (req-new-line port)
+  (if (verbose-rla?)
+      (hard-new-line port)
+      (write-char #\Space port)))
+
+(define (opt-new-line port)
+  (when (verbose-rla?)
+    (hard-new-line port)))
+
 (define (write-hex-char ord port)
   (write-string "\\x" port)
   (write-char (string-ref hex-digits (quotient  ord 16)) port)
@@ -48,10 +59,10 @@
 
 (define (write-rla-bytecode+tail-call forms port)
   (define (write-tail-call tc-form)
-    (new-line port) (write-hex-byte (variable->code (second tc-form)) port)
+    (req-new-line port) (write-hex-byte (variable->code (second tc-form)) port)
-    (new-line port) (write-hex-byte (variable->code (third  tc-form)) port)
+    (req-new-line port) (write-hex-byte (variable->code (third  tc-form)) port)
-    (new-line port) (write-hex-byte (variable->code (fourth tc-form)) port)
+    (req-new-line port) (write-hex-byte (variable->code (fourth tc-form)) port)
-    (new-line port) (write-hex-byte (variable->code (fifth  tc-form)) port))
+    (req-new-line port) (write-hex-byte (variable->code (fifth  tc-form)) port))
   (let-values ([(line col pos) (port-next-location port)])
     (parameterize ([current-indent col])
       (write-char #\" port)
@@ -64,14 +75,18 @@
                  (statement->code (car forms)))
             (if (eq? (first (second forms)) '#%tail-call)
                 (begin
-                  (write-string "\"; " port)
+                  (if (verbose-rla?)
-                  (write (car forms) port)
+                      (begin
+                        (write-string "\"; " port)
+                        (write (car forms) port))
+                      (write-char #\" port))
                   (write-tail-call (second forms)))
                 (begin
-                  (write-string "\\; " port)
+                  (when (verbose-rla?)
-                  (write (car forms) port)
+                    (write-string "\\; " port)
-                  (new-line port)
+                    (write (car forms) port)
-                  (write-char #\Space port)
+                    (hard-new-line port)
+                    (write-char #\Space port))
                   (iter (cdr forms)))))))))
 
 (define (write-rla-function value port)
@@ -83,32 +98,36 @@
           (write-string "#=\"template\"" port)
           (write-string "#=\"lambda\"" port))
       (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-        (new-line port)
+        (req-new-line port)
         (write-string "#(" port)
         (unless (null? (second value))
           (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-            (for ([global (in-list (second value))])
+            (opt-new-line port)
-              (new-line port)
+            (write-rla-value (first (second value)) port)
+            (for ([global (in-list (cdr (second value)))])
+              (req-new-line port)
               (write-rla-value global port)))
-          (new-line port))
+          (opt-new-line port))
         (write-string ")" port)
-        (new-line port)
+        (req-new-line port)
         (if template?
             (write-instance-string (third value) port)
             (begin
               (write-string "#(" port)
               (unless (null? (third value))
                 (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-                  (for ([instance (in-list (third value))])
+                  (opt-new-line port)
-                    (new-line port)
+                  (write-rla-value (first (third value)) port)
+                  (for ([instance (in-list (cdr (third value)))])
+                    (req-new-line port)
                     (write-rla-value instance port)))
-                (new-line port))
+                (opt-new-line port))
               (write-string ")" port)))
-        (new-line port)
+        (req-new-line port)
         (write-rla-value (length (second (fourth value))) port)
-        (new-line port)
+        (req-new-line port)
         (write-rla-bytecode+tail-call (cddr (fourth value)) port))
-      (new-line port))
+      (opt-new-line port))
     (write-string ")" port)))
 
 (define (write-rla-value value [port (current-output-port)])

src/lib/primitives.rls

@@ -13,10 +13,11 @@
 (define (struct? x) (struct? x))
 (define (float? x) (float? x))
 (define (builtin? x) (builtin? x))
+(define (weak-box? x) (weak-box? x))
 (define (make-box x) (make-box x))
 (define (make-struct x) (make-struct x))
 (define (make-float x) (make-float x))
-(define (make-lambda x) (make-lambda x))
+(define (make-weak-box x) (make-weak-box x))
 (define (not x) (not x))
 (define (bit-not x) (bit-not x))
 (define (fix- x) (fix- x))