* libraries are now expanded to a special library-letrec* form.
This commit is contained in:
parent
eef196c09d
commit
759474fd85
|
@ -8599,3 +8599,28 @@ Words allocated: 221189818
|
||||||
Words reclaimed: 0
|
Words reclaimed: 0
|
||||||
Elapsed time...: 20809 ms (User: 11008 ms; System: 9796 ms)
|
Elapsed time...: 20809 ms (User: 11008 ms; System: 9796 ms)
|
||||||
Elapsed GC time: 164 ms (CPU: 175 in 844 collections.)
|
Elapsed GC time: 164 ms (CPU: 175 in 844 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Sat Nov 17 09:16:18 EST 2007 under Darwin Vesuvius.local 8.10.1 Darwin Kernel Version 8.10.1: Wed May 23 16:33:00 PDT 2007; root:xnu-792.22.5~1/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing ray under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.95 "First Safety" (Nov 8 2007 04:30:20, precise:BSD Unix:unified)
|
||||||
|
larceny.heap, built on Thu Nov 8 04:39:44 EST 2007
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.95 "First Safety" (Nov 8 2007 04:30:20, precise:BSD Unix:unified)
|
||||||
|
larceny.heap, built on Thu Nov 8 04:39:44 EST 2007
|
||||||
|
|
||||||
|
>
|
||||||
|
opening "spheres.pgm"
|
||||||
|
opening "spheres.pgm"
|
||||||
|
opening "spheres.pgm"
|
||||||
|
opening "spheres.pgm"
|
||||||
|
opening "spheres.pgm"
|
||||||
|
Words allocated: 221189818
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 20868 ms (User: 11040 ms; System: 9770 ms)
|
||||||
|
Elapsed GC time: 159 ms (CPU: 170 in 844 collections.)
|
||||||
|
|
Binary file not shown.
|
@ -266,6 +266,27 @@
|
||||||
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
|
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
|
||||||
(ungen-fml* lhs*)
|
(ungen-fml* lhs*)
|
||||||
expr))))]
|
expr))))]
|
||||||
|
[(library-letrec*)
|
||||||
|
(let ([bind* (cadr x)] [body (caddr x)])
|
||||||
|
(let ([lhs* (map car bind*)]
|
||||||
|
[loc* (map cadr bind*)]
|
||||||
|
[rhs* (map caddr bind*)])
|
||||||
|
(let ([nlhs* (gen-fml* lhs*)])
|
||||||
|
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*)
|
||||||
|
(let f ([nlhs* nlhs*] [loc* loc*])
|
||||||
|
(cond
|
||||||
|
[(null? nlhs*) (E body ctxt)]
|
||||||
|
[(not (car loc*))
|
||||||
|
(f (cdr nlhs*) (cdr loc*))]
|
||||||
|
[else
|
||||||
|
(make-seq
|
||||||
|
(make-funcall
|
||||||
|
(make-primref '$init-symbol-value!)
|
||||||
|
(list (make-constant (car loc*))
|
||||||
|
(car nlhs*)))
|
||||||
|
(f (cdr nlhs*) (cdr loc*)))])))])
|
||||||
|
(ungen-fml* lhs*)
|
||||||
|
expr))))]
|
||||||
[(case-lambda)
|
[(case-lambda)
|
||||||
(let ([cls*
|
(let ([cls*
|
||||||
(map
|
(map
|
||||||
|
|
|
@ -24,7 +24,7 @@
|
||||||
build-global-assignment build-global-definition build-lambda
|
build-global-assignment build-global-definition build-lambda
|
||||||
build-case-lambda build-let build-primref build-foreign-call
|
build-case-lambda build-let build-primref build-foreign-call
|
||||||
build-data build-sequence build-void build-letrec build-letrec*
|
build-data build-sequence build-void build-letrec build-letrec*
|
||||||
build-global-define)
|
build-global-define build-library-letrec*)
|
||||||
(import (rnrs) (psyntax compat) (psyntax config))
|
(import (rnrs) (psyntax compat) (psyntax config))
|
||||||
|
|
||||||
(define (build-global-define x)
|
(define (build-global-define x)
|
||||||
|
@ -140,6 +140,10 @@
|
||||||
(build-lexical-assignment ae lhs rhs))
|
(build-lexical-assignment ae lhs rhs))
|
||||||
vars val-exps)
|
vars val-exps)
|
||||||
(list body-exp)))))))))
|
(list body-exp)))))))))
|
||||||
|
(define build-library-letrec*
|
||||||
|
(lambda (ae vars locs val-exps body-exp)
|
||||||
|
`(library-letrec* ,(map list vars locs val-exps) ,body-exp)))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -3069,14 +3069,21 @@
|
||||||
(chi-library-internal b* rib top?)))
|
(chi-library-internal b* rib top?)))
|
||||||
(seal-rib! rib)
|
(seal-rib! rib)
|
||||||
(let ((rhs* (chi-rhs* rhs* r mr))
|
(let ((rhs* (chi-rhs* rhs* r mr))
|
||||||
|
(loc* (map gen-global lex*))
|
||||||
(init* (chi-expr* init* r mr)))
|
(init* (chi-expr* init* r mr)))
|
||||||
(unseal-rib! rib)
|
(unseal-rib! rib)
|
||||||
(let ((export-subst (make-export-subst exp-int* exp-ext* rib)))
|
(let ((export-subst (make-export-subst exp-int* exp-ext* rib)))
|
||||||
(let-values (((export-env global* macro*)
|
(let-values (((export-env global* macro*)
|
||||||
(make-export-env/macros r)))
|
(make-export-env/macros lex* loc* r)))
|
||||||
(let ((invoke-body
|
(let ((invoke-body
|
||||||
(build-letrec* no-source lex* rhs*
|
(build-library-letrec* no-source
|
||||||
(build-exports global* init*)))
|
lex* loc* rhs*
|
||||||
|
(if (null? init*)
|
||||||
|
(build-void)
|
||||||
|
(build-sequence no-source init*))))
|
||||||
|
;(invoke-body
|
||||||
|
; (build-letrec* no-source lex* rhs*
|
||||||
|
; (build-exports global* init*)))
|
||||||
(invoke-definitions
|
(invoke-definitions
|
||||||
(map build-global-define (map cdr global*))))
|
(map build-global-define (map cdr global*))))
|
||||||
(values
|
(values
|
||||||
|
@ -3250,7 +3257,15 @@
|
||||||
(cons ext label)))
|
(cons ext label)))
|
||||||
int* ext*))
|
int* ext*))
|
||||||
|
|
||||||
(define (make-export-env/macros r)
|
(define (make-export-env/macros lex* loc* r)
|
||||||
|
(define (lookup x)
|
||||||
|
(let f ([x x] [lex* lex*] [loc* loc*])
|
||||||
|
(cond
|
||||||
|
[(pair? lex*)
|
||||||
|
(if (eq? x (car lex*))
|
||||||
|
(car loc*)
|
||||||
|
(f x (cdr lex*) (cdr loc*)))]
|
||||||
|
[else (error 'lookup-make-export "BUG")])))
|
||||||
(let f ((r r) (env '()) (global* '()) (macro* '()))
|
(let f ((r r) (env '()) (global* '()) (macro* '()))
|
||||||
(cond
|
(cond
|
||||||
((null? r) (values env global* macro*))
|
((null? r) (values env global* macro*))
|
||||||
|
@ -3259,7 +3274,7 @@
|
||||||
(let ((label (car x)) (b (cdr x)))
|
(let ((label (car x)) (b (cdr x)))
|
||||||
(case (binding-type b)
|
(case (binding-type b)
|
||||||
((lexical)
|
((lexical)
|
||||||
(let ((loc (gen-global (binding-value b))))
|
(let ((loc (lookup (binding-value b))))
|
||||||
(f (cdr r)
|
(f (cdr r)
|
||||||
(cons (cons* label 'global loc) env)
|
(cons (cons* label 'global loc) env)
|
||||||
(cons (cons (binding-value b) loc) global*)
|
(cons (cons (binding-value b) loc) global*)
|
||||||
|
|
Loading…
Reference in New Issue