From fd62415dee834b2aa96cf2bd3dd344ba961ce784 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Wed, 26 May 2010 21:38:57 -0500 Subject: [PATCH] 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 | 11 ++++++- doc/bytecode.txt | 36 +++++++++++---------- gc.c | 15 +++++---- interp.c | 4 ++- libcompiler/primitives.scm | 2 ++ libcompiler/simplifier.scm | 4 +-- libcompiler/writer.scm | 65 ++++++++++++++++++++++++-------------- src/lib/primitives.rls | 3 +- 8 files changed, 88 insertions(+), 52 deletions(-) diff --git a/compiler.scm b/compiler.scm index ce92a5a..268c320 100755 --- a/compiler.scm +++ b/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: diff --git a/doc/bytecode.txt b/doc/bytecode.txt index e2280c1..6084a14 100644 --- a/doc/bytecode.txt +++ b/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 - 09 (set! out (fixnum? in)) ; value => bool - 0a (set! out (box? in)) ; value => bool - 0b (set! out (pair? in)) ; value => bool - 0c (set! out (vector? in)) ; value => bool - 0d (set! out (byte-string? in)) ; value => bool - 0e (set! out (struct? in)) ; value => bool - 0f (set! out (float? in)) ; value => bool - 10 (set! out (builtin? in)) ; value => bool + 08 (set! out (boolean? in)) ; value => bool + 09 (set! out (fixnum? in)) ; value => bool + 0a (set! out (box? in)) ; value => bool + 0b (set! out (pair? in)) ; value => bool + 0c (set! out (vector? in)) ; value => bool + 0d (set! out (byte-string? in)) ; value => bool + 0e (set! out (struct? in)) ; value => bool + 0f (set! out (float? 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 - 19 (set! out (make-struct in)) ; metastruct => struct - 1a (set! out (make-float in)) ; fixnum => float - 1b (set! out (lambda in)) ; template-or-lambda => lambda + 18 (set! out (make-box in)) ; value => box + 19 (set! out (make-struct in)) ; metastruct => struct + 1a (set! out (make-float in)) ; fixnum => float + 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 - 21 (set! out (bit-not in)) ; one's complement / bitwise negation - 22 (set! out (fix- in)) ; two's complement / arithmetic negation - 23 (set! out (float- in)) ; floating-point negation + 20 (set! out (not in)) ; if in == #f then #t else #f + 21 (set! out (bit-not in)) ; one's complement / bitwise negation + 22 (set! out (fix- in)) ; two's complement / arithmetic negation + 23 (set! out (float- in)) ; floating-point negation 28 (set! out (vector-size in)) 29 (set! out (byte-string-size in)) diff --git a/gc.c b/gc.c index 90dbe0b..55534ec 100644 --- a/gc.c +++ b/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. */ - assert(is_weak_box(*wb)); - *wb = _get_weak_box(*wb)->next; + /* Box is no longer reachable; remove it from the list by updating *wb. */ + *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 */ - assert(is_weak_box(*wb)); - wb = &_get_weak_box(*wb)->next; + /* Move on to next box */ + wb = &get_weak_box(*wb)->next; } } } diff --git a/interp.c b/interp.c index 953001a..38fea4d 100644 --- a/interp.c +++ b/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)); diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index 8bef366..70510aa 100644 --- a/libcompiler/primitives.scm +++ b/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-) diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index df08033..8d37c82 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -153,8 +153,8 @@ ,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp)))) (reverse simple-vals)) ,tmp))] - [(or `(#%apply _ _) - `(#%call/cc _)) + [(or `(#%apply . ,_) + `(#%call/cc . ,_)) `(#%value-list ,values-form)] [(? value-form?) (simplify-value-list `(value-list (values ,values-form)))] diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index e3459bb..aac3781 100644 --- a/libcompiler/writer.scm +++ b/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) - (new-line port) (write-hex-byte (variable->code (third tc-form)) port) - (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 (second tc-form)) port) + (req-new-line port) (write-hex-byte (variable->code (third tc-form)) port) + (req-new-line port) (write-hex-byte (variable->code (fourth 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) - (write (car forms) port) + (if (verbose-rla?) + (begin + (write-string "\"; " port) + (write (car forms) port)) + (write-char #\" port)) (write-tail-call (second forms))) (begin - (write-string "\\; " port) - (write (car forms) port) - (new-line port) - (write-char #\Space port) + (when (verbose-rla?) + (write-string "\\; " port) + (write (car forms) 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))]) - (new-line port) + (opt-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))]) - (new-line port) + (opt-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)]) diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index bfd8bb3..4f451b6 100644 --- a/src/lib/primitives.rls +++ b/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))