* added with-output-to-string
This commit is contained in:
Abdulaziz Ghuloum
parent
82375a3ddc
commit
d8f646040f
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -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)
|
||||
|
|
|
|||
345
src/libcogen1.ss
345
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 <value>) 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)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue