From 29fe17779490d83cd666ff2218e3a528aae02450 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 7 Jul 2008 14:49:25 -0400 Subject: [PATCH] GC was changed to consider the new representation. The compiler still has to be changed. This is the last version for the old PIC, from now on, the code for picoboard-v2 will be merged. --- picobit-vm.c | 77 +- picobit.scm | 3962 ++++++++++++++-------------------------------------------- robot.scm | 1 + 3 files changed, 1008 insertions(+), 3032 deletions(-) rewrite picobit.scm (65%) diff --git a/picobit-vm.c b/picobit-vm.c index 4052f35..be97a8b 100644 --- a/picobit-vm.c +++ b/picobit-vm.c @@ -406,11 +406,14 @@ obj globals[GLOVARS]; // TODO changed, now gc bits are 0x60, were 0xc0, but the 1st is not always used #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60) +#define RAM_SET_GC_TAGS_MACRO(o,tags) \ + (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags))) #define RAM_SET_GC_TAG0_MACRO(o,tag) \ RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag)) #define RAM_SET_GC_TAG1_MACRO(o,tag) \ RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag)) // TODO we can't set them both at once now, since some objects only have 1 +// FOOBAR, maybe we can #if WORD_BITS == 8 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1)) @@ -456,9 +459,11 @@ obj globals[GLOVARS]; #endif uint8 ram_get_gc_tags (obj o) { return RAM_GET_GC_TAGS_MACRO(o); } +void ram_set_gc_tags (obj o, uint8 tags) { RAM_SET_GC_TAGS_MACRO(o, tags); } void ram_set_gc_tag0 (obj o, uint8 tag) { RAM_SET_GC_TAG0_MACRO(o,tag); } void ram_set_gc_tag1 (obj o, uint8 tag) { RAM_SET_GC_TAG1_MACRO(o,tag); } // TODO we can't set them both at once anymore, some object only use 1 +// FOOBAR actually, we might be able to, if we don't ever set or unset something used for the type uint8 ram_get_field0 (obj o) { return RAM_GET_FIELD0_MACRO(o); } word ram_get_field1 (obj o) { return RAM_GET_FIELD1_MACRO(o); } // TODO used to return obj, which used to be the same as words word ram_get_field2 (obj o) { return RAM_GET_FIELD2_MACRO(o); } @@ -506,16 +511,19 @@ void set_global (uint8 i, obj o) /* Interface to GC */ /* GC tags are in the top 2 bits of field 0 */ -// TODO change GC with new representation -#define GC_TAG_0_LEFT (3<<6) -#define GC_TAG_1_LEFT (2<<6) -#define GC_TAG_UNMARKED (0<<6) /* must be 0 */ +// TODO change GC with new representation FOOBAR +#define GC_TAG_0_LEFT (1<<5) +// TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other +#define GC_TAG_1_LEFT (2<<5) +#define GC_TAG_UNMARKED (0<<5) /* must be 0 */ // TODO FOOBAR is it ok ? eevn for bignums ? /* Number of object fields of objects in ram */ -// TODO change -#define HAS_2_OBJECT_FIELDS(field0) ((field0) == PAIR_FIELD0) -#define HAS_1_OBJECT_FIELD(field0) ((field0) >= PROCEDURE_FIELD0) -// procedures and continuations have both 1 pointer +#define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit)) +#define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) || RAM_PROCEDURE(visit)) +// TODO now we consider that all composites have at least 1 field, even symbols, as do procedures. no problem for symbols, since the car is always #f +// TODO was : (RAM_STRING(visit) || RAM_VECTOR(visit) || RAM_PROCEDURE(visit)) +// TODO no real way to tell using simple inequality +// TODO if we ever have true bignums, bignums will have 1 object field #define NIL OBJ_FALSE @@ -531,15 +539,14 @@ obj arg3; obj arg4; obj cont; obj env; -obj second_half; /* the second half of continuations */ -uint8 na; /* interpreter variables */ // TODO what's that ? +uint8 na; /* interpreter variables */ // TODO what's na ? rom_addr pc; rom_addr entry; uint8 bytecode; uint8 bytecode_hi4; uint8 bytecode_lo4; -uint8 field0; // TODO is it used anymore +obj second_half; /* the second half of continuations */ int32 a1; int32 a2; int32 a3; @@ -554,7 +561,7 @@ void init_ram_heap (void) while (o >= MIN_RAM_ENCODING) { ram_set_gc_tags (o, GC_TAG_UNMARKED); - ram_set_field1 (o, free_list); + ram_set_car (o, free_list); // TODO was field1 free_list = o; o--; } @@ -575,7 +582,7 @@ void mark (obj temp) { /* mark phase */ - obj stack; + obj stack; // TODO do we need a stack ? since we have 0-1-2 children, we could do deutsche schorr waite obj visit; if (IN_RAM(temp)) @@ -621,26 +628,26 @@ void mark (obj temp) */ // TODO since no-one has 3 fields anymore, not really 4 cases ? - if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) - IF_GC_TRACE(printf ("case 1\n")); + // if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) // TODO always matches procedures, WRONG, maybe check only the right gc bit ?/ + if (ram_get_gc_tags (visit) & 0x2f) // TODO we check only the last gc bit + IF_GC_TRACE(printf ("case 1\n")); // TODO are there cases where checking only the last gc bit is wrong ? + // TODO FOOBAR ok, with our new way, what do we check here ? else { - field0 = ram_get_field0 (visit); - - if (HAS_2_OBJECT_FIELDS(field0)) + if (HAS_2_OBJECT_FIELDS(visit)) { IF_GC_TRACE(printf ("case 5\n")); // TODO we don't have cases 2-4 anymore visit_field2: - temp = ram_get_cdr (visit); // TODO was field2 + temp = ram_get_cdr (visit); if (IN_RAM(temp)) { IF_GC_TRACE(printf ("case 6\n")); ram_set_gc_tags (visit, GC_TAG_1_LEFT); - ram_set_cdr (visit, stack); // TODO was field2 + ram_set_cdr (visit, stack); goto push; } @@ -649,19 +656,19 @@ void mark (obj temp) goto visit_field1; } - if (HAS_1_OBJECT_FIELD(field0)) + if (HAS_1_OBJECT_FIELD(visit)) { IF_GC_TRACE(printf ("case 8\n")); visit_field1: - temp = ram_get_car (visit); // TODO was field1 + temp = ram_get_car (visit); if (IN_RAM(temp)) { IF_GC_TRACE(printf ("case 9\n")); - ram_set_gc_tags (visit, GC_TAG_0_LEFT); - ram_set_car (visit, stack); // TODO was field1 + ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, now we only set the bit 0, we don't change the bit 1, since some objets have only 1 mark bit + ram_set_car (visit, stack); goto push; } @@ -670,7 +677,7 @@ void mark (obj temp) else IF_GC_TRACE(printf ("case 11\n")); - ram_set_gc_tags (visit, GC_TAG_0_LEFT); + ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, same as above } pop: @@ -679,12 +686,12 @@ void mark (obj temp) if (stack != NIL) { - if (ram_get_gc_tags (stack) == GC_TAG_1_LEFT) + if (ram_get_gc_tags (stack) == GC_TAG_1_LEFT) // TODO FOOBAR, this is always true for procedures that have not been marked, can such an object get here ? probably not, since when a procedure is popped, it has already been visited, so will be at 0 left { IF_GC_TRACE(printf ("case 13\n")); - temp = ram_get_cdr (stack); /* pop through field 2 */ // TODO was field2 - ram_set_cdr (stack, visit); // TODO was field2 + temp = ram_get_cdr (stack); /* pop through field 2 */ + ram_set_cdr (stack, visit); visit = stack; stack = temp; @@ -693,8 +700,8 @@ void mark (obj temp) IF_GC_TRACE(printf ("case 14\n")); - temp = ram_get_car (stack); /* pop through field 1 */ // TODO was field1 - ram_set_car (stack, visit); // TODO was field1 + temp = ram_get_car (stack); /* pop through field 1 */ + ram_set_car (stack, visit); visit = stack; stack = temp; @@ -721,14 +728,18 @@ void sweep (void) while (visit >= MIN_RAM_ENCODING) { - if (ram_get_gc_tags (visit) == GC_TAG_UNMARKED) /* unmarked? */ + if ((RAM_COMPOSITE(visit) && (ram_get_gc_tags (visit) == GC_TAG_UNMARKED)) || (ram_get_gc_tags (visit) & GC_TAG_0_LEFT)) /* unmarked? */ + // TODO now we check only 1 bit if the object has only 1 mark bit { - ram_set_field1 (visit, free_list); + ram_set_car (visit, free_list); // TODO was field1 free_list = visit; } else { - ram_set_gc_tags (visit, GC_TAG_UNMARKED); + if (RAM_COMPOSITE(visit)) + ram_set_gc_tags (visit, GC_TAG_UNMARKED); + else // only 1 mark bit to unset + ram_set_gc_tag0 (visit, GC_TAG_UNMARKED); #ifdef DEBUG_GC n++; #endif diff --git a/picobit.scm b/picobit.scm dissimilarity index 65% index 0a9ef2f..d9f5de1 100644 --- a/picobit.scm +++ b/picobit.scm @@ -1,2999 +1,963 @@ -; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley> - -; Copyright (C) 2006 by Marc Feeley, All Rights Reserved. - -(define-macro (dummy) - (proper-tail-calls-set! #f) - #f) -;(dummy) - -;----------------------------------------------------------------------------- - -(define compiler-error - (lambda (msg . others) - (display "*** ERROR -- ") - (display msg) - (for-each (lambda (x) (display " ") (write x)) others) - (newline) - (exit 1))) - -;----------------------------------------------------------------------------- - -(define keep - (lambda (keep? lst) - (cond ((null? lst) '()) - ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst)))) - (else (keep keep? (cdr lst)))))) - -(define take - (lambda (n lst) - (if (> n 0) - (cons (car lst) (take (- n 1) (cdr lst))) - '()))) - -(define drop - (lambda (n lst) - (if (> n 0) - (drop (- n 1) (cdr lst)) - lst))) - -(define repeat - (lambda (n x) - (if (> n 0) - (cons x (repeat (- n 1) x)) - '()))) - -(define pos-in-list - (lambda (x lst) - (let loop ((lst lst) (i 0)) - (cond ((not (pair? lst)) #f) - ((eq? (car lst) x) i) - (else (loop (cdr lst) (+ i 1))))))) - -(define every - (lambda (pred? lst) - (or (null? lst) - (and (pred? (car lst)) - (every pred? (cdr lst)))))) - -;----------------------------------------------------------------------------- - -; Syntax-tree node representation. - -(define-type node - extender: define-type-of-node - parent - children -) - -(define-type-of-node cst - val -) - -(define-type-of-node ref - var -) - -(define-type-of-node def - var -) - -(define-type-of-node set - var -) - -(define-type-of-node if -) - -(define-type-of-node prc - params - rest? - entry-label -) - -(define-type-of-node call -) - -(define-type-of-node seq -) - -(define-type-of-node fix - vars -) - -(define node->expr - (lambda (node) - (cond ((cst? node) - (let ((val (cst-val node))) - (if (self-eval? val) - val - (list 'quote val)))) - ((ref? node) - (var-id (ref-var node))) - ((def? node) - (list 'define - (var-id (def-var node)) - (node->expr (child1 node)))) - ((set? node) - (list 'set! - (var-id (set-var node)) - (node->expr (child1 node)))) - ((if? node) - (list 'if - (node->expr (child1 node)) - (node->expr (child2 node)) - (node->expr (child3 node)))) - ((prc? node) - (if (seq? (child1 node)) - (cons 'lambda - (cons (build-pattern (prc-params node) (prc-rest? node)) - (nodes->exprs (node-children (child1 node))))) - (list 'lambda - (build-pattern (prc-params node) (prc-rest? node)) - (node->expr (child1 node))))) - ((call? node) - (map node->expr (node-children node))) - ((seq? node) - (let ((children (node-children node))) - (cond ((null? children) - '(void)) - ((null? (cdr children)) - (node->expr (car children))) - (else - (cons 'begin - (nodes->exprs children)))))) - ((fix? node) - (let ((children (node-children node))) - (list 'letrec - (map (lambda (var val) - (list (var-id var) - (node->expr val))) - (fix-vars node) - (take (- (length children) 1) children)) - (node->expr (list-ref children (- (length children) 1)))))) - (else - (compiler-error "unknown expression type" node))))) - -(define nodes->exprs - (lambda (nodes) - (if (null? nodes) - '() - (if (seq? (car nodes)) - (append (nodes->exprs (node-children (car nodes))) - (nodes->exprs (cdr nodes))) - (cons (node->expr (car nodes)) - (nodes->exprs (cdr nodes))))))) - -(define build-pattern - (lambda (params rest?) - (cond ((null? params) - '()) - ((null? (cdr params)) - (if rest? - (var-id (car params)) - (list (var-id (car params))))) - (else - (cons (var-id (car params)) - (build-pattern (cdr params) rest?)))))) - -;----------------------------------------------------------------------------- - -; Environment representation. - -(define-type var - id - global? - refs - sets - defs - needed? - primitive -) - -(define-type primitive - nargs - inliner - unspecified-result? -) - -(define-type renaming - renamings -) - -(define make-global-env - (lambda () - (list (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f)) - (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t)) - (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f)) - - (make-var '#%set-fst! #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%set-snd! #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%set-trd! #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - - (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t)) - (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f)) - (make-var '#%motor #t '() '() '() #f (make-primitive 3 #f #t)) - (make-var '#%led #t '() '() '() #f (make-primitive 1 #f #t)) - (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%putchar #t '() '() '() #f (make-primitive 1 #f #t)) - (make-var '#%light #t '() '() '() #f (make-primitive 0 #f #f)) - - (make-var '#%triplet? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED - (make-var '#%triplet #t '() '() '() #f (make-primitive 3 #f #f)) ;; ADDED - (make-var '#%fst #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED - (make-var '#%snd #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED - (make-var '#%trd #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED - - (make-var '#%readyq #t '() '() '() #f #f) - - ))) - -(define env-lookup - (lambda (env id) - (let loop ((lst env) (id id)) - (let ((b (car lst))) - (cond ((and (renaming? b) - (assq id (renaming-renamings b))) - => - (lambda (x) - (loop (cdr lst) (cadr x)))) - ((and (var? b) - (eq? (var-id b) id)) - b) - ((null? (cdr lst)) - (let ((x (make-var id #t '() '() '() #f #f))) - (set-cdr! lst (cons x '())) - x)) - (else - (loop (cdr lst) id))))))) - -(define env-extend - (lambda (env ids def) - (append (map (lambda (id) - (make-var id #f '() '() (list def) #f #f)) - ids) - env))) - -(define env-extend-renamings - (lambda (env renamings) - (cons (make-renaming renamings) env))) - -;----------------------------------------------------------------------------- - -; Parsing. - -(define parse-program - (lambda (expr env) - (let ((x (parse-top expr env))) - (cond ((null? x) - (parse 'value #f env)) - ((null? (cdr x)) - (car x)) - (else - (let ((r (make-seq #f x))) - (for-each (lambda (y) (node-parent-set! y r)) x) - r)))))) - -(define parse-top - (lambda (expr env) - (cond ((and (pair? expr) - (eq? (car expr) 'begin)) - (parse-top-list (cdr expr) env)) - ((and (pair? expr) - (eq? (car expr) 'hide)) - (parse-top-hide (cadr expr) (cddr expr) env)) - ((and (pair? expr) - (eq? (car expr) 'rename)) - (parse-top-rename (cadr expr) (cddr expr) env)) - ((and (pair? expr) - (eq? (car expr) 'define)) - (let ((var - (if (pair? (cadr expr)) - (car (cadr expr)) - (cadr expr))) - (val - (if (pair? (cadr expr)) - (cons 'lambda (cons (cdr (cadr expr)) (cddr expr))) - (caddr expr)))) - (let* ((var2 (env-lookup env var)) - (val2 (parse 'value val env)) - (r (make-def #f (list val2) var2))) - (node-parent-set! val2 r) - (var-defs-set! var2 (cons r (var-defs var2))) - (list r)))) - (else - (list (parse 'value expr env)))))) - -(define parse-top-list - (lambda (lst env) - (if (pair? lst) - (append (parse-top (car lst) env) - (parse-top-list (cdr lst) env)) - '()))) - -(define parse-top-hide - (lambda (renamings body env) - (append - (parse-top-list body - (env-extend-renamings env renamings)) -#| - (parse-top-list - (map (lambda (x) (list 'define (car x) (cadr x))) renamings) - env) -|# -))) - -(define parse-top-rename - (lambda (renamings body env) - (parse-top-list body - (env-extend-renamings env renamings)))) - -(define parse - (lambda (use expr env) - (cond ((self-eval? expr) - (make-cst #f '() expr)) - ((symbol? expr) - (let* ((var (env-lookup env expr)) - (r (make-ref #f '() var))) - (var-refs-set! var (cons r (var-refs var))) - r)) - ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid - (eq? (car expr) 'cond)) - (parse use - `(if ,(caadr expr) - (begin ,@(cdadr expr)) - ,(if (null? (cddr expr)) - #f - `(cond ,@(cddr expr)))) - env)) - ((and (pair? expr) - (eq? (car expr) 'set!)) - (let ((var (env-lookup env (cadr expr)))) - (if (var-global? var) - (let* ((val (parse 'value (caddr expr) env)) - (r (make-set #f (list val) var))) - (node-parent-set! val r) - (var-sets-set! var (cons r (var-sets var))) - r) - (compiler-error "set! is only permitted on global variables")))) - ((and (pair? expr) - (eq? (car expr) 'quote)) - (make-cst #f '() (cadr expr))) - ((and (pair? expr) - (eq? (car expr) 'if)) - (let* ((a (parse 'test (cadr expr) env)) - (b (parse use (caddr expr) env)) - (c (if (null? (cdddr expr)) - (make-cst #f '() #f) - (parse use (cadddr expr) env))) - (r (make-if #f (list a b c)))) - (node-parent-set! a r) - (node-parent-set! b r) - (node-parent-set! c r) - r)) - ((and (pair? expr) - (eq? (car expr) 'lambda)) - (let* ((pattern (cadr expr)) - (ids (extract-ids pattern)) - (r (make-prc #f '() #f (has-rest-param? pattern) #f)) - (new-env (env-extend env ids r)) - (body (parse-body (cddr expr) new-env))) - (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids)) - (node-children-set! r (list body)) - (node-parent-set! body r) - r)) - ((and (pair? expr) - (eq? (car expr) 'begin)) - (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr))) - (r (make-seq #f exprs))) - (for-each (lambda (x) (node-parent-set! x r)) exprs) - r)) - ((and (pair? expr) - (eq? (car expr) 'let)) - (if (symbol? (cadr expr)) - (compiler-error "named let is not implemented") - (parse use - (cons (cons 'lambda - (cons (map car (cadr expr)) - (cddr expr))) - (map cadr (cadr expr))) - env))) - ((and (pair? expr) - (eq? (car expr) 'let*)) - (if (null? (cadr expr)) - (parse use - (cons 'let (cdr expr)) - env) - (parse use - (list 'let - (list (list (caar (cadr expr)) - (cadar (cadr expr)))) - (cons 'let* - (cons (cdr (cadr expr)) - (cddr expr)))) - env))) - ((and (pair? expr) - (eq? (car expr) 'and)) - (cond ((null? (cdr expr)) - (parse use - #t - env)) - ((null? (cddr expr)) - (parse use - (cadr expr) - env)) - (else - (parse use - (list 'if - (cadr expr) - (cons 'and (cddr expr)) - #f) - env)))) - ((and (pair? expr) - (eq? (car expr) 'or)) - (cond ((null? (cdr expr)) - (parse use - #f - env)) - ((null? (cddr expr)) - (parse use - (cadr expr) - env)) - ((eq? use 'test) - (parse use - (list 'if - (cadr expr) - #t - (cons 'or (cddr expr))) - env)) - (else - (parse use - (let ((v (gensym))) - (list 'let - (list (list v (cadr expr))) - (list 'if - v - v - (cons 'or (cddr expr))))) - env)))) - ((and (pair? expr) - (memq (car expr) - '(quote quasiquote unquote unquote-splicing lambda if - set! cond and or case let let* letrec begin do define - delay))) - (compiler-error "the compiler does not implement the special form" (car expr))) - ((pair? expr) - (let* ((exprs (map (lambda (x) (parse 'value x env)) expr)) - (r (make-call #f exprs))) - (for-each (lambda (x) (node-parent-set! x r)) exprs) - r)) - (else - (compiler-error "unknown expression" expr))))) - -(define parse-body - (lambda (exprs env) - (parse 'value (cons 'begin exprs) env))) - -(define self-eval? - (lambda (expr) - (or (number? expr) - (char? expr) - (boolean? expr) - (string? expr)))) - -(define extract-ids - (lambda (pattern) - (if (pair? pattern) - (cons (car pattern) (extract-ids (cdr pattern))) - (if (symbol? pattern) - (cons pattern '()) - '())))) - -(define has-rest-param? - (lambda (pattern) - (if (pair? pattern) - (has-rest-param? (cdr pattern)) - (symbol? pattern)))) - -;----------------------------------------------------------------------------- - -; Compilation context representation. - -(define-type context - code - env - env2 -) - -(define context-change-code - (lambda (ctx code) - (make-context code - (context-env ctx) - (context-env2 ctx)))) - -(define context-change-env - (lambda (ctx env) - (make-context (context-code ctx) - env - (context-env2 ctx)))) - -(define context-change-env2 - (lambda (ctx env2) - (make-context (context-code ctx) - (context-env ctx) - env2))) - -(define make-init-context - (lambda () - (make-context (make-init-code) - (make-init-env) - #f))) - -(define context-make-label - (lambda (ctx) - (context-change-code ctx (code-make-label (context-code ctx))))) - -(define context-last-label - (lambda (ctx) - (code-last-label (context-code ctx)))) - -(define context-add-bb - (lambda (ctx label) - (context-change-code ctx (code-add-bb (context-code ctx) label)))) - -(define context-add-instr - (lambda (ctx instr) - (context-change-code ctx (code-add-instr (context-code ctx) instr)))) - -; Representation of code. - -(define-type code - last-label - rev-bbs -) - -(define-type bb - label - rev-instrs -) - -(define make-init-code - (lambda () - (make-code 0 - (list (make-bb 0 (list)))))) - -(define code-make-label - (lambda (code) - (let ((label (+ (code-last-label code) 1))) - (make-code label - (code-rev-bbs code))))) - -(define code-add-bb - (lambda (code label) - (make-code - (code-last-label code) - (cons (make-bb label '()) - (code-rev-bbs code))))) - -(define code-add-instr - (lambda (code instr) - (let* ((rev-bbs (code-rev-bbs code)) - (bb (car rev-bbs)) - (rev-instrs (bb-rev-instrs bb))) - (make-code - (code-last-label code) - (cons (make-bb (bb-label bb) - (cons instr rev-instrs)) - (cdr rev-bbs)))))) - -; Representation of compile-time stack. - -(define-type stack - size ; number of slots - slots ; for each slot, the variable (or #f) contained in the slot -) - -(define make-init-stack - (lambda () - (make-stack 0 '()))) - -(define stack-extend - (lambda (x nb-slots stk) - (let ((size (stack-size stk))) - (make-stack - (+ size nb-slots) - (append (repeat nb-slots x) (stack-slots stk)))))) - -(define stack-discard - (lambda (nb-slots stk) - (let ((size (stack-size stk))) - (make-stack - (- size nb-slots) - (list-tail (stack-slots stk) nb-slots))))) - -; Representation of compile-time environment. - -(define-type env - local - closed -) - -(define make-init-env - (lambda () - (make-env (make-init-stack) - '()))) - -(define env-change-local - (lambda (env local) - (make-env local - (env-closed env)))) - -(define env-change-closed - (lambda (env closed) - (make-env (env-local env) - closed))) - -(define find-local-var - (lambda (var env) - (let ((i (pos-in-list var (stack-slots (env-local env))))) - (or i - (- (+ (pos-in-list var (env-closed env)) 1)))))) - -(define prc->env - (lambda (prc) - (make-env - (let ((params (prc-params prc))) - (make-stack (length params) - (append (map var-id params) '()))) - (let ((vars (varset->list (non-global-fv prc)))) -; (pp (map var-id vars)) - (map var-id vars))))) - -;----------------------------------------------------------------------------- - -(define gen-instruction - (lambda (instr nb-pop nb-push ctx) - (let* ((env - (context-env ctx)) - (stk - (stack-extend #f - nb-push - (stack-discard nb-pop - (env-local env))))) - (context-add-instr (context-change-env ctx (env-change-local env stk)) - instr)))) - -(define gen-entry - (lambda (nparams rest? ctx) - (gen-instruction (list 'entry nparams rest?) 0 0 ctx))) - -(define gen-push-constant - (lambda (val ctx) - (gen-instruction (list 'push-constant val) 0 1 ctx))) - -(define gen-push-unspecified - (lambda (ctx) - (gen-push-constant #f ctx))) - -(define gen-push-local-var - (lambda (var ctx) -; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx)))) - (let ((i (find-local-var var (context-env ctx)))) - (if (>= i 0) - (gen-push-stack i ctx) - (gen-push-stack (+ (- -1 i) (length (stack-slots (env-local (context-env ctx))))) ctx))))) - -(define gen-push-stack - (lambda (pos ctx) - (gen-instruction (list 'push-stack pos) 0 1 ctx))) - -(define gen-push-global - (lambda (var ctx) - (gen-instruction (list 'push-global var) 0 1 ctx))) - -(define gen-set-global - (lambda (var ctx) - (gen-instruction (list 'set-global var) 1 0 ctx))) - -(define gen-call - (lambda (nargs ctx) - (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx))) - -(define gen-jump - (lambda (nargs ctx) - (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx))) - -(define gen-call-toplevel - (lambda (nargs id ctx) - (gen-instruction (list 'call-toplevel id) nargs 1 ctx))) - -(define gen-jump-toplevel - (lambda (nargs id ctx) - (gen-instruction (list 'jump-toplevel id) nargs 1 ctx))) - -(define gen-goto - (lambda (label ctx) - (gen-instruction (list 'goto label) 0 0 ctx))) - -(define gen-goto-if-false - (lambda (label-false label-true ctx) - (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx))) - -(define gen-closure - (lambda (label-entry ctx) - (gen-instruction (list 'closure label-entry) 2 1 ctx))) - -(define gen-prim - (lambda (id nargs unspec-result? ctx) - (gen-instruction - (list 'prim id) - nargs - (if unspec-result? 0 1) - ctx))) - -(define gen-shift - (lambda (n ctx) - (if (> n 0) - (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx)) - ctx))) - -(define gen-pop - (lambda (ctx) - (gen-instruction (list 'pop) 1 0 ctx))) - -(define gen-return - (lambda (ctx) - (let ((ss (stack-size (env-local (context-env ctx))))) - (gen-instruction (list 'return) ss 0 ctx)))) - -;----------------------------------------------------------------------------- - -(define child1 - (lambda (node) - (car (node-children node)))) - -(define child2 - (lambda (node) - (cadr (node-children node)))) - -(define child3 - (lambda (node) - (caddr (node-children node)))) - -(define comp-none - (lambda (node ctx) - - (cond ((or (cst? node) - (ref? node) - (prc? node)) - ctx) - - ((def? node) - (let ((var (def-var node))) - (if (toplevel-prc-with-non-rest-correct-calls? var) - (comp-prc (child1 node) #f ctx) - (if (var-needed? var) - (let ((ctx2 (comp-push (child1 node) ctx))) - (gen-set-global (var-id var) ctx2)) - (comp-none (child1 node) ctx))))) - - ((set? node) - (let ((var (set-var node))) - (if (var-needed? var) - (let ((ctx2 (comp-push (child1 node) ctx))) - (gen-set-global (var-id var) ctx2)) - (comp-none (child1 node) ctx)))) - - ((if? node) - (let* ((ctx2 - (context-make-label ctx)) - (label-then - (context-last-label ctx2)) - (ctx3 - (context-make-label ctx2)) - (label-else - (context-last-label ctx3)) - (ctx4 - (context-make-label ctx3)) - (label-then-join - (context-last-label ctx4)) - (ctx5 - (context-make-label ctx4)) - (label-else-join - (context-last-label ctx5)) - (ctx6 - (context-make-label ctx5)) - (label-join - (context-last-label ctx6)) - (ctx7 - (comp-test (child1 node) label-then label-else ctx6)) - (ctx8 - (gen-goto - label-else-join - (comp-none (child3 node) - (context-change-env2 - (context-add-bb ctx7 label-else) - #f)))) - (ctx9 - (gen-goto - label-then-join - (comp-none (child2 node) - (context-change-env - (context-add-bb ctx8 label-then) - (context-env2 ctx7))))) - (ctx10 - (gen-goto - label-join - (context-add-bb ctx9 label-else-join))) - (ctx11 - (gen-goto - label-join - (context-add-bb ctx10 label-then-join))) - (ctx12 - (context-add-bb ctx11 label-join))) - ctx12)) - - ((call? node) - (comp-call node 'none ctx)) - - ((seq? node) - (let ((children (node-children node))) - (if (null? children) - ctx - (let loop ((lst children) - (ctx ctx)) - (if (null? (cdr lst)) - (comp-none (car lst) ctx) - (loop (cdr lst) - (comp-none (car lst) ctx))))))) - - (else - (compiler-error "unknown expression type" node))))) - -(define comp-tail - (lambda (node ctx) - - (cond ((or (cst? node) - (ref? node) - (def? node) - (set? node) - (prc? node) -; (call? node) - ) - (gen-return (comp-push node ctx))) - - ((if? node) - (let* ((ctx2 - (context-make-label ctx)) - (label-then - (context-last-label ctx2)) - (ctx3 - (context-make-label ctx2)) - (label-else - (context-last-label ctx3)) - (ctx4 - (comp-test (child1 node) label-then label-else ctx3)) - (ctx5 - (comp-tail (child3 node) - (context-change-env2 - (context-add-bb ctx4 label-else) - #f))) - (ctx6 - (comp-tail (child2 node) - (context-change-env - (context-add-bb ctx5 label-then) - (context-env2 ctx4))))) - ctx6)) - - ((call? node) - (comp-call node 'tail ctx)) - - ((seq? node) - (let ((children (node-children node))) - (if (null? children) - (gen-return (gen-push-unspecified ctx)) - (let loop ((lst children) - (ctx ctx)) - (if (null? (cdr lst)) - (comp-tail (car lst) ctx) - (loop (cdr lst) - (comp-none (car lst) ctx))))))) - - (else - (compiler-error "unknown expression type" node))))) - -(define comp-push - (lambda (node ctx) - - '( - (display "--------------\n") - (pp (node->expr node)) - (pp env) - (pp stk) - ) - - (cond ((cst? node) - (let ((val (cst-val node))) - (gen-push-constant val ctx))) - - ((ref? node) - (let ((var (ref-var node))) - (if (var-global? var) - (if (null? (var-defs var)) - (compiler-error "undefined variable:" (var-id var)) - (gen-push-global (var-id var) ctx)) - (gen-push-local-var (var-id var) ctx)))) - - ((or (def? node) - (set? node)) - (gen-push-unspecified (comp-none node ctx))) - - ((if? node) - (let* ((ctx2 - (context-make-label ctx)) - (label-then - (context-last-label ctx2)) - (ctx3 - (context-make-label ctx2)) - (label-else - (context-last-label ctx3)) - (ctx4 - (context-make-label ctx3)) - (label-then-join - (context-last-label ctx4)) - (ctx5 - (context-make-label ctx4)) - (label-else-join - (context-last-label ctx5)) - (ctx6 - (context-make-label ctx5)) - (label-join - (context-last-label ctx6)) - (ctx7 - (comp-test (child1 node) label-then label-else ctx6)) - (ctx8 - (gen-goto - label-else-join - (comp-push (child3 node) - (context-change-env2 - (context-add-bb ctx7 label-else) - #f)))) - (ctx9 - (gen-goto - label-then-join - (comp-push (child2 node) - (context-change-env - (context-add-bb ctx8 label-then) - (context-env2 ctx7))))) - (ctx10 - (gen-goto - label-join - (context-add-bb ctx9 label-else-join))) - (ctx11 - (gen-goto - label-join - (context-add-bb ctx10 label-then-join))) - (ctx12 - (context-add-bb ctx11 label-join))) - ctx12)) - - ((prc? node) - (comp-prc node #t ctx)) - - ((call? node) - (comp-call node 'push ctx)) - - ((seq? node) - (let ((children (node-children node))) - (if (null? children) - (gen-push-unspecified ctx) - (let loop ((lst children) - (ctx ctx)) - (if (null? (cdr lst)) - (comp-push (car lst) ctx) - (loop (cdr lst) - (comp-none (car lst) ctx))))))) - - (else - (compiler-error "unknown expression type" node))))) - -(define (build-closure label-entry vars ctx) - - (define (build vars ctx) - (if (null? vars) - (gen-push-constant '() ctx) - (gen-prim '#%cons - 2 - #f - (build (cdr vars) - (gen-push-local-var (car vars) ctx))))) - - (if (null? vars) - (gen-closure label-entry - ;; (gen-push-constant '() ;; TODO FOOBAR this is probably where we have to change the size of the pointer to 12 bits, instead of '() #f (#x0200), it should be (#x0020), but is #x20 a constant ? if not, it should be gen push something, actually, looks like it's a fixnum, 24 to be exact -;; (gen-push-constant #f ctx)) - (gen-push-constant #f (gen-push-constant 24 ctx)) - ;; TODO ugly hack, probably doesn't even work FOOBAR - ) - (gen-closure label-entry ;; TODO can a similar hack be done to extend pointer size ? similar to above, that is, or is it even necessary since build calls cons ? maybe for the original empty list ? - (build (cdr vars) - (gen-push-local-var (car vars) ctx))))) - -(define comp-prc - (lambda (node closure? ctx) - (let* ((ctx2 - (context-make-label ctx)) - (label-entry - (context-last-label ctx2)) - (ctx3 - (context-make-label ctx2)) - (label-continue - (context-last-label ctx3)) - (body-env - (prc->env node)) - (ctx4 - (if closure? - (build-closure label-entry (env-closed body-env) ctx3) - ctx3)) - (ctx5 - (gen-goto label-continue ctx4)) - (ctx6 - (gen-entry (length (prc-params node)) - (prc-rest? node) - (context-add-bb (context-change-env ctx5 - body-env) - label-entry))) - (ctx7 - (comp-tail (child1 node) ctx6))) - (prc-entry-label-set! node label-entry) - (context-add-bb (context-change-env ctx7 (context-env ctx5)) - label-continue)))) - -(define comp-call - (lambda (node reason ctx) - (let* ((op (child1 node)) - (args (cdr (node-children node))) - (nargs (length args))) - (let loop ((lst args) - (ctx ctx)) - (if (pair? lst) - - (let ((arg (car lst))) - (loop (cdr lst) - (comp-push arg ctx))) - - (cond ((and (ref? op) - (var-primitive (ref-var op))) - (let* ((var (ref-var op)) - (id (var-id var)) - (primitive (var-primitive var)) - (prim-nargs (primitive-nargs primitive))) - - (define use-result - (lambda (ctx2) - (cond ((eq? reason 'tail) - (gen-return - (if (primitive-unspecified-result? primitive) - (gen-push-unspecified ctx2) - ctx2))) - ((eq? reason 'push) - (if (primitive-unspecified-result? primitive) - (gen-push-unspecified ctx2) - ctx2)) - (else - (if (primitive-unspecified-result? primitive) - ctx2 - (gen-pop ctx2)))))) - - (use-result - (if (primitive-inliner primitive) - ((primitive-inliner primitive) ctx) - (if (not (= nargs prim-nargs)) - (compiler-error "primitive called with wrong number of arguments" id) - (gen-prim - id - prim-nargs - (primitive-unspecified-result? primitive) - ctx)))))) - - - ((and (ref? op) - (toplevel-prc-with-non-rest-correct-calls? (ref-var op))) - => - (lambda (prc) - (cond ((eq? reason 'tail) - (gen-jump-toplevel nargs prc ctx)) - ((eq? reason 'push) - (gen-call-toplevel nargs prc ctx)) - (else - (gen-pop (gen-call-toplevel nargs prc ctx)))))) - - (else - (let ((ctx2 (comp-push op ctx))) - (cond ((eq? reason 'tail) - (gen-jump nargs ctx2)) - ((eq? reason 'push) - (gen-call nargs ctx2)) - (else - (gen-pop (gen-call nargs ctx2)))))))))))) - -(define comp-test - (lambda (node label-true label-false ctx) - (cond ((cst? node) - (let ((ctx2 - (gen-goto - (let ((val (cst-val node))) - (if val - label-true - label-false)) - ctx))) - (context-change-env2 ctx2 (context-env ctx2)))) - - ((or (ref? node) - (def? node) - (set? node) - (if? node) - (call? node) - (seq? node)) - (let* ((ctx2 - (comp-push node ctx)) - (ctx3 - (gen-goto-if-false label-false label-true ctx2))) - (context-change-env2 ctx3 (context-env ctx3)))) - - ((prc? node) - (let ((ctx2 - (gen-goto label-true ctx))) - (context-change-env2 ctx2 (context-env ctx2)))) - - (else - (compiler-error "unknown expression type" node))))) - -;----------------------------------------------------------------------------- - -(define toplevel-prc? - (lambda (var) - (and (not (mutable-var? var)) - (let ((d (var-defs var))) - (and (pair? d) - (null? (cdr d)) - (let ((val (child1 (car d)))) - (and (prc? val) - val))))))) - -(define toplevel-prc-with-non-rest-correct-calls? - (lambda (var) - (let ((prc (toplevel-prc? var))) - (and prc - (not (prc-rest? prc)) - (every (lambda (r) - (let ((parent (node-parent r))) - (and (call? parent) - (eq? (child1 parent) r) - (= (length (prc-params prc)) - (- (length (node-children parent)) 1))))) - (var-refs var)) - prc)))) - -(define mutable-var? ;; TODO use it to put immutable globals in rom - (lambda (var) - (not (null? (var-sets var))))) - -(define global-fv - (lambda (node) - (list->varset - (keep var-global? - (varset->list (fv node)))))) - -(define non-global-fv - (lambda (node) - (list->varset - (keep (lambda (x) (not (var-global? x))) - (varset->list (fv node)))))) - -(define fv - (lambda (node) - (cond ((cst? node) - (varset-empty)) - ((ref? node) - (let ((var (ref-var node))) - (varset-singleton var))) - ((def? node) - (let ((var (def-var node)) - (val (child1 node))) - (varset-union - (varset-singleton var) - (fv val)))) - ((set? node) - (let ((var (set-var node)) - (val (child1 node))) - (varset-union - (varset-singleton var) - (fv val)))) - ((if? node) - (let ((a (list-ref (node-children node) 0)) - (b (list-ref (node-children node) 1)) - (c (list-ref (node-children node) 2))) - (varset-union-multi (list (fv a) (fv b) (fv c))))) - ((prc? node) - (let ((body (list-ref (node-children node) 0))) - (varset-difference - (fv body) - (build-params-varset (prc-params node))))) - ((call? node) - (varset-union-multi (map fv (node-children node)))) - ((seq? node) - (varset-union-multi (map fv (node-children node)))) - (else - (compiler-error "unknown expression type" node))))) - -(define build-params-varset - (lambda (params) - (list->varset params))) - -(define mark-needed-global-vars! - (lambda (global-env node) - - (define readyq - (env-lookup global-env '#%readyq)) - - (define mark-var! - (lambda (var) - (if (and (var-global? var) - (not (var-needed? var))) - (begin - (var-needed?-set! var #t) - (for-each - (lambda (def) - (let ((val (child1 def))) - (if (side-effect-less? val) - (mark! val)))) - (var-defs var)) - (if (eq? var readyq) - (begin - (mark-var! - (env-lookup global-env '#%start-first-process)) - (mark-var! - (env-lookup global-env '#%exit)))))))) - - (define side-effect-less? - (lambda (node) - (or (cst? node) - (ref? node) - (prc? node)))) - - (define mark! - (lambda (node) - (cond ((cst? node)) - ((ref? node) - (let ((var (ref-var node))) - (mark-var! var))) - ((def? node) - (let ((var (def-var node)) - (val (child1 node))) - (if (not (side-effect-less? val)) - (mark! val)))) - ((set? node) - (let ((var (set-var node)) - (val (child1 node))) - (mark! val))) - ((if? node) - (let ((a (list-ref (node-children node) 0)) - (b (list-ref (node-children node) 1)) - (c (list-ref (node-children node) 2))) - (mark! a) - (mark! b) - (mark! c))) - ((prc? node) - (let ((body (list-ref (node-children node) 0))) - (mark! body))) - ((call? node) - (for-each mark! (node-children node))) - ((seq? node) - (for-each mark! (node-children node))) - (else - (compiler-error "unknown expression type" node))))) - - (mark! node) -)) - -;----------------------------------------------------------------------------- - -; Variable sets - -(define (varset-empty) ; return the empty set - '()) - -(define (varset-singleton x) ; create a set containing only 'x' - (list x)) - -(define (list->varset lst) ; convert list to set - lst) - -(define (varset->list set) ; convert set to list - set) - -(define (varset-size set) ; return cardinality of set - (list-length set)) - -(define (varset-empty? set) ; is 'x' the empty set? - (null? set)) - -(define (varset-member? x set) ; is 'x' a member of the 'set'? - (and (not (null? set)) - (or (eq? x (car set)) - (varset-member? x (cdr set))))) - -(define (varset-adjoin set x) ; add the element 'x' to the 'set' - (if (varset-member? x set) set (cons x set))) - -(define (varset-remove set x) ; remove the element 'x' from 'set' - (cond ((null? set) - '()) - ((eq? (car set) x) - (cdr set)) - (else - (cons (car set) (varset-remove (cdr set) x))))) - -(define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets? - (and (varset-subset? s1 s2) - (varset-subset? s2 s1))) - -(define (varset-subset? s1 s2) ; is 's1' a subset of 's2'? - (cond ((null? s1) - #t) - ((varset-member? (car s1) s2) - (varset-subset? (cdr s1) s2)) - (else - #f))) - -(define (varset-difference set1 set2) ; return difference of sets - (cond ((null? set1) - '()) - ((varset-member? (car set1) set2) - (varset-difference (cdr set1) set2)) - (else - (cons (car set1) (varset-difference (cdr set1) set2))))) - -(define (varset-union set1 set2) ; return union of sets - (define (union s1 s2) - (cond ((null? s1) - s2) - ((varset-member? (car s1) s2) - (union (cdr s1) s2)) - (else - (cons (car s1) (union (cdr s1) s2))))) - (if (varset-smaller? set1 set2) - (union set1 set2) - (union set2 set1))) - -(define (varset-intersection set1 set2) ; return intersection of sets - (define (intersection s1 s2) - (cond ((null? s1) - '()) - ((varset-member? (car s1) s2) - (cons (car s1) (intersection (cdr s1) s2))) - (else - (intersection (cdr s1) s2)))) - (if (varset-smaller? set1 set2) - (intersection set1 set2) - (intersection set2 set1))) - -(define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect? - (not (varset-empty? (varset-intersection set1 set2)))) - -(define (varset-smaller? set1 set2) - (if (null? set1) - (not (null? set2)) - (if (null? set2) - #f - (varset-smaller? (cdr set1) (cdr set2))))) - -(define (varset-union-multi sets) - (if (null? sets) - (varset-empty) - (n-ary varset-union (car sets) (cdr sets)))) - -(define (n-ary function first rest) - (if (null? rest) - first - (n-ary function (function first (car rest)) (cdr rest)))) - -;------------------------------------------------------------------------------ - -(define code->vector - (lambda (code) - (let ((v (make-vector (+ (code-last-label code) 1)))) - (for-each - (lambda (bb) - (vector-set! v (bb-label bb) bb)) - (code-rev-bbs code)) - v))) - -(define bbs->ref-counts - (lambda (bbs) - (let ((ref-counts (make-vector (vector-length bbs) 0))) - - (define visit - (lambda (label) - (let ((ref-count (vector-ref ref-counts label))) - (vector-set! ref-counts label (+ ref-count 1)) - (if (= ref-count 0) - (let* ((bb (vector-ref bbs label)) - (rev-instrs (bb-rev-instrs bb))) - (for-each - (lambda (instr) - (let ((opcode (car instr))) - (cond ((eq? opcode 'goto) - (visit (cadr instr))) - ((eq? opcode 'goto-if-false) - (visit (cadr instr)) - (visit (caddr instr))) - ((or (eq? opcode 'closure) - (eq? opcode 'call-toplevel) - (eq? opcode 'jump-toplevel)) - (visit (cadr instr)))))) - rev-instrs)))))) - - (visit 0) - - ref-counts))) - -(define resolve-toplevel-labels! - (lambda (bbs) - (let loop ((i 0)) - (if (< i (vector-length bbs)) - (let* ((bb (vector-ref bbs i)) - (rev-instrs (bb-rev-instrs bb))) - (bb-rev-instrs-set! - bb - (map (lambda (instr) - (let ((opcode (car instr))) - (cond ((eq? opcode 'call-toplevel) - (list opcode - (prc-entry-label (cadr instr)))) - ((eq? opcode 'jump-toplevel) - (list opcode - (prc-entry-label (cadr instr)))) - (else - instr)))) - rev-instrs)) - (loop (+ i 1))))))) - -(define tighten-jump-cascades! - (lambda (bbs) - (let ((ref-counts (bbs->ref-counts bbs))) - - (define resolve - (lambda (label) - (let* ((bb (vector-ref bbs label)) - (rev-instrs (bb-rev-instrs bb))) - (and (or (null? (cdr rev-instrs)) - (= (vector-ref ref-counts label) 1)) - rev-instrs)))) - - (let loop1 () - (let loop2 ((i 0) - (changed? #f)) - (if (< i (vector-length bbs)) - (if (> (vector-ref ref-counts i) 0) - (let* ((bb (vector-ref bbs i)) - (rev-instrs (bb-rev-instrs bb)) - (jump (car rev-instrs)) - (opcode (car jump))) - (cond ((eq? opcode 'goto) - (let* ((label (cadr jump)) - (jump-replacement (resolve label))) - (if jump-replacement - (begin - (vector-set! - bbs - i - (make-bb (bb-label bb) - (append jump-replacement - (cdr rev-instrs)))) - (loop2 (+ i 1) - #t)) - (loop2 (+ i 1) - changed?)))) - ((eq? opcode 'goto-if-false) - (let* ((label-then (cadr jump)) - (label-else (caddr jump)) - (jump-then-replacement (resolve label-then)) - (jump-else-replacement (resolve label-else))) - (if (and jump-then-replacement - (null? (cdr jump-then-replacement)) - jump-else-replacement - (null? (cdr jump-else-replacement)) - (or (eq? (caar jump-then-replacement) 'goto) - (eq? (caar jump-else-replacement) 'goto))) - (begin - (vector-set! - bbs - i - (make-bb (bb-label bb) - (cons (list 'goto-if-false - (if (eq? (caar jump-then-replacement) 'goto) - (cadar jump-then-replacement) - label-then) - (if (eq? (caar jump-else-replacement) 'goto) - (cadar jump-else-replacement) - label-else)) - (cdr rev-instrs)))) - (loop2 (+ i 1) - #t)) - (loop2 (+ i 1) - changed?)))) - (else - (loop2 (+ i 1) - changed?)))) - (loop2 (+ i 1) - changed?)) - (if changed? - (loop1)))))))) - -(define remove-useless-bbs! - (lambda (bbs) - (let ((ref-counts (bbs->ref-counts bbs))) - (let loop1 ((label 0) (new-label 0)) - (if (< label (vector-length bbs)) - (if (> (vector-ref ref-counts label) 0) - (let ((bb (vector-ref bbs label))) - (vector-set! - bbs - label - (make-bb new-label (bb-rev-instrs bb))) - (loop1 (+ label 1) (+ new-label 1))) - (loop1 (+ label 1) new-label)) - (renumber-labels bbs ref-counts new-label)))))) - -(define renumber-labels - (lambda (bbs ref-counts n) - (let ((new-bbs (make-vector n))) - (let loop2 ((label 0)) - (if (< label (vector-length bbs)) - (if (> (vector-ref ref-counts label) 0) - (let* ((bb (vector-ref bbs label)) - (new-label (bb-label bb)) - (rev-instrs (bb-rev-instrs bb))) - - (define fix - (lambda (instr) - - (define new-label - (lambda (label) - (bb-label (vector-ref bbs label)))) - - (let ((opcode (car instr))) - (cond ((eq? opcode 'closure) - (list 'closure - (new-label (cadr instr)))) - ((eq? opcode 'call-toplevel) - (list 'call-toplevel - (new-label (cadr instr)))) - ((eq? opcode 'jump-toplevel) - (list 'jump-toplevel - (new-label (cadr instr)))) - ((eq? opcode 'goto) - (list 'goto - (new-label (cadr instr)))) - ((eq? opcode 'goto-if-false) - (list 'goto-if-false - (new-label (cadr instr)) - (new-label (caddr instr)))) - (else - instr))))) - - (vector-set! - new-bbs - new-label - (make-bb new-label (map fix rev-instrs))) - (loop2 (+ label 1))) - (loop2 (+ label 1))) - new-bbs))))) - -(define reorder! - (lambda (bbs) - (let* ((done (make-vector (vector-length bbs) #f))) - - (define unscheduled? - (lambda (label) - (not (vector-ref done label)))) - - (define label-refs - (lambda (instrs todo) - (if (pair? instrs) - (let* ((instr (car instrs)) - (opcode (car instr))) - (cond ((or (eq? opcode 'closure) - (eq? opcode 'call-toplevel) - (eq? opcode 'jump-toplevel)) - (label-refs (cdr instrs) (cons (cadr instr) todo))) - (else - (label-refs (cdr instrs) todo)))) - todo))) - - (define schedule-here - (lambda (label new-label todo cont) - (let* ((bb (vector-ref bbs label)) - (rev-instrs (bb-rev-instrs bb)) - (jump (car rev-instrs)) - (opcode (car jump)) - (new-todo (label-refs rev-instrs todo))) - (vector-set! bbs label (make-bb new-label rev-instrs)) - (vector-set! done label #t) - (cond ((eq? opcode 'goto) - (let ((label (cadr jump))) - (if (unscheduled? label) - (schedule-here label - (+ new-label 1) - new-todo - cont) - (cont (+ new-label 1) - new-todo)))) - ((eq? opcode 'goto-if-false) - (let ((label-then (cadr jump)) - (label-else (caddr jump))) - (cond ((unscheduled? label-else) - (schedule-here label-else - (+ new-label 1) - (cons label-then new-todo) - cont)) - ((unscheduled? label-then) - (schedule-here label-then - (+ new-label 1) - new-todo - cont)) - (else - (cont (+ new-label 1) - new-todo))))) - (else - (cont (+ new-label 1) - new-todo)))))) - - (define schedule-somewhere - (lambda (label new-label todo cont) - (schedule-here label new-label todo cont))) - - (define schedule-todo - (lambda (new-label todo) - (if (pair? todo) - (let ((label (car todo))) - (if (unscheduled? label) - (schedule-somewhere label - new-label - (cdr todo) - schedule-todo) - (schedule-todo new-label - (cdr todo))))))) - - - (schedule-here 0 0 '() schedule-todo) - - (renumber-labels bbs - (make-vector (vector-length bbs) 1) - (vector-length bbs))))) - -(define linearize - (lambda (bbs) - (let loop ((label (- (vector-length bbs) 1)) - (lst '())) - (if (>= label 0) - (let* ((bb (vector-ref bbs label)) - (rev-instrs (bb-rev-instrs bb)) - (jump (car rev-instrs)) - (opcode (car jump))) - (loop (- label 1) - (append - (list label) - (reverse - (cond ((eq? opcode 'goto) - (if (= (cadr jump) (+ label 1)) - (cdr rev-instrs) - rev-instrs)) - ((eq? opcode 'goto-if-false) - (cond ((= (caddr jump) (+ label 1)) - (cons (list 'goto-if-false (cadr jump)) - (cdr rev-instrs))) - ((= (cadr jump) (+ label 1)) - (cons (list 'goto-if-not-false (caddr jump)) - (cdr rev-instrs))) - (else - (cons (list 'goto (caddr jump)) - (cons (list 'goto-if-false (cadr jump)) - (cdr rev-instrs)))))) - (else - rev-instrs))) - lst))) - lst)))) - -(define optimize-code - (lambda (code) - (let ((bbs (code->vector code))) - (resolve-toplevel-labels! bbs) - (tighten-jump-cascades! bbs) - (let ((bbs (remove-useless-bbs! bbs))) - (reorder! bbs))))) - -(define expand-loads ;; ADDED - (lambda (exprs) - (map (lambda (e) - (if (eq? (car e) 'load) - (cons 'begin - (expand-loads (with-input-from-file (cadr e) read-all))) - e)) - exprs))) - -(define parse-file - (lambda (filename) - (let* ((library - (with-input-from-file "library.scm" read-all)) - (toplevel-exprs - (expand-loads (append library ;; ADDED (didn't have expand-loads) - (with-input-from-file filename read-all)))) - (global-env - (make-global-env)) - (parsed-prog - (parse-top (cons 'begin toplevel-exprs) global-env))) - - (for-each - (lambda (node) - (mark-needed-global-vars! global-env node)) - parsed-prog) - - (extract-parts - parsed-prog - (lambda (defs after-defs) - - (define make-seq-preparsed - (lambda (exprs) - (let ((r (make-seq #f exprs))) - (for-each (lambda (x) (node-parent-set! x r)) exprs) - r))) - - (define make-call-preparsed - (lambda (exprs) - (let ((r (make-call #f exprs))) - (for-each (lambda (x) (node-parent-set! x r)) exprs) - r))) - - (if (var-needed? - (env-lookup global-env '#%readyq)) - (make-seq-preparsed - (list (make-seq-preparsed defs) - (make-call-preparsed - (list (parse 'value '#%start-first-process global-env) - (let* ((pattern - '()) - (ids - (extract-ids pattern)) - (r - (make-prc #f '() #f (has-rest-param? pattern) #f)) - (new-env - (env-extend global-env ids r)) - (body - (make-seq-preparsed after-defs))) - (prc-params-set! - r - (map (lambda (id) (env-lookup new-env id)) - ids)) - (node-children-set! r (list body)) - (node-parent-set! body r) - r))) - (parse 'value - '(#%exit) - global-env))) - (make-seq-preparsed - (append defs - after-defs - (list (parse 'value - '(#%halt) - global-env)))))))))) - -(define extract-parts - (lambda (lst cont) - (if (or (null? lst) - (not (def? (car lst)))) - (cont '() lst) - (extract-parts - (cdr lst) - (lambda (d ad) - (cont (cons (car lst) d) ad)))))) - -;------------------------------------------------------------------------------ - -;(include "asm.scm") - -;;; File: "asm.scm" -;;; -;;; This module implements the generic assembler. - -;(##declare (standard-bindings) (fixnum) (block)) - -(define compiler-internal-error error) - -;; (asm-begin! start-pos big-endian?) initializes the assembler and -;; starts a new empty code stream at address "start-pos". It must be -;; called every time a new code stream is to be built. The argument -;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64 -;; bit values. After a call to "asm-begin!" the code stream is built -;; by calling the following procedures: -;; -;; asm-8 to add an 8 bit integer to the code stream -;; asm-16 to add a 16 bit integer to the code stream -;; asm-32 to add a 32 bit integer to the code stream -;; asm-64 to add a 64 bit integer to the code stream -;; asm-float64 to add a 64 bit IEEE float to the code stream -;; asm-string to add a null terminated string to the code stream -;; asm-label to set a label to the current position in the code stream -;; asm-align to add enough zero bytes to force alignment -;; asm-origin to add enough zero bytes to move to a particular address -;; asm-at-assembly to defer code production to assembly time -;; asm-listing to add textual information to the listing - -(define (asm-begin! start-pos big-endian?) - (set! asm-start-pos start-pos) - (set! asm-big-endian? big-endian?) - (set! asm-code-stream (asm-make-stream)) - #f) - -;; (asm-end!) must be called to finalize the assembler. - -(define (asm-end!) - (set! asm-code-stream #f) - #f) - -;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream. - -(define (asm-8 n) - (asm-code-extend (asm-bits-0-to-7 n))) - -;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream. - -(define (asm-16 n) - (if asm-big-endian? - (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n)) - (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n))))) - -;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream. - -(define (asm-32 n) - (if asm-big-endian? - (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n)) - (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n))))) - -;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream. - -(define (asm-64 n) - (if asm-big-endian? - (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n)) - (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n))))) - -;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream. - -(define (asm-float64 n) - (asm-64 (asm-float->bits n))) - -;; (asm-string str) adds a null terminated string to the code stream. - -(define (asm-string str) - (let ((len (string-length str))) - (let loop ((i 0)) - (if (< i len) - (begin - (asm-8 (char->integer (string-ref str i))) - (loop (+ i 1))) - (asm-8 0))))) - -;; (asm-make-label id) creates a new label object. A label can -;; be queried with "asm-label-pos" to obtain the label's position -;; relative to the start of the code stream (i.e. "start-pos"). -;; The argument "id" gives a name to the label (not necessarily -;; unique) and is only needed for debugging purposes. - -(define (asm-make-label id) - (vector 'LABEL #f id)) - -;; (asm-label label-obj) sets the label to the current position in the -;; code stream. - -(define (asm-label label-obj) - (if (vector-ref label-obj 1) - (compiler-internal-error - "asm-label, label multiply defined" (asm-label-id label-obj)) - (begin - (vector-set! label-obj 1 0) - (asm-code-extend label-obj)))) - -;; (asm-label-id label-obj) returns the identifier of the label object. - -(define (asm-label-id label-obj) - (vector-ref label-obj 2)) - -;; (asm-label-pos label-obj) returns the position of the label -;; relative to the start of the code stream (i.e. "start-pos"). -;; This procedure can only be called at assembly time (i.e. -;; within the call to "asm-assemble") or after assembly time -;; for labels declared prior to assembly time with "asm-label". -;; A label declared at assembly time can only be queried after -;; assembly time. Moreover, at assembly time the position of a -;; label may vary from one call to the next due to the actions -;; of the assembler. - -(define (asm-label-pos label-obj) - (let ((pos (vector-ref label-obj 1))) - (if pos - pos - (compiler-internal-error - "asm-label-pos, undefined label" (asm-label-id label-obj))))) - -;; (asm-align multiple offset) adds enough zero bytes to the code -;; stream to force alignment to the next address congruent to -;; "offset" modulo "multiple". - -(define (asm-align multiple offset) - (asm-at-assembly - (lambda (self) - (modulo (- multiple (- self offset)) multiple)) - (lambda (self) - (let loop ((n (modulo (- multiple (- self offset)) multiple))) - (if (> n 0) - (begin - (asm-8 0) - (loop (- n 1)))))))) - -;; (asm-origin address) adds enough zero bytes to the code stream to move -;; to the address "address". - -(define (asm-origin address) - (asm-at-assembly - (lambda (self) - (- address self)) - (lambda (self) - (let ((len (- address self))) - (if (< len 0) - (compiler-internal-error "asm-origin, can't move back") - (let loop ((n len)) - (if (> n 0) - (begin - (asm-8 0) - (loop (- n 1)))))))))) - -;; (asm-at-assembly . procs) makes it possible to defer code -;; production to assembly time. A useful application is to generate -;; position dependent and span dependent code sequences. This -;; procedure must be passed an even number of procedures. All odd -;; indexed procedures (including the first procedure) are called "check" -;; procedures. The even indexed procedures are the "production" -;; procedures which, when called, produce a particular code sequence. -;; A check procedure decides if, given the current state of assembly -;; (in particular the current positioning of the labels), the code -;; produced by the corresponding production procedure is valid. -;; If the code is not valid, the check procedure must return #f. -;; If the code is valid, the check procedure must return the length -;; of the code sequence in bytes. The assembler will try each check -;; procedure in order until it finds one that does not return #f -;; (the last check procedure must never return #f). For convenience, -;; the current position in the code sequence is passed as the single -;; argument of check and production procedures. -;; -;; Here is a sample call of "asm-at-assembly" to produce the -;; shortest branch instruction to branch to label "x" for a -;; hypothetical processor: -;; -;; (asm-at-assembly -;; -;; (lambda (self) ; first check procedure -;; (let ((dist (- (asm-label-pos x) self))) -;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible? -;; 2 -;; #f))) -;; -;; (lambda (self) ; first production procedure -;; (asm-8 #x34) ; branch opcode for 8 bit displacement -;; (asm-8 (- (asm-label-pos x) self))) -;; -;; (lambda (self) 5) ; second check procedure -;; -;; (lambda (self) ; second production procedure -;; (asm-8 #x35) ; branch opcode for 32 bit displacement -;; (asm-32 (- (asm-label-pos x) self)))) - -(define (asm-at-assembly . procs) - (asm-code-extend (vector 'DEFERRED procs))) - -;; (asm-listing text) adds text to the right side of the listing. -;; The atoms in "text" will be output using "display" (lists are -;; traversed recursively). The listing is generated by calling -;; "asm-display-listing". - -(define (asm-listing text) - (asm-code-extend (vector 'LISTING text))) - -;; (asm-assemble) assembles the code stream. After assembly, the -;; label objects will be set to their final position and the -;; alignment bytes and the deferred code will have been produced. It -;; is possible to extend the code stream after assembly. However, if -;; any of the procedures "asm-label", "asm-align", and -;; "asm-at-assembly" are called, the code stream will have to be -;; assembled once more. - -(define (asm-assemble) - (let ((fixup-lst (asm-pass1))) - - (let loop1 () - (let loop2 ((lst fixup-lst) - (changed? #f) - (pos asm-start-pos)) - (if (null? lst) - (if changed? (loop1)) - (let* ((fixup (car lst)) - (pos (+ pos (car fixup))) - (curr (cdr fixup)) - (x (car curr))) - (if (eq? (vector-ref x 0) 'LABEL) - ; LABEL - (if (= (vector-ref x 1) pos) - (loop2 (cdr lst) changed? pos) - (begin - (vector-set! x 1 pos) - (loop2 (cdr lst) #t pos))) - ; DEFERRED - (let loop3 () - (let ((n ((car (vector-ref x 1)) pos))) - (if n - (loop2 (cdr lst) changed? (+ pos n)) - (begin - (vector-set! x 1 (cddr (vector-ref x 1))) - (loop3)))))))))) - - (let loop4 ((prev asm-code-stream) - (curr (cdr asm-code-stream)) - (pos asm-start-pos)) - (if (null? curr) - (set-car! asm-code-stream prev) - (let ((x (car curr)) - (next (cdr curr))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (cond ((eq? kind 'LABEL) - (let ((final-pos (vector-ref x 1))) - (if final-pos - (if (not (= pos final-pos)) - (compiler-internal-error - "asm-assemble, inconsistency detected")) - (vector-set! x 1 pos)) - (set-cdr! prev next) - (loop4 prev next pos))) - ((eq? kind 'DEFERRED) - (let ((temp asm-code-stream)) - (set! asm-code-stream (asm-make-stream)) - ((cadr (vector-ref x 1)) pos) - (let ((tail (car asm-code-stream))) - (set-cdr! tail next) - (let ((head (cdr asm-code-stream))) - (set-cdr! prev head) - (set! asm-code-stream temp) - (loop4 prev head pos))))) - (else - (loop4 curr next pos)))) - (loop4 curr next (+ pos 1)))))))) - -;; (asm-display-listing port) produces a listing of the code stream -;; on the given output port. The bytes generated are shown in -;; hexadecimal on the left side of the listing and the right side -;; of the listing contains the text inserted by "asm-listing". - -(define (asm-display-listing port) - - (define text-col 24) - (define pos-width 6) - (define byte-width 2) - - (define (output text) - (cond ((null? text)) - ((pair? text) - (output (car text)) - (output (cdr text))) - (else - (display text port)))) - - (define (print-hex n) - (display (string-ref "0123456789ABCDEF" n) port)) - - (define (print-byte n) - (print-hex (quotient n 16)) - (print-hex (modulo n 16))) - - (define (print-pos n) - (if (< n 0) - (display " " port) - (begin - (print-byte (quotient n #x10000)) - (print-byte (modulo (quotient n #x100) #x100)) - (print-byte (modulo n #x100))))) - - (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0)) - (if (null? lst) - (if (> col 0) - (newline port)) - (let ((x (car lst))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (cond ((eq? kind 'LISTING) - (let loop2 ((col col)) - (if (< col text-col) - (begin - (display (integer->char 9) port) - (loop2 (* 8 (+ (quotient col 8) 1)))))) - (output (vector-ref x 1)) - (newline port) - (loop1 (cdr lst) pos 0)) - (else - (compiler-internal-error - "asm-display-listing, code stream not assembled")))) - (if (or (= col 0) (>= col (- text-col byte-width))) - (begin - (if (not (= col 0)) (newline port)) - (print-pos pos) - (display " " port) - (print-byte x) - (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width))) - (begin - (print-byte x) - (loop1 (cdr lst) (+ pos 1) (+ col byte-width))))))))) - -;; (asm-write-code filename) outputs the code stream (i.e. the sequence -;; of bytes produced) on the named file. - -(define (asm-write-code filename) - (with-output-to-file filename - (lambda () - (let loop ((lst (cdr asm-code-stream))) - (if (not (null? lst)) - (let ((x (car lst))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (if (not (eq? kind 'LISTING)) - (compiler-internal-error - "asm-write-code, code stream not assembled")) - (loop (cdr lst))) - (begin - (write-char (integer->char x)) - (loop (cdr lst)))))))))) - -(define (asm-write-hex-file filename) - (with-output-to-file filename - (lambda () - - (define (print-hex n) - (display (string-ref "0123456789ABCDEF" n))) - - (define (print-byte n) - (print-hex (quotient n 16)) - (print-hex (modulo n 16))) - - (define (print-line type addr bytes) - (let ((n (length bytes)) - (addr-hi (quotient addr 256)) - (addr-lo (modulo addr 256))) - (display ":") - (print-byte n) - (print-byte addr-hi) - (print-byte addr-lo) - (print-byte type) - (for-each print-byte bytes) - (let ((sum - (modulo (- (apply + n addr-hi addr-lo type bytes)) 256))) - (print-byte sum) - (newline)))) - - (let loop ((lst (cdr asm-code-stream)) - (pos asm-start-pos) - (rev-bytes '())) - (if (not (null? lst)) - (let ((x (car lst))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (if (not (eq? kind 'LISTING)) - (compiler-internal-error - "asm-write-hex-file, code stream not assembled")) - (loop (cdr lst) - pos - rev-bytes)) - (let ((new-pos - (+ pos 1)) - (new-rev-bytes - (cons x - (if (= (modulo pos 16) 0) - (begin - (print-line 0 - (- pos (length rev-bytes)) - (reverse rev-bytes)) - '()) - rev-bytes)))) - (loop (cdr lst) - new-pos - new-rev-bytes)))) - (begin - (if (not (null? rev-bytes)) - (print-line 0 - (- pos (length rev-bytes)) - (reverse rev-bytes))) - (print-line 1 0 '()) - (if #t - (begin - (display (- pos asm-start-pos) ##stderr-port) - (display " bytes\n" ##stderr-port))))))))) - -;; Utilities. - -(define asm-start-pos #f) ; start position of the code stream -(define asm-big-endian? #f) ; endianness to use -(define asm-code-stream #f) ; current code stream - -(define (asm-make-stream) ; create an empty stream - (let ((x (cons '() '()))) - (set-car! x x) - x)) - -(define (asm-code-extend item) ; add an item at the end of current code stream - (let* ((stream asm-code-stream) - (tail (car stream)) - (cell (cons item '()))) - (set-cdr! tail cell) - (set-car! stream cell))) - -(define (asm-pass1) ; construct fixup list and make first label assignment - (let loop ((curr (cdr asm-code-stream)) - (fixup-lst '()) - (span 0) - (pos asm-start-pos)) - (if (null? curr) - (reverse fixup-lst) - (let ((x (car curr))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (cond ((eq? kind 'LABEL) - (vector-set! x 1 pos) ; first approximation of position - (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos)) - ((eq? kind 'DEFERRED) - (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos)) - (else - (loop (cdr curr) fixup-lst span pos)))) - (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1))))))) - -;(##declare (generic)) - -(define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer - (modulo n #x100)) - -(define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer - (if (>= n 0) - (quotient n #x100) - (- (quotient (+ n 1) #x100) 1))) - -(define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer - (if (>= n 0) - (quotient n #x10000) - (- (quotient (+ n 1) #x10000) 1))) - -(define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer - (if (>= n 0) - (quotient n #x100000000) - (- (quotient (+ n 1) #x100000000) 1))) - -; The following procedures convert floating point numbers into their -; machine representation. They perform bignum and flonum arithmetic. - -(define (asm-float->inexact-exponential-format x) - - (define (exp-form-pos x y i) - (let ((i*2 (+ i i))) - (let ((z (if (and (not (< asm-ieee-e-bias i*2)) - (not (< x y))) - (exp-form-pos x (* y y) i*2) - (cons x 0)))) - (let ((a (car z)) (b (cdr z))) - (let ((i+b (+ i b))) - (if (and (not (< asm-ieee-e-bias i+b)) - (not (< a y))) - (begin - (set-car! z (/ a y)) - (set-cdr! z i+b))) - z))))) - - (define (exp-form-neg x y i) - (let ((i*2 (+ i i))) - (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1) - (< x y)) - (exp-form-neg x (* y y) i*2) - (cons x 0)))) - (let ((a (car z)) (b (cdr z))) - (let ((i+b (+ i b))) - (if (and (< i+b asm-ieee-e-bias-minus-1) - (< a y)) - (begin - (set-car! z (/ a y)) - (set-cdr! z i+b))) - z))))) - - (define (exp-form x) - (if (< x asm-inexact-+1) - (let ((z (exp-form-neg x asm-inexact-+1/2 1))) - (set-car! z (* asm-inexact-+2 (car z))) - (set-cdr! z (- -1 (cdr z))) - z) - (exp-form-pos x asm-inexact-+2 1))) - - (if (negative? x) - (let ((z (exp-form (- asm-inexact-0 x)))) - (set-car! z (- asm-inexact-0 (car z))) - z) - (exp-form x))) - -(define (asm-float->exact-exponential-format x) - (let ((z (asm-float->inexact-exponential-format x))) - (let ((y (car z))) - (cond ((not (< y asm-inexact-+2)) - (set-car! z asm-ieee-+m-min) - (set-cdr! z asm-ieee-e-bias-plus-1)) - ((not (< asm-inexact--2 y)) - (set-car! z asm-ieee--m-min) - (set-cdr! z asm-ieee-e-bias-plus-1)) - (else - (set-car! z - (truncate (inexact->exact (* (car z) asm-inexact-m-min)))))) - (set-cdr! z (- (cdr z) asm-ieee-m-bits)) - z))) - -(define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x" - - (define (bits a b) - (if (< a asm-ieee-+m-min) - a - (+ (- a asm-ieee-+m-min) - (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias) - asm-ieee-+m-min)))) - - (let ((z (asm-float->exact-exponential-format x))) - (let ((a (car z)) (b (cdr z))) - (if (negative? a) - (+ asm-ieee-sign-bit (bits (- 0 a) b)) - (bits a b))))) - -; Parameters for ANSI-IEEE Std 754-1985 representation of -; doubles (i.e. 64 bit floating point numbers): - -(define asm-ieee-m-bits 52) -(define asm-ieee-e-bits 11) -(define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits) -(define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min) -(define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits)) - -(define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1) -(define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1) -(define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1) - -(define asm-inexact-m-min (exact->inexact asm-ieee-+m-min)) -(define asm-inexact-+2 (exact->inexact 2)) -(define asm-inexact--2 (exact->inexact -2)) -(define asm-inexact-+1 (exact->inexact 1)) -(define asm-inexact-+1/2 (exact->inexact (/ 1 2))) -(define asm-inexact-0 (exact->inexact 0)) - -;------------------------------------------------------------------------------ - -(define min-fixnum-encoding 3) -(define min-fixnum -5) -(define max-fixnum 40) -(define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1)) -(define min-ram-encoding 128) ;; TODO change ? -(define max-ram-encoding 8191) - -(define code-start #x2000) - -(define (predef-constants) (list)) - -(define (predef-globals) (list)) - -(define (encode-direct obj) - (cond ((eq? obj #f) - 0) - ((eq? obj #t) - 1) - ((eq? obj '()) - 2) - ((and (integer? obj) - (exact? obj) - (>= obj min-fixnum) - (<= obj max-fixnum)) - (+ obj (- min-fixnum-encoding min-fixnum))) - (else - #f))) - -(define (translate-constant obj) - (if (char? obj) - (char->integer obj) - obj)) - -(define (encode-constant obj constants) ;; TODO FOOBAR, this should return a 12 bit value - (let ((o (translate-constant obj))) - (let ((e (encode-direct o))) - (if e - e - (let ((x (assq o constants))) - (if x - (vector-ref (cdr x) 0) - (compiler-error "unknown object" obj))))))) - -(define (add-constant obj constants from-code? cont) - (let ((o (translate-constant obj))) - (let ((e (encode-direct o))) - (if e - (cont constants) - (let ((x (assq o constants))) - (if x - (begin - (if from-code? - (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1))) - (cont constants)) - (let* ((descr - (vector #f - (asm-make-label 'constant) - (if from-code? 1 0) - #f)) - (new-constants - (cons (cons o descr) - constants))) - (cond ((pair? o) - (add-constants (list (car o) (cdr o)) - new-constants - cont)) - ((symbol? o) - (cont new-constants)) - ((string? o) - (let ((chars (map char->integer (string->list o)))) - (vector-set! descr 3 chars) - (add-constant chars - new-constants - #f - cont))) - ((vector? o) - (let ((elems (vector->list o))) - (vector-set! descr 3 elems) - (add-constant elems - new-constants - #f - cont))) - - (else - (cont new-constants)))))))))) - -(define (add-constants objs constants cont) - (if (null? objs) - (cont constants) - (add-constant (car objs) - constants - #f - (lambda (new-constants) - (add-constants (cdr objs) - new-constants - cont))))) - -(define (add-global var globals cont) - (let ((x (assq var globals))) - (if x - (cont globals) - (let ((new-globals - (cons (cons var (length globals)) - globals))) - (cont new-globals))))) - -(define (sort-constants constants) - (let ((csts - (sort-list constants - (lambda (x y) - (> (vector-ref (cdr x) 2) - (vector-ref (cdr y) 2)))))) - (let loop ((i min-rom-encoding) - (lst csts)) - (if (null? lst) - (if (> i min-ram-encoding) - (compiler-error "too many constants") - csts) ;; TODO do some constant propagation, actually, more for globals ? - (begin - (vector-set! (cdr (car lst)) 0 i) - (loop (+ i 1) - (cdr lst))))))) - -(define assemble - (lambda (code hex-filename) - (let loop1 ((lst code) - (constants (predef-constants)) - (globals (predef-globals)) - (labels (list))) - (if (pair? lst) - - (let ((instr (car lst))) - (cond ((number? instr) - (loop1 (cdr lst) - constants - globals - (cons (cons instr (asm-make-label 'label)) - labels))) - ((eq? (car instr) 'push-constant) - (add-constant (cadr instr) - constants - #t - (lambda (new-constants) - (loop1 (cdr lst) - new-constants - globals - labels)))) - ((memq (car instr) '(push-global set-global)) - (add-global (cadr instr) - globals - (lambda (new-globals) - (loop1 (cdr lst) - constants - new-globals - labels)))) - (else - (loop1 (cdr lst) - constants - globals - labels)))) - - (let ((constants (sort-constants constants))) - - (define (label-instr label opcode) - (asm-at-assembly - (lambda (self) - 2) - (lambda (self) - (let ((pos (- (asm-label-pos label) code-start))) - (asm-8 (+ (quotient pos 256) opcode)) - (asm-8 (modulo pos 256)))))) - - (define (push-constant n) - (if (<= n 31) - (asm-8 (+ #x00 n)) - (begin - (asm-8 #xfc) - (asm-8 n)))) - - (define (push-stack n) - (if (> n 31) - (compiler-error "stack is too deep") - (asm-8 (+ #x20 n)))) - - (define (push-global n) - (asm-8 (+ #x40 n)) ;; TODO we are actually limited to 16 constants, since we only have 4 bits to represent them - ;; (if (> n 15) ;; ADDED prevented the stack from compiling - ;; (compiler-error "too many global variables") - ;; (asm-8 (+ #x40 n))) - ) ;; TODO actually inline most, or put as csts - - (define (set-global n) - (asm-8 (+ #x50 n)) - ;; (if (> n 15) ;; ADDED prevented the stack from compiling - ;; (compiler-error "too many global variables") - ;; (asm-8 (+ #x50 n))) - ) - - (define (call n) - (if (> n 15) - (compiler-error "call has too many arguments") - (asm-8 (+ #x60 n)))) - - (define (jump n) - (if (> n 15) - (compiler-error "call has too many arguments") - (asm-8 (+ #x70 n)))) - - (define (call-toplevel label) - (label-instr label #x80)) - - (define (jump-toplevel label) - (label-instr label #x90)) - - (define (goto label) - (label-instr label #xa0)) - - (define (goto-if-false label) - (label-instr label #xb0)) - - (define (closure label) - (label-instr label #xc0)) - - (define (prim n) - (asm-8 (+ #xd0 n))) - - (define (prim.number?) (prim 0)) - (define (prim.+) (prim 1)) - (define (prim.-) (prim 2)) - (define (prim.*) (prim 3)) - (define (prim.quotient) (prim 4)) - (define (prim.remainder) (prim 5)) - (define (prim.neg) (prim 6)) - (define (prim.=) (prim 7)) - (define (prim.<) (prim 8)) - (define (prim.ior) (prim 9)) ;; ADDED - (define (prim.>) (prim 10)) - (define (prim.xor) (prim 11)) ;; ADDED - (define (prim.pair?) (prim 12)) - (define (prim.cons) (prim 13)) - (define (prim.car) (prim 14)) - (define (prim.cdr) (prim 15)) - (define (prim.set-car!) (prim 16)) - (define (prim.set-cdr!) (prim 17)) - (define (prim.null?) (prim 18)) - (define (prim.eq?) (prim 19)) - (define (prim.not) (prim 20)) - (define (prim.get-cont) (prim 21)) - (define (prim.graft-to-cont) (prim 22)) - (define (prim.return-to-cont) (prim 23)) - (define (prim.halt) (prim 24)) - (define (prim.symbol?) (prim 25)) - (define (prim.string?) (prim 26)) - (define (prim.string->list) (prim 27)) - (define (prim.list->string) (prim 28)) - (define (prim.set-fst!) (prim 29)) ;; ADDED - (define (prim.set-snd!) (prim 30)) ;; ADDED - (define (prim.set-trd!) (prim 31)) ;; ADDED - - (define (prim.print) (prim 32)) - (define (prim.clock) (prim 33)) - (define (prim.motor) (prim 34)) - (define (prim.led) (prim 35)) - (define (prim.getchar-wait) (prim 36)) - (define (prim.putchar) (prim 37)) - (define (prim.light) (prim 38)) - - (define (prim.triplet?) (prim 39)) ;; ADDED - (define (prim.triplet) (prim 40)) ;; ADDED - (define (prim.fst) (prim 41)) ;; ADDED - (define (prim.snd) (prim 42)) ;; ADDED - (define (prim.trd) (prim 43)) ;; ADDED - - (define (prim.shift) (prim 45)) - (define (prim.pop) (prim 46)) - (define (prim.return) (prim 47)) - - (define big-endian? #f) - - (asm-begin! code-start #f) - - (asm-8 #xfb) - (asm-8 #xd7) - (asm-8 (length constants)) ;; TODO maybe more constants ? that would mean more rom adress space, and less for ram, for now we are ok - (asm-8 0) - - (pp (list constants: constants globals: globals)) ;; TODO debug - - (for-each - (lambda (x) - (let* ((descr (cdr x)) - (label (vector-ref descr 1)) - (obj (car x))) - (asm-label label) - (cond ((and (integer? obj) (exact? obj)) - (asm-8 0) - (asm-8 (bitwise-and (arithmetic-shift obj -16) 255)) - (asm-8 (bitwise-and (arithmetic-shift obj -8) 255)) - (asm-8 (bitwise-and obj 255))) - ((pair? obj) ;; TODO this is ok no matter how many csts we have - (let ((obj-car (encode-constant (car obj) constants)) - (obj-cdr (encode-constant (cdr obj) constants))) - ;; car and cdr are both represented in 12 bits, the - ;; center byte being shared between the 2 - ;; TODO changed - (asm-8 2) - (asm-8 - (arithmetic-shift (bitwise-and obj-car #xff0) -4)) - (asm-8 - (bitwise-ior (arithmetic-shift - (bitwise-and obj-car #xf) - 4) - (arithmetic-shift - (bitwise-and obj-cdr #xf00) - -8))) - (asm-8 (bitwise-and obj-cdr #xff)))) - ((symbol? obj) - (asm-8 3) - (asm-8 0) - (asm-8 0) - (asm-8 0)) - ((string? obj) - (let ((obj-enc (encode-constant (vector-ref descr 3) - constants))) - (asm-8 4) ;; TODO changed - (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0) - -4)) - (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf) - 4)) - (asm-8 0))) - ((vector? obj) - (let ((obj-enc (encode-constant (vector-ref descr 3) - constants))) - (asm-8 5) ;; TODO changed, and factor code - (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0) - -4)) - (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf) - 4)) - (asm-8 0))) - (else - (compiler-error "unknown object type" obj))))) - constants) - - (let loop2 ((lst code)) - (if (pair? lst) - (let ((instr (car lst))) - - (cond ((number? instr) - (let ((label (cdr (assq instr labels)))) - (asm-label label))) - - ((eq? (car instr) 'entry) - (let ((np (cadr instr)) - (rest? (caddr instr))) - (asm-8 (if rest? (- np) np)))) - - ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now - (let ((n (encode-constant (cadr instr) constants))) - (push-constant n))) - - ((eq? (car instr) 'push-stack) - (push-stack (cadr instr))) - - ((eq? (car instr) 'push-global) - (push-global (cdr (assq (cadr instr) globals)))) - - ((eq? (car instr) 'set-global) - (set-global (cdr (assq (cadr instr) globals)))) - - ((eq? (car instr) 'call) - (call (cadr instr))) - - ((eq? (car instr) 'jump) - (jump (cadr instr))) - - ((eq? (car instr) 'call-toplevel) - (let ((label (cdr (assq (cadr instr) labels)))) - (call-toplevel label))) - - ((eq? (car instr) 'jump-toplevel) - (let ((label (cdr (assq (cadr instr) labels)))) - (jump-toplevel label))) - - ((eq? (car instr) 'goto) - (let ((label (cdr (assq (cadr instr) labels)))) - (goto label))) - - ((eq? (car instr) 'goto-if-false) - (let ((label (cdr (assq (cadr instr) labels)))) - (goto-if-false label))) - - ((eq? (car instr) 'closure) - (let ((label (cdr (assq (cadr instr) labels)))) - (closure label))) - - ((eq? (car instr) 'prim) - (case (cadr instr) - ((#%number?) (prim.number?)) - ((#%+) (prim.+)) - ((#%-) (prim.-)) - ((#%*) (prim.*)) - ((#%quotient) (prim.quotient)) - ((#%remainder) (prim.remainder)) - ((#%neg) (prim.neg)) - ((#%=) (prim.=)) - ((#%<) (prim.<)) - ((#%ior) (prim.ior)) ;; ADDED - ((#%>) (prim.>)) - ((#%xor) (prim.xor)) ;; ADDED - ((#%pair?) (prim.pair?)) - ((#%cons) (prim.cons)) - ((#%car) (prim.car)) - ((#%cdr) (prim.cdr)) - ((#%set-car!) (prim.set-car!)) - ((#%set-cdr!) (prim.set-cdr!)) - ((#%null?) (prim.null?)) - ((#%eq?) (prim.eq?)) - ((#%not) (prim.not)) - ((#%get-cont) (prim.get-cont)) - ((#%graft-to-cont) (prim.graft-to-cont)) - ((#%return-to-cont) (prim.return-to-cont)) - ((#%halt) (prim.halt)) - ((#%symbol?) (prim.symbol?)) - ((#%string?) (prim.string?)) - ((#%string->list) (prim.string->list)) - ((#%list->string) (prim.list->string)) - ((#%set-fst!) (prim.set-fst!)) ;; ADDED - ((#%set-snd!) (prim.set-snd!)) ;; ADDED - ((#%set-trd!) (prim.set-trd!)) ;; ADDED - - ((#%print) (prim.print)) - ((#%clock) (prim.clock)) - ((#%motor) (prim.motor)) - ((#%led) (prim.led)) - ((#%getchar-wait) (prim.getchar-wait)) - ((#%putchar) (prim.putchar)) - ((#%light) (prim.light)) - - ((#%triplet?) (prim.triplet?)) ;; ADDED - ((#%triplet) (prim.triplet)) ;; ADDED - ((#%fst) (prim.fst)) ;; ADDED - ((#%snd) (prim.snd)) ;; ADDED - ((#%trd) (prim.trd)) ;; ADDED - (else - (compiler-error "unknown primitive" (cadr instr))))) - - ((eq? (car instr) 'return) - (prim.return)) - - ((eq? (car instr) 'pop) - (prim.pop)) - - ((eq? (car instr) 'shift) - (prim.shift)) - - (else - (compiler-error "unknown instruction" instr))) - - (loop2 (cdr lst))))) - - (asm-assemble) - - (asm-write-hex-file hex-filename) - - (asm-end!)))))) - -(define execute - (lambda (hex-filename) -' - (if #f - (begin - (shell-command "gcc -o picobit-vm picobit-vm.c") - (shell-command (string-append "./picobit-vm " hex-filename))) - (shell-command (string-append "./robot . 1 " hex-filename))))) - -(define (sort-list l expr node)) - - (let ((ctx (comp-none node (make-init-context)))) - (let ((prog (linearize (optimize-code (context-code ctx))))) -; (pp (list code: prog env: (context-env ctx))) - (assemble prog hex-filename) - (execute hex-filename)))))) - - -(define main - (lambda (filename) - (compile filename))) - -;------------------------------------------------------------------------------ - -' -(define (asm-write-hex-file filename) - (with-output-to-file filename - (lambda () - - (define (print-hex n) - (display (string-ref "0123456789ABCDEF" n))) - - (define (print-byte n) - (display ", 0x") - (print-hex (quotient n 16)) - (print-hex (modulo n 16))) - - (define (print-line type addr bytes) - (let ((n (length bytes)) - (addr-hi (quotient addr 256)) - (addr-lo (modulo addr 256))) -; (display ":") -; (print-byte n) -; (print-byte addr-hi) -; (print-byte addr-lo) -; (print-byte type) - (for-each print-byte bytes) - (let ((sum - (modulo (- (apply + n addr-hi addr-lo type bytes)) 256))) -; (print-byte sum) - (newline)))) - - (let loop ((lst (cdr asm-code-stream)) - (pos asm-start-pos) - (rev-bytes '())) - (if (not (null? lst)) - (let ((x (car lst))) - (if (vector? x) - (let ((kind (vector-ref x 0))) - (if (not (eq? kind 'LISTING)) - (compiler-internal-error - "asm-write-hex-file, code stream not assembled")) - (loop (cdr lst) - pos - rev-bytes)) - (let ((new-pos - (+ pos 1)) - (new-rev-bytes - (cons x - (if (= (modulo pos 8) 0) - (begin - (print-line 0 - (- pos (length rev-bytes)) - (reverse rev-bytes)) - '()) - rev-bytes)))) - (loop (cdr lst) - new-pos - new-rev-bytes)))) - (begin - (if (not (null? rev-bytes)) - (print-line 0 - (- pos (length rev-bytes)) - (reverse rev-bytes))) - (print-line 1 0 '()))))))) +; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley> + +; Copyright (C) 2006 by Marc Feeley, All Rights Reserved. + +(define-macro (dummy) + (proper-tail-calls-set! #f) + #f) +;(dummy) + +;----------------------------------------------------------------------------- + +(define compiler-error + (lambda (msg . others) + (display "*** ERROR -- ") + (display msg) + (for-each (lambda (x) (display " ") (write x)) others) + (newline) + (exit 1))) + +;----------------------------------------------------------------------------- + +(define keep + (lambda (keep? lst) + (cond ((null? lst) '()) + ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst)))) + (else (keep keep? (cdr lst)))))) + +(define take + (lambda (n lst) + (if (> n 0) + (cons (car lst) (take (- n 1) (cdr lst))) + '()))) + +(define drop + (lambda (n lst) + (if (> n 0) + (drop (- n 1) (cdr lst)) + lst))) + +(define repeat + (lambda (n x) + (if (> n 0) + (cons x (repeat (- n 1) x)) + '()))) + +(define pos-in-list + (lambda (x lst) + (let loop ((lst lst) (i 0)) + (cond ((not (pair? lst)) #f) + ((eq? (car lst) x) i) + (else (loop (cdr lst) (+ i 1))))))) + +(define every + (lambda (pred? lst) + (or (null? lst) + (and (pred? (car lst)) + (every pred? (cdr lst)))))) + +;----------------------------------------------------------------------------- + +(load "node.scm") + +;----------------------------------------------------------------------------- + +(load "env.scm") + +;----------------------------------------------------------------------------- + +(load "parser.scm") + +;----------------------------------------------------------------------------- + +(load "context.scm") + +;----------------------------------------------------------------------------- + +(load "gen.scm") + +;----------------------------------------------------------------------------- + +(load "comp.scm") + +;----------------------------------------------------------------------------- + +(load "mutable.scm") + +;----------------------------------------------------------------------------- + +(load "varset.scm") + +;------------------------------------------------------------------------------ + +(define code->vector + (lambda (code) + (let ((v (make-vector (+ (code-last-label code) 1)))) + (for-each + (lambda (bb) + (vector-set! v (bb-label bb) bb)) + (code-rev-bbs code)) + v))) + +(define bbs->ref-counts + (lambda (bbs) + (let ((ref-counts (make-vector (vector-length bbs) 0))) + + (define visit + (lambda (label) + (let ((ref-count (vector-ref ref-counts label))) + (vector-set! ref-counts label (+ ref-count 1)) + (if (= ref-count 0) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb))) + (for-each + (lambda (instr) + (let ((opcode (car instr))) + (cond ((eq? opcode 'goto) + (visit (cadr instr))) + ((eq? opcode 'goto-if-false) + (visit (cadr instr)) + (visit (caddr instr))) + ((or (eq? opcode 'closure) + (eq? opcode 'call-toplevel) + (eq? opcode 'jump-toplevel)) + (visit (cadr instr)))))) + rev-instrs)))))) + + (visit 0) + + ref-counts))) + +(define resolve-toplevel-labels! + (lambda (bbs) + (let loop ((i 0)) + (if (< i (vector-length bbs)) + (let* ((bb (vector-ref bbs i)) + (rev-instrs (bb-rev-instrs bb))) + (bb-rev-instrs-set! + bb + (map (lambda (instr) + (let ((opcode (car instr))) + (cond ((eq? opcode 'call-toplevel) + (list opcode + (prc-entry-label (cadr instr)))) + ((eq? opcode 'jump-toplevel) + (list opcode + (prc-entry-label (cadr instr)))) + (else + instr)))) + rev-instrs)) + (loop (+ i 1))))))) + +(define tighten-jump-cascades! + (lambda (bbs) + (let ((ref-counts (bbs->ref-counts bbs))) + + (define resolve + (lambda (label) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb))) + (and (or (null? (cdr rev-instrs)) + (= (vector-ref ref-counts label) 1)) + rev-instrs)))) + + (let loop1 () + (let loop2 ((i 0) + (changed? #f)) + (if (< i (vector-length bbs)) + (if (> (vector-ref ref-counts i) 0) + (let* ((bb (vector-ref bbs i)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump))) + (cond ((eq? opcode 'goto) + (let* ((label (cadr jump)) + (jump-replacement (resolve label))) + (if jump-replacement + (begin + (vector-set! + bbs + i + (make-bb (bb-label bb) + (append jump-replacement + (cdr rev-instrs)))) + (loop2 (+ i 1) + #t)) + (loop2 (+ i 1) + changed?)))) + ((eq? opcode 'goto-if-false) + (let* ((label-then (cadr jump)) + (label-else (caddr jump)) + (jump-then-replacement (resolve label-then)) + (jump-else-replacement (resolve label-else))) + (if (and jump-then-replacement + (null? (cdr jump-then-replacement)) + jump-else-replacement + (null? (cdr jump-else-replacement)) + (or (eq? (caar jump-then-replacement) 'goto) + (eq? (caar jump-else-replacement) 'goto))) + (begin + (vector-set! + bbs + i + (make-bb (bb-label bb) + (cons (list 'goto-if-false + (if (eq? (caar jump-then-replacement) 'goto) + (cadar jump-then-replacement) + label-then) + (if (eq? (caar jump-else-replacement) 'goto) + (cadar jump-else-replacement) + label-else)) + (cdr rev-instrs)))) + (loop2 (+ i 1) + #t)) + (loop2 (+ i 1) + changed?)))) + (else + (loop2 (+ i 1) + changed?)))) + (loop2 (+ i 1) + changed?)) + (if changed? + (loop1)))))))) + +(define remove-useless-bbs! + (lambda (bbs) + (let ((ref-counts (bbs->ref-counts bbs))) + (let loop1 ((label 0) (new-label 0)) + (if (< label (vector-length bbs)) + (if (> (vector-ref ref-counts label) 0) + (let ((bb (vector-ref bbs label))) + (vector-set! + bbs + label + (make-bb new-label (bb-rev-instrs bb))) + (loop1 (+ label 1) (+ new-label 1))) + (loop1 (+ label 1) new-label)) + (renumber-labels bbs ref-counts new-label)))))) + +(define renumber-labels + (lambda (bbs ref-counts n) + (let ((new-bbs (make-vector n))) + (let loop2 ((label 0)) + (if (< label (vector-length bbs)) + (if (> (vector-ref ref-counts label) 0) + (let* ((bb (vector-ref bbs label)) + (new-label (bb-label bb)) + (rev-instrs (bb-rev-instrs bb))) + + (define fix + (lambda (instr) + + (define new-label + (lambda (label) + (bb-label (vector-ref bbs label)))) + + (let ((opcode (car instr))) + (cond ((eq? opcode 'closure) + (list 'closure + (new-label (cadr instr)))) + ((eq? opcode 'call-toplevel) + (list 'call-toplevel + (new-label (cadr instr)))) + ((eq? opcode 'jump-toplevel) + (list 'jump-toplevel + (new-label (cadr instr)))) + ((eq? opcode 'goto) + (list 'goto + (new-label (cadr instr)))) + ((eq? opcode 'goto-if-false) + (list 'goto-if-false + (new-label (cadr instr)) + (new-label (caddr instr)))) + (else + instr))))) + + (vector-set! + new-bbs + new-label + (make-bb new-label (map fix rev-instrs))) + (loop2 (+ label 1))) + (loop2 (+ label 1))) + new-bbs))))) + +(define reorder! + (lambda (bbs) + (let* ((done (make-vector (vector-length bbs) #f))) + + (define unscheduled? + (lambda (label) + (not (vector-ref done label)))) + + (define label-refs + (lambda (instrs todo) + (if (pair? instrs) + (let* ((instr (car instrs)) + (opcode (car instr))) + (cond ((or (eq? opcode 'closure) + (eq? opcode 'call-toplevel) + (eq? opcode 'jump-toplevel)) + (label-refs (cdr instrs) (cons (cadr instr) todo))) + (else + (label-refs (cdr instrs) todo)))) + todo))) + + (define schedule-here + (lambda (label new-label todo cont) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump)) + (new-todo (label-refs rev-instrs todo))) + (vector-set! bbs label (make-bb new-label rev-instrs)) + (vector-set! done label #t) + (cond ((eq? opcode 'goto) + (let ((label (cadr jump))) + (if (unscheduled? label) + (schedule-here label + (+ new-label 1) + new-todo + cont) + (cont (+ new-label 1) + new-todo)))) + ((eq? opcode 'goto-if-false) + (let ((label-then (cadr jump)) + (label-else (caddr jump))) + (cond ((unscheduled? label-else) + (schedule-here label-else + (+ new-label 1) + (cons label-then new-todo) + cont)) + ((unscheduled? label-then) + (schedule-here label-then + (+ new-label 1) + new-todo + cont)) + (else + (cont (+ new-label 1) + new-todo))))) + (else + (cont (+ new-label 1) + new-todo)))))) + + (define schedule-somewhere + (lambda (label new-label todo cont) + (schedule-here label new-label todo cont))) + + (define schedule-todo + (lambda (new-label todo) + (if (pair? todo) + (let ((label (car todo))) + (if (unscheduled? label) + (schedule-somewhere label + new-label + (cdr todo) + schedule-todo) + (schedule-todo new-label + (cdr todo))))))) + + + (schedule-here 0 0 '() schedule-todo) + + (renumber-labels bbs + (make-vector (vector-length bbs) 1) + (vector-length bbs))))) + +(define linearize + (lambda (bbs) + (let loop ((label (- (vector-length bbs) 1)) + (lst '())) + (if (>= label 0) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump))) + (loop (- label 1) + (append + (list label) + (reverse + (cond ((eq? opcode 'goto) + (if (= (cadr jump) (+ label 1)) + (cdr rev-instrs) + rev-instrs)) + ((eq? opcode 'goto-if-false) + (cond ((= (caddr jump) (+ label 1)) + (cons (list 'goto-if-false (cadr jump)) + (cdr rev-instrs))) + ((= (cadr jump) (+ label 1)) + (cons (list 'goto-if-not-false (caddr jump)) + (cdr rev-instrs))) + (else + (cons (list 'goto (caddr jump)) + (cons (list 'goto-if-false (cadr jump)) + (cdr rev-instrs)))))) + (else + rev-instrs))) + lst))) + lst)))) + +(define optimize-code + (lambda (code) + (let ((bbs (code->vector code))) + (resolve-toplevel-labels! bbs) + (tighten-jump-cascades! bbs) + (let ((bbs (remove-useless-bbs! bbs))) + (reorder! bbs))))) + +(define expand-loads ;; ADDED + (lambda (exprs) + (map (lambda (e) + (if (eq? (car e) 'load) + (cons 'begin + (expand-loads (with-input-from-file (cadr e) read-all))) + e)) + exprs))) + +(define parse-file + (lambda (filename) + (let* ((library + (with-input-from-file "library.scm" read-all)) + (toplevel-exprs + (expand-loads (append library ;; ADDED (didn't have expand-loads) + (with-input-from-file filename read-all)))) + (global-env + (make-global-env)) + (parsed-prog + (parse-top (cons 'begin toplevel-exprs) global-env))) + + (for-each + (lambda (node) + (mark-needed-global-vars! global-env node)) + parsed-prog) + + (extract-parts + parsed-prog + (lambda (defs after-defs) + + (define make-seq-preparsed + (lambda (exprs) + (let ((r (make-seq #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r))) + + (define make-call-preparsed + (lambda (exprs) + (let ((r (make-call #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r))) + + (if (var-needed? + (env-lookup global-env '#%readyq)) + (make-seq-preparsed + (list (make-seq-preparsed defs) + (make-call-preparsed + (list (parse 'value '#%start-first-process global-env) + (let* ((pattern + '()) + (ids + (extract-ids pattern)) + (r + (make-prc #f '() #f (has-rest-param? pattern) #f)) + (new-env + (env-extend global-env ids r)) + (body + (make-seq-preparsed after-defs))) + (prc-params-set! + r + (map (lambda (id) (env-lookup new-env id)) + ids)) + (node-children-set! r (list body)) + (node-parent-set! body r) + r))) + (parse 'value + '(#%exit) + global-env))) + (make-seq-preparsed + (append defs + after-defs + (list (parse 'value + '(#%halt) + global-env)))))))))) + +(define extract-parts + (lambda (lst cont) + (if (or (null? lst) + (not (def? (car lst)))) + (cont '() lst) + (extract-parts + (cdr lst) + (lambda (d ad) + (cont (cons (car lst) d) ad)))))) + +;------------------------------------------------------------------------------ + +(load "asm.scm") + +;------------------------------------------------------------------------------ + +(load "encode.scm") + +(define assemble + (lambda (code hex-filename) + (let loop1 ((lst code) + (constants (predef-constants)) + (globals (predef-globals)) + (labels (list))) + (if (pair? lst) + + (let ((instr (car lst))) + (cond ((number? instr) + (loop1 (cdr lst) + constants + globals + (cons (cons instr (asm-make-label 'label)) + labels))) + ((eq? (car instr) 'push-constant) + (add-constant (cadr instr) + constants + #t + (lambda (new-constants) + (loop1 (cdr lst) + new-constants + globals + labels)))) + ((memq (car instr) '(push-global set-global)) + (add-global (cadr instr) + globals + (lambda (new-globals) + (loop1 (cdr lst) + constants + new-globals + labels)))) + (else + (loop1 (cdr lst) + constants + globals + labels)))) + + (let ((constants (sort-constants constants))) + + (define (label-instr label opcode) + (asm-at-assembly + (lambda (self) + 2) + (lambda (self) + (let ((pos (- (asm-label-pos label) code-start))) + (asm-8 (+ (quotient pos 256) opcode)) + (asm-8 (modulo pos 256)))))) + + (define (push-constant n) + (if (<= n 31) + (asm-8 (+ #x00 n)) + (begin + (asm-8 #xfc) + (asm-8 n)))) + + (define (push-stack n) + (if (> n 31) + (compiler-error "stack is too deep") + (asm-8 (+ #x20 n)))) + + (define (push-global n) + (asm-8 (+ #x40 n)) ;; TODO we are actually limited to 16 constants, since we only have 4 bits to represent them + ;; (if (> n 15) ;; ADDED prevented the stack from compiling + ;; (compiler-error "too many global variables") + ;; (asm-8 (+ #x40 n))) + ) ;; TODO actually inline most, or put as csts + + (define (set-global n) + (asm-8 (+ #x50 n)) + ;; (if (> n 15) ;; ADDED prevented the stack from compiling + ;; (compiler-error "too many global variables") + ;; (asm-8 (+ #x50 n))) + ) + + (define (call n) + (if (> n 15) + (compiler-error "call has too many arguments") + (asm-8 (+ #x60 n)))) + + (define (jump n) + (if (> n 15) + (compiler-error "call has too many arguments") + (asm-8 (+ #x70 n)))) + + (define (call-toplevel label) + (label-instr label #x80)) + + (define (jump-toplevel label) + (label-instr label #x90)) + + (define (goto label) + (label-instr label #xa0)) + + (define (goto-if-false label) + (label-instr label #xb0)) + + (define (closure label) + (label-instr label #xc0)) + + (define (prim n) + (asm-8 (+ #xd0 n))) + + (define (prim.number?) (prim 0)) + (define (prim.+) (prim 1)) + (define (prim.-) (prim 2)) + (define (prim.*) (prim 3)) + (define (prim.quotient) (prim 4)) + (define (prim.remainder) (prim 5)) + (define (prim.neg) (prim 6)) + (define (prim.=) (prim 7)) + (define (prim.<) (prim 8)) + (define (prim.ior) (prim 9)) ;; ADDED + (define (prim.>) (prim 10)) + (define (prim.xor) (prim 11)) ;; ADDED + (define (prim.pair?) (prim 12)) + (define (prim.cons) (prim 13)) + (define (prim.car) (prim 14)) + (define (prim.cdr) (prim 15)) + (define (prim.set-car!) (prim 16)) + (define (prim.set-cdr!) (prim 17)) + (define (prim.null?) (prim 18)) + (define (prim.eq?) (prim 19)) + (define (prim.not) (prim 20)) + (define (prim.get-cont) (prim 21)) + (define (prim.graft-to-cont) (prim 22)) + (define (prim.return-to-cont) (prim 23)) + (define (prim.halt) (prim 24)) + (define (prim.symbol?) (prim 25)) + (define (prim.string?) (prim 26)) + (define (prim.string->list) (prim 27)) + (define (prim.list->string) (prim 28)) + (define (prim.set-fst!) (prim 29)) ;; ADDED + (define (prim.set-snd!) (prim 30)) ;; ADDED + (define (prim.set-trd!) (prim 31)) ;; ADDED + + (define (prim.print) (prim 32)) + (define (prim.clock) (prim 33)) + (define (prim.motor) (prim 34)) + (define (prim.led) (prim 35)) + (define (prim.getchar-wait) (prim 36)) + (define (prim.putchar) (prim 37)) + (define (prim.light) (prim 38)) + + (define (prim.triplet?) (prim 39)) ;; ADDED + (define (prim.triplet) (prim 40)) ;; ADDED + (define (prim.fst) (prim 41)) ;; ADDED + (define (prim.snd) (prim 42)) ;; ADDED + (define (prim.trd) (prim 43)) ;; ADDED + + (define (prim.shift) (prim 45)) + (define (prim.pop) (prim 46)) + (define (prim.return) (prim 47)) + + (define big-endian? #f) + + (asm-begin! code-start #f) + + (asm-8 #xfb) + (asm-8 #xd7) + (asm-8 (length constants)) ;; TODO maybe more constants ? that would mean more rom adress space, and less for ram, for now we are ok + (asm-8 0) + + (pp (list constants: constants globals: globals)) ;; TODO debug + + (for-each + (lambda (x) + (let* ((descr (cdr x)) + (label (vector-ref descr 1)) + (obj (car x))) + (asm-label label) + (cond ((and (integer? obj) (exact? obj)) + (asm-8 0) + (asm-8 (bitwise-and (arithmetic-shift obj -16) 255)) + (asm-8 (bitwise-and (arithmetic-shift obj -8) 255)) + (asm-8 (bitwise-and obj 255))) + ((pair? obj) ;; TODO this is ok no matter how many csts we have + (let ((obj-car (encode-constant (car obj) constants)) + (obj-cdr (encode-constant (cdr obj) constants))) + ;; car and cdr are both represented in 12 bits, the + ;; center byte being shared between the 2 + ;; TODO changed + (asm-8 2) + (asm-8 + (arithmetic-shift (bitwise-and obj-car #xff0) -4)) + (asm-8 + (bitwise-ior (arithmetic-shift + (bitwise-and obj-car #xf) + 4) + (arithmetic-shift + (bitwise-and obj-cdr #xf00) + -8))) + (asm-8 (bitwise-and obj-cdr #xff)))) + ((symbol? obj) + (asm-8 3) + (asm-8 0) + (asm-8 0) + (asm-8 0)) + ((string? obj) + (let ((obj-enc (encode-constant (vector-ref descr 3) + constants))) + (asm-8 4) ;; TODO changed + (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0) + -4)) + (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf) + 4)) + (asm-8 0))) + ((vector? obj) + (let ((obj-enc (encode-constant (vector-ref descr 3) + constants))) + (asm-8 5) ;; TODO changed, and factor code + (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0) + -4)) + (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf) + 4)) + (asm-8 0))) + (else + (compiler-error "unknown object type" obj))))) + constants) + + (let loop2 ((lst code)) + (if (pair? lst) + (let ((instr (car lst))) + + (cond ((number? instr) + (let ((label (cdr (assq instr labels)))) + (asm-label label))) + + ((eq? (car instr) 'entry) + (let ((np (cadr instr)) + (rest? (caddr instr))) + (asm-8 (if rest? (- np) np)))) + + ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now + (let ((n (encode-constant (cadr instr) constants))) + (push-constant n))) + + ((eq? (car instr) 'push-stack) + (push-stack (cadr instr))) + + ((eq? (car instr) 'push-global) + (push-global (cdr (assq (cadr instr) globals)))) + + ((eq? (car instr) 'set-global) + (set-global (cdr (assq (cadr instr) globals)))) + + ((eq? (car instr) 'call) + (call (cadr instr))) + + ((eq? (car instr) 'jump) + (jump (cadr instr))) + + ((eq? (car instr) 'call-toplevel) + (let ((label (cdr (assq (cadr instr) labels)))) + (call-toplevel label))) + + ((eq? (car instr) 'jump-toplevel) + (let ((label (cdr (assq (cadr instr) labels)))) + (jump-toplevel label))) + + ((eq? (car instr) 'goto) + (let ((label (cdr (assq (cadr instr) labels)))) + (goto label))) + + ((eq? (car instr) 'goto-if-false) + (let ((label (cdr (assq (cadr instr) labels)))) + (goto-if-false label))) + + ((eq? (car instr) 'closure) + (let ((label (cdr (assq (cadr instr) labels)))) + (closure label))) + + ((eq? (car instr) 'prim) + (case (cadr instr) + ((#%number?) (prim.number?)) + ((#%+) (prim.+)) + ((#%-) (prim.-)) + ((#%*) (prim.*)) + ((#%quotient) (prim.quotient)) + ((#%remainder) (prim.remainder)) + ((#%neg) (prim.neg)) + ((#%=) (prim.=)) + ((#%<) (prim.<)) + ((#%ior) (prim.ior)) ;; ADDED + ((#%>) (prim.>)) + ((#%xor) (prim.xor)) ;; ADDED + ((#%pair?) (prim.pair?)) + ((#%cons) (prim.cons)) + ((#%car) (prim.car)) + ((#%cdr) (prim.cdr)) + ((#%set-car!) (prim.set-car!)) + ((#%set-cdr!) (prim.set-cdr!)) + ((#%null?) (prim.null?)) + ((#%eq?) (prim.eq?)) + ((#%not) (prim.not)) + ((#%get-cont) (prim.get-cont)) + ((#%graft-to-cont) (prim.graft-to-cont)) + ((#%return-to-cont) (prim.return-to-cont)) + ((#%halt) (prim.halt)) + ((#%symbol?) (prim.symbol?)) + ((#%string?) (prim.string?)) + ((#%string->list) (prim.string->list)) + ((#%list->string) (prim.list->string)) + ((#%set-fst!) (prim.set-fst!)) ;; ADDED + ((#%set-snd!) (prim.set-snd!)) ;; ADDED + ((#%set-trd!) (prim.set-trd!)) ;; ADDED + + ((#%print) (prim.print)) + ((#%clock) (prim.clock)) + ((#%motor) (prim.motor)) + ((#%led) (prim.led)) + ((#%getchar-wait) (prim.getchar-wait)) + ((#%putchar) (prim.putchar)) + ((#%light) (prim.light)) + + ((#%triplet?) (prim.triplet?)) ;; ADDED + ((#%triplet) (prim.triplet)) ;; ADDED + ((#%fst) (prim.fst)) ;; ADDED + ((#%snd) (prim.snd)) ;; ADDED + ((#%trd) (prim.trd)) ;; ADDED + (else + (compiler-error "unknown primitive" (cadr instr))))) + + ((eq? (car instr) 'return) + (prim.return)) + + ((eq? (car instr) 'pop) + (prim.pop)) + + ((eq? (car instr) 'shift) + (prim.shift)) + + (else + (compiler-error "unknown instruction" instr))) + + (loop2 (cdr lst))))) + + (asm-assemble) + + (asm-write-hex-file hex-filename) + + (asm-end!)))))) + +(define execute + (lambda (hex-filename) +' + (if #f + (begin + (shell-command "gcc -o picobit-vm picobit-vm.c") + (shell-command (string-append "./picobit-vm " hex-filename))) + (shell-command (string-append "./robot . 1 " hex-filename))))) + +(define (sort-list l expr node)) + + (let ((ctx (comp-none node (make-init-context)))) + (let ((prog (linearize (optimize-code (context-code ctx))))) +; (pp (list code: prog env: (context-env ctx))) + (assemble prog hex-filename) + (execute hex-filename)))))) + + +(define main + (lambda (filename) + (compile filename))) + +;------------------------------------------------------------------------------ + +' +(define (asm-write-hex-file filename) + (with-output-to-file filename + (lambda () + + (define (print-hex n) + (display (string-ref "0123456789ABCDEF" n))) + + (define (print-byte n) + (display ", 0x") + (print-hex (quotient n 16)) + (print-hex (modulo n 16))) + + (define (print-line type addr bytes) + (let ((n (length bytes)) + (addr-hi (quotient addr 256)) + (addr-lo (modulo addr 256))) +; (display ":") +; (print-byte n) +; (print-byte addr-hi) +; (print-byte addr-lo) +; (print-byte type) + (for-each print-byte bytes) + (let ((sum + (modulo (- (apply + n addr-hi addr-lo type bytes)) 256))) +; (print-byte sum) + (newline)))) + + (let loop ((lst (cdr asm-code-stream)) + (pos asm-start-pos) + (rev-bytes '())) + (if (not (null? lst)) + (let ((x (car lst))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (if (not (eq? kind 'LISTING)) + (compiler-internal-error + "asm-write-hex-file, code stream not assembled")) + (loop (cdr lst) + pos + rev-bytes)) + (let ((new-pos + (+ pos 1)) + (new-rev-bytes + (cons x + (if (= (modulo pos 8) 0) + (begin + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes)) + '()) + rev-bytes)))) + (loop (cdr lst) + new-pos + new-rev-bytes)))) + (begin + (if (not (null? rev-bytes)) + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes))) + (print-line 1 0 '()))))))) diff --git a/robot.scm b/robot.scm index 4fedae0..0a7c435 100644 --- a/robot.scm +++ b/robot.scm @@ -18,6 +18,7 @@ (define program-start-addr #x2000) (define serial-port-name "com1") ; default, works for Windows +(define serial-port-name "rs232") ; ADDED now to named pipe (let loop ((lst '("/dev/cu.USA28X181P1.1" "/dev/cu.USA28X181P2.2" -- 2.11.4.GIT