nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Jesse D. McDonald 2010-05-26 21:38:57 -05:00
parent 9e4286b49e
commit fd62415dee
8 changed files with 88 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler.scm
View File

@ -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:

36
doc/bytecode.txt
View File

@ -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))

15
gc.c
View File

@ -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;
}
}
}

4
interp.c
View File

@ -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));

2
libcompiler/primitives.scm
View File

@ -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-)

4
libcompiler/simplifier.scm
View File

@ -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)))]

65
libcompiler/writer.scm
View File

@ -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)])

3
src/lib/primitives.rls
View File

@ -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))