conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* libraries are now expanded to a special library-letrec* form.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-17 09:53:22 -05:00
parent eef196c09d
commit 759474fd85
5 changed files with 71 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
benchmarks.larceny/results.Larceny-r6rs
View File

@ -8599,3 +8599,28 @@ Words allocated: 221189818
Words reclaimed: 0
Elapsed time...: 20809 ms (User: 11008 ms; System: 9796 ms)
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.)

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

21
scheme/ikarus.compiler.ss
View File

@ -266,6 +266,27 @@
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
(ungen-fml* lhs*)
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)
(let ([cls*
(map

6
scheme/psyntax.builders.ss
View File

@ -24,7 +24,7 @@
build-global-assignment build-global-definition build-lambda
build-case-lambda build-let build-primref build-foreign-call
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))
(define (build-global-define x)
@ -140,6 +140,10 @@
(build-lexical-assignment ae lhs rhs))
vars val-exps)
(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)))
)

25
scheme/psyntax.expander.ss
View File

@ -3069,14 +3069,21 @@
(chi-library-internal b* rib top?)))
(seal-rib! rib)
(let ((rhs* (chi-rhs* rhs* r mr))
(loc* (map gen-global lex*))
(init* (chi-expr* init* r mr)))
(unseal-rib! rib)
(let ((export-subst (make-export-subst exp-int* exp-ext* rib)))
(let-values (((export-env global* macro*)
(make-export-env/macros r)))
(make-export-env/macros lex* loc* r)))
(let ((invoke-body
(build-letrec* no-source lex* rhs*
(build-exports global* init*)))
(build-library-letrec* no-source
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
(map build-global-define (map cdr global*))))
(values
@ -3250,7 +3257,15 @@
(cons ext label)))
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* '()))
(cond
((null? r) (values env global* macro*))
@ -3259,7 +3274,7 @@
(let ((label (car x)) (b (cdr x)))
(case (binding-type b)
((lexical)
(let ((loc (gen-global (binding-value b))))
(let ((loc (lookup (binding-value b))))
(f (cdr r)
(cons (cons* label 'global loc) env)
(cons (cons (binding-value b) loc) global*)