diff --git a/src/ikarus.boot b/src/ikarus.boot index 8180a98..ad1c421 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libchezio.ss b/src/libchezio.ss index d17d46e..f56c693 100644 --- a/src/libchezio.ss +++ b/src/libchezio.ss @@ -695,6 +695,14 @@ (error 'get-output-string "~s is not an output port" p)))) ) + (primitive-set! 'with-output-to-string + (lambda (f) + (unless (procedure? f) + (error 'with-output-to-string "~s is not a procedure" f)) + (let ([p (open-output-string)]) + (parameterize ([current-output-port p]) (f)) + (get-output-string p)))) + (primitive-set! 'with-output-to-file (lambda (name proc . args) (unless (string? name) diff --git a/src/libcogen1.ss b/src/libcogen1.ss index 21f6776..aedb26c 100644 --- a/src/libcogen1.ss +++ b/src/libcogen1.ss @@ -115,6 +115,14 @@ ;;; (Program x)) + + + +;;; the program so far includes both primcalls and funcalls to +;;; primrefs. This pass removes all primcalls. Once everything +;;; works, we need to fix all previous passes to eliminate this +;;; whole primcall business. + (define (remove-primcalls x) ;;; (define who 'remove-primcalls) @@ -191,13 +199,346 @@ ;;; ;;; So, what do we want to do here? -;;; +;;; 1. we eliminate all variables: +;;; bind should become a sequence of (setfv i ) statements +;;; variable refs should befome (fv i) where i is the index of +;;; the var on the stack. +;;; 2. we need to keep track of the maximum stack size used; and +;;; whether we made a procedure call so that we can insert a +;;; stack overflow check with an appropriate size check. +;;; 3. as we generate code, we need to keep track of which stack +;;; locations contain pointers so that procedure calls can +;;; set an appropriate mask. +;;; 4. primitives that allocate, as well as closures and fixes +;;; should insert an appropriate alloc-check marks as well as +;;; keep the live masks for the later generation of trap handlers +;;; 5. primcalls should also keep track of liveness information +;;; and frame size just in case the primitive needs to make a +;;; procedure call. + + +(define-record move (src dst)) +(define-record alloc-check (n si live)) +(define-record fvar (idx)) +(define acr '%acr) +(define-record cpvar (idx)) +(define-record cmp (op v0 v1)) +(define false-object 'false-object) + +(define (new-cogen-pass1 x) + ;;; + (define who 'new-cogen-pass-1) + ;;; + (define (fxeven? x) + (if (fixnum? x) + ($fxzero? ($fxlogand x 1)) + (error 'fxeven? "~s is not a fixnum" x))) + ;;; + (define (sum ls) + (let f ([ls ls] [n 0]) + (cond + [(null? ls) n] + [else (f (cdr ls) (fx+ (car ls) n))]))) + ;;; + (define fxmax + (case-lambda + [(x y) (if (fx> x y) x y)] + [(x y z) (fxmax x (fxmax y z))] + [_ (error 'fxmax "unhandled")])) + ;;; + (define (do-seq e0 si live env e1 k) + (let-values ([(e0 msi0 call0?) + (Effect e0 si live env)]) + (let-values ([(e1 msi1 call1?) + (k e1 si live env)]) + (values (make-seq e0 e1) + (fxmax msi0 msi1) + (or call0? call1?))))) + ;;; + (define (do-cond e0 si live env e1 e2 k) + (let-values ([(e0 msi0 call0?) + (Pred e0 si live env)]) + (let-values ([(e1 msi1 call1?) + (k e1 si live env)] + [(e2 msi2 call2?) + (k e2 si live env)]) + (values (make-conditional e0 e1 e2) + (fxmax msi0 msi1 msi2) + (or call0? call1? call2?))))) + ;;; + (define (do-move-to-mem loc expr si live env) + (record-case expr + [(constant) + (values (make-move expr loc) 0 #f)] + [else + (let-values ([(x msi call?) + (Value expr si live env)]) + (values (make-seq x (make-move acr loc)) msi call?))])) + ;;; + (define (do-bind lhs* rhs* si live env0 env body k) + (cond + [(null? lhs*) + (k body si live env)] + [else + (let ([fv (make-fvar si)]) + (let-values ([(e0 msi0 call0?) + (do-move-to-mem fv (car rhs*) si live env0)]) + (let-values ([(e1 msi1 call1?) + (do-bind (cdr lhs*) (cdr rhs*) + (fxadd1 si) + (cons si live) + env0 + (cons (cons (car lhs*) fv) env) + body + k)]) + (values (make-seq e0 e1) + (fxmax msi0 msi1) + (or call0? call1?)))))])) + ;;; + (define (align n) + (cond + [(fxeven? n) n] + [else (fxadd1 n)])) + ;;; + (define (extend-env* lhs* si live env) + (let f ([lhs* lhs*] [si si] [live live] [env env] [nlhs* '()]) + (cond + [(null? lhs*) + (values nlhs* si live env)] + [else + (let ([fv (make-fvar si)]) + (f (cdr lhs*) (fxadd1 si) (cons si live) + (cons (cons (car lhs*) fv) env) + (cons fv nlhs*)))]))) + ;;; + (define (insert-const-alloc-check n si live rest) + (cond + [(fxzero? n) rest] + [else + (make-seq + (make-alloc-check n si live) + rest)])) + ;;; + (define (construct-closures n* lhs* nlhs* rhs* body) + (cond + [(null? lhs*) body] + [else + (make-seq 'FIXME:construct-closures body)])) + ;;; + (define (do-fix lhs* rhs* si live env body k) + (define (compute-closure-size x) + (record-case x + [(closure label free*) + (align (fxadd1 (length free*)))])) + (let ([n* (map compute-closure-size rhs*)]) + (let ([n (sum n*)]) + (let-values ([(nlhs* si live env) + (extend-env* lhs* si live env)]) + (let-values ([(x msi call?) + (k body si live env)]) + (values (insert-const-alloc-check n si live + (construct-closures n* lhs* nlhs* rhs* x)) + msi call?)))))) + ;;; + (define (constant-rep x) + 'FIXME:constant-rep) + ;;; + (define (do-closure label free* si live env) + 'FIXME:do-closure) + ;;; + (define (do-forcall x si live env) + (values 'FIXME:do-forcall si #f)) + ;;; + (define (do-tail-funcall x si live env) + (values 'FIXME:do-tail-funcall si #f)) + ;;; + (define (do-tail-appcall x si live env) + (values 'FIXME:do-tail-appcall si #f)) + ;;; + (define (do-tail-jmpcall x si live env) + (values 'FIXME:do-tail-jmpcall si #f)) + ;;; + (define (do-effect-funcall x si live env) + (values 'FIXME:do-effect-funcall si #f)) + ;;; + (define (do-effect-appcall x si live env) + (values 'FIXME:do-effect-appcall si #f)) + ;;; + (define (do-effect-jmpcall x si live env) + (values 'FIXME:do-effect-jmpcall si #f)) + ;;; + (define (do-value-funcall x si live env) + (values 'FIXME:do-value-funcall si #f)) + ;;; + (define (do-value-appcall x si live env) + (values 'FIXME:do-value-appcall si #f)) + ;;; + (define (do-value-jmpcall x si live env) + (values 'FIXME:do-value-jmpcall si #f)) + ;;; + (define (do-mvcall x si live env k) + (values 'FIXME:do-mvcall si #t)) + ;;; + (define (Var x env) + (cond + [(assq x env) => cdr] + [else (error who "unbound var ~s" x)])) + ;;; + (define (Primref x) + 'FIXME:primref) + ;;; + (define (Value x si live env) + (record-case x + [(constant t) + (values (make-move (constant-rep t) acr) 0 #f)] + [(var) + (values (make-move (Var x env) acr) 0 #f)] + [(primref) + (values (make-move (Primref x) acr) 0 #f)] + [(bind lhs* rhs* body) + (do-bind lhs* rhs* si live env env body Value)] + [(fix lhs* rhs* body) + (do-fix lhs* rhs* si live env body Value)] + [(conditional e0 e1 e2) + (do-cond e0 si live env e1 e2 Value)] + [(seq e0 e1) (do-seq e0 si live env e1 Value)] + [(closure label free*) + (values (do-closure label free* si live env) 0 #f)] + [(forcall) (do-forcall x si live env)] + [(funcall) (do-value-funcall x si live env)] + [(jmpcall) (do-value-jmpcall x si live env)] + [(appcall) (do-value-appcall x si live env)] + [(mvcall) (do-mvcall x si live env Value)] + [else (error who "invalid value expr ~s" x)])) + ;;; + (define (Pred x si live env) + (record-case x + [(constant t) + (values (if t #t #f) 0 #f)] + [(var) (values (make-cmp 'neq (Var x env) false-object) 0 #f)] + [(primref) (values #t 0 #f)] + [(bind lhs* rhs* body) + (do-bind lhs* rhs* si live env env body Pred)] + [(fix lhs* rhs* body) + (do-fix lhs* rhs* si live env body Pred)] + [(conditional e0 e1 e2) + (do-cond e0 si live env e1 e2 Pred)] + [(seq e0 e1) (do-seq e0 si live env e1 Pred)] + [(closure label free*) (values #t 0 #f)] + [(forcall) + (let-values ([(x msi call?) (Value x si live env)]) + (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))] + [(funcall) + (let-values ([(x msi call?) (Value x si live env)]) + (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))] + [(jmpcall) + (let-values ([(x msi call?) (Value x si live env)]) + (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))] + [(appcall) + (let-values ([(x msi call?) (Value x si live env)]) + (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))] + [(mvcall) (do-mvcall x si live env Pred)] + [else (error who "invalid pred expr ~s" x)])) + ;;; + (define (Effect x si live env) + (record-case x + [(constant) (values 'nop 0 #f)] + [(var) (values 'nop 0 #f)] + [(primref) (values 'nop 0 #f)] + [(bind lhs* rhs* body) + (do-bind lhs* rhs* si live env env body Effect)] + [(fix lhs* rhs* body) + (do-fix lhs* rhs* si live env body Effect)] + [(conditional e0 e1 e2) + (do-cond e0 si live env e1 e2 Effect)] + [(seq e0 e1) (do-seq e0 si live env e1 Effect)] + [(closure label free*) (values 'nop 0 #f)] + [(forcall) (do-forcall x si live env)] + [(funcall) (do-effect-funcall x si live env)] + [(jmpcall) (do-effect-jmpcall x si live env)] + [(appcall) (do-effect-appcall x si live env)] + [(mvcall) (do-mvcall x si live env Tail)] + [else (error who "invalid effect expr ~s" x)])) + ;;; + (define (Tail x si live env) + (record-case x + [(constant) (values x si #f)] + [(var) (values (Var x env) si #f)] + [(primref) (values x si #f)] + [(bind lhs* rhs* body) + (do-bind lhs* rhs* si live env env body Tail)] + [(fix lhs* rhs* body) + (do-fix lhs* rhs* si live env body Tail)] + [(conditional e0 e1 e2) + (do-cond e0 si live env e1 e2 Tail)] + [(seq e0 e1) (do-seq e0 si live env e1 Tail)] + [(closure label free*) + (values (do-closure label free* si live env) si #f)] + [(forcall) + (let-values ([(x msi call?) (do-forcall x si live env)]) + (values x msi call?))] + [(funcall) (do-tail-funcall x si live env)] + [(jmpcall) (do-tail-jmpcall x si live env)] + [(appcall) (do-tail-appcall x si live env)] + [(mvcall) (do-mvcall x si live env Tail)] + [else (error who "invalid tail expr ~s" x)])) + ;;; + (define (MainTail x si live env) + (let-values ([(x msi call?) + (Tail x si live env)]) + (if call? + (make-seq 'FIXME:stack-overflow-check x) + x))) + (define (ClambdaCase free*) + (define (bind-free ls) + (let f ([ls ls] [i 0] [env '()]) + (cond + [(null? ls) env] + [else + (f (cdr ls) (fxadd1 i) + (cons (cons (car ls) (make-cpvar i)) env))]))) + (define (do-info x env) + (record-case x + [(case-info label args proper) + (let f ([ls args] [env env] [si 0] [live '()]) + (cond + [(null? ls) (values env si live)] + [else + (let ([fv (make-fvar si)]) + (f (cdr ls) + (cons (cons (car ls) fv) env) + (fxadd1 si) + (cons si live)))]))])) + (let ([env (bind-free free*)]) + (lambda (x) + (record-case x + [(clambda-case info body) + (let-values ([(env si live) (do-info info env)]) + (make-clambda-case info (MainTail body si live env)))] + [else (error who "invalid clambda-case ~s" x)])))) + ;;; + (define (Clambda x) + (record-case x + [(clambda label case* free*) + (make-clambda label (map (ClambdaCase free*) case*) free*)] + [else (error who "invalid clambda ~s" x)])) + ;;; + (define (Program x) + (record-case x + [(codes code* body) + (make-codes (map Clambda code*) (MainTail body 0 '() '()))] + [else (error who "invalid program ~s" x)])) + ;;; + (Program x)) + + + (define (new-cogen x) (verify-new-cogen-input x) (let ([x (remove-primcalls x)]) - x)) + (new-cogen-pass1 x))) diff --git a/src/libcompile.ss b/src/libcompile.ss index 8732d3f..c209ab5 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -5146,7 +5146,10 @@ (primitive-set! 'compile (lambda (x) (let ([code - (if (code? x) x (compile-expr x))]) + (if (code? x) + x + (parameterize ([expand-mode 'eval]) + (compile-expr x)))]) (let ([proc ($code->closure code)]) (proc))))) diff --git a/src/makefile.ss b/src/makefile.ss index 9e68dd5..e166454 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -52,7 +52,7 @@ top-level-value set-top-level-value! top-level-bound? gensym gensym-count gensym-prefix print-gensym gensym->unique-string call-with-values values make-parameter - dynamic-wind display write print-graph fasl-write printf format + dynamic-wind display write print-graph fasl-write printf fprintf format print-error read-token read comment-handler error exit call/cc error-handler eval current-eval compile compile-file new-cafe load system expand sc-expand current-expand expand-mode @@ -78,6 +78,7 @@ console-input-port current-input-port standard-output-port standard-error-port console-output-port current-output-port open-output-file open-input-file open-output-string + with-output-to-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file date-string file-exists? delete-file + - add1 sub1 * / expt diff --git a/src/psyntax-7.1.ss b/src/psyntax-7.1.ss index 0616a2d..6448740 100644 --- a/src/psyntax-7.1.ss +++ b/src/psyntax-7.1.ss @@ -3826,7 +3826,7 @@ (primitive-set! 'expand-mode (make-parameter - 'eval + 'compile (lambda (x) (unless (memq x '(eval compile bootstrap)) (error 'expand-mode "~s is not a valid mode" x))