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

Rewrote recordize to get rid of the environment: total saving ~ 50ms.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-06 21:33:33 -05:00
parent 5abcbccb3a
commit 69008ea318
2 changed files with 39 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

124
lib/libcompile.ss
View File

@ -243,25 +243,32 @@
(define (unique-var x) (define (unique-var x)
(make-var (gensym x) #f #f)) (make-var (gensym x) #f #f))
(define (recordize x) (define (recordize x)
(define *cookie* (gensym))
(define (gen-fml* fml*) (define (gen-fml* fml*)
(cond (cond
[(pair? fml*) [(pair? fml*)
(cons (unique-var (car fml*)) (let ([v (unique-var (car fml*))])
(gen-fml* (cdr fml*)))] (putprop (car fml*) *cookie* v)
(cons v (gen-fml* (cdr fml*))))]
[(symbol? fml*) [(symbol? fml*)
(unique-var fml*)] (let ([v (unique-var fml*)])
(putprop fml* *cookie* v)
v)]
[else '()])) [else '()]))
(define (ungen-fml* fml*)
(cond
[(pair? fml*)
(remprop (car fml*) *cookie*)
(ungen-fml* (cdr fml*))]
[(symbol? fml*)
(remprop fml* *cookie*)]))
(define (properize fml*) (define (properize fml*)
(cond (cond
[(pair? fml*) [(pair? fml*)
(cons (car fml*) (properize (cdr fml*)))] (cons (car fml*) (properize (cdr fml*)))]
[(null? fml*) '()] [(null? fml*) '()]
[else (list fml*)])) [else (list fml*)]))
(define (extend-env fml* nfml* env)
(cons (cons fml* nfml*) env))
(define (quoted-sym x) (define (quoted-sym x)
(if (and (list? x) (if (and (list? x)
(fx= (length x) 2) (fx= (length x) 2)
@ -269,84 +276,51 @@
(symbol? (cadr x))) (symbol? (cadr x)))
(cadr x) (cadr x)
(error 'quoted-sym "not a quoted symbol ~s" x))) (error 'quoted-sym "not a quoted symbol ~s" x)))
(define (quoted-string x) (define (quoted-string x)
(if (and (list? x) (if (and (list? x)
(fx= (length x) 2) (fx= (length x) 2)
(eq? 'quote (car x)) (eq? 'quote (car x))
(string? (cadr x))) (string? (cadr x)))
(cadr x) (cadr x)
(error 'quoted-string "not a quoted string ~s" x))) (error 'quoted-string "not a quoted string ~s" x)))
(define (lookup^ x lhs* rhs*) (define (Var x)
(cond (or (getprop x *cookie*)
[(pair? lhs*) (error 'recordize "unbound ~s" x)))
(if (eq? x (car lhs*)) (define (E x)
(car rhs*)
(lookup^ x (cdr lhs*) (cdr rhs*)))]
[(eq? x lhs*) rhs*]
[else #f]))
(define (lookup x env)
(cond
[(pair? env)
(or (lookup^ x (caar env) (cdar env))
(lookup x (cdr env)))]
[else #f]))
(define (E x env)
(cond (cond
[(pair? x) [(pair? x)
(case (car x) (case (car x)
[(quote) (make-constant (cadr x))] [(quote) (make-constant (cadr x))]
[(if) [(if)
(make-conditional (make-conditional
(E (cadr x) env) (E (cadr x))
(E (caddr x) env) (E (caddr x))
(E (cadddr x) env))] (E (cadddr x)))]
[(set!) [(set!)
(let ([lhs (cadr x)] [rhs (caddr x)]) (let ([lhs (cadr x)] [rhs (caddr x)])
(make-assign (make-assign (Var lhs) (E rhs)))]
(or (lookup lhs env)
(error 'recordize "invalid assignment ~s" x))
(E rhs env)))]
[(begin) [(begin)
(let f ([a (cadr x)] [d (cddr x)]) (let f ([a (cadr x)] [d (cddr x)])
(cond (cond
[(null? d) (E a env)] [(null? d) (E a)]
[else [else (make-seq (E a) (f (car d) (cdr d)))]))]
(make-seq
(E a env)
(f (car d) (cdr d)))]))]
[(letrec) [(letrec)
(unless (fx= (length x) 3) (syntax-error x)) (unless (fx= (length x) 3) (syntax-error x))
(let ([bind* (cadr x)] [body (caddr x)]) (let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)] (let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)]) [rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)]) (let ([nlhs* (gen-fml* lhs*)])
(let ([env (extend-env lhs* nlhs* env)]) (let ([expr (make-recbind nlhs* (map E rhs*) (E body ))])
(make-recbind nlhs* (ungen-fml* lhs*)
(map (lambda (rhs) (E rhs env)) rhs*) expr))))]
(E body env))))))]
[(letrec)
(unless (fx= (length x) 3) (syntax-error x))
(let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)]
[rhs* (map cadr bind*)]
[v* (map (lambda (x) '(void)) bind*)]
[t* (map (lambda (x) (gensym)) bind*)])
(E `((case-lambda
[,lhs*
((case-lambda
[,t*
(begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
,body)])
,@rhs*)])
,@v*)
env)))]
[(case-lambda) [(case-lambda)
(let ([cls* (let ([cls*
(map (map
(lambda (cls) (lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)]) (let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)]) (let ([nfml* (gen-fml* fml*)])
(let ([body (E body (extend-env fml* nfml* env))]) (let ([body (E body)])
(ungen-fml* fml*)
(make-clambda-case (make-clambda-case
(make-case-info (make-case-info
(gensym) (gensym)
@ -357,56 +331,36 @@
(make-clambda (gensym) cls* #f))] (make-clambda (gensym) cls* #f))]
[(foreign-call) [(foreign-call)
(let ([name (quoted-string (cadr x))] [arg* (cddr x)]) (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
(make-forcall name (make-forcall name (map E arg*)))]
(map (lambda (x) (E x env)) arg*)))]
[(|#primitive|) [(|#primitive|)
(let ([var (cadr x)]) (let ([var (cadr x)])
(make-primref var))] (make-primref var))]
;;; [(|#primitive|)
;;; (let ([var (cadr x)])
;;; (if (primitive? var)
;;; (make-primref var)
;;; (error 'recordize "invalid primitive ~s" var)))]
[(top-level-value) [(top-level-value)
(let ([var (quoted-sym (cadr x))]) (let ([var (quoted-sym (cadr x))])
(if (eq? (expand-mode) 'bootstrap) (if (eq? (expand-mode) 'bootstrap)
(error 'compile "reference to ~s in bootstrap mode" var) (error 'compile "reference to ~s in bootstrap mode" var)
;(make-primref var)
(make-funcall (make-funcall
(make-primref 'top-level-value) (make-primref 'top-level-value)
(list (make-constant var)))))] (list (make-constant var)))))]
;;; [(top-level-value)
;;; (let ([var (quoted-sym (cadr x))])
;;; (if (eq? (expand-mode) 'bootstrap)
;;; (if (primitive? var)
;;; (make-primref var)
;;; (error 'compile "invalid primitive ~s" var))
;;; (make-funcall
;;; (make-primref 'top-level-value)
;;; (list (make-constant var)))))]
[(set-top-level-value!) [(set-top-level-value!)
(make-funcall (make-primref 'set-top-level-value!) (make-funcall (make-primref 'set-top-level-value!)
(map (lambda (x) (E x env)) (cdr x)))] (map E (cdr x)))]
[(memv) [(memv)
(make-funcall (make-funcall
(make-primref 'memq) (make-primref 'memq)
(map (lambda (x) (E x env)) (cdr x)))] (map E (cdr x)))]
[($apply) [($apply)
(let ([proc (cadr x)] [arg* (cddr x)]) (let ([proc (cadr x)] [arg* (cddr x)])
(make-appcall (make-appcall
(E proc env) (E proc)
(map (lambda (x) (E x env)) arg*)))] (map E arg*)))]
[(void) [(void)
(make-constant (void))] (make-constant (void))]
[else [else
(make-funcall (make-funcall (E (car x)) (map E (cdr x)))])]
(E (car x) env) [(symbol? x) (Var x)]
(map (lambda (x) (E x env)) (cdr x)))])]
[(symbol? x)
(or (lookup x env)
(error 'recordize "invalid reference in ~s" x))]
[else (error 'recordize "invalid expression ~s" x)])) [else (error 'recordize "invalid expression ~s" x)]))
(E x '())) (E x))
(define (unparse x) (define (unparse x)
(define (E-args proper x) (define (E-args proper x)