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

Binary file not shown.

View File

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