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

* Global variables which are assigned (or complex) no longer have lexical 

copy.  All references and assignments to them goes through the
  symbol value slot.
This commit is contained in:
Abdulaziz Ghuloum 2007-11-17 11:06:17 -05:00
parent 759474fd85
commit 245203eaa0
1 changed files with 77 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
scheme/ikarus.compiler.ss
View File

@ -104,7 +104,7 @@
(define-struct var (define-struct var
(name assigned referenced (name assigned referenced
reg-conf frm-conf var-conf reg-move frm-move var-move reg-conf frm-conf var-conf reg-move frm-move var-move
loc index)) loc index global-loc))
(define-struct cp-var (idx)) (define-struct cp-var (idx))
(define-struct frame-var (idx)) (define-struct frame-var (idx))
(define-struct new-frame (base-idx size body)) (define-struct new-frame (base-idx size body))
@ -162,7 +162,7 @@
[else (error 'mkfvar "not a fixnum" i)])))) [else (error 'mkfvar "not a fixnum" i)]))))
(define (unique-var x) (define (unique-var x)
(make-var (gensym x) #f #f #f #f #f #f #f #f #f #f)) (make-var (gensym x) #f #f #f #f #f #f #f #f #f #f #f))
(define (recordize x) (define (recordize x)
(define *cookie* (gensym)) (define *cookie* (gensym))
@ -224,6 +224,9 @@
(caar cls*)] (caar cls*)]
[else (f (cdr cls*))]))] [else (f (cdr cls*))]))]
[else '()])) [else '()]))
(define (make-global-set! lhs rhs)
(make-funcall (make-primref '$init-symbol-value!)
(list (make-constant lhs) rhs)))
(define (E x ctxt) (define (E x ctxt)
(cond (cond
[(pair? x) [(pair? x)
@ -240,10 +243,7 @@
[(lexical lhs) => [(lexical lhs) =>
(lambda (var) (lambda (var)
(make-assign var (E rhs lhs)))] (make-assign var (E rhs lhs)))]
[else [else (make-global-set! lhs (E rhs lhs))]))]
(make-funcall (make-primref '$init-symbol-value!)
(list (make-constant lhs)
(E rhs lhs)))]))]
[(begin) [(begin)
(let f ([a (cadr x)] [d (cddr x)]) (let f ([a (cadr x)] [d (cddr x)])
(cond (cond
@ -272,21 +272,32 @@
[loc* (map cadr bind*)] [loc* (map cadr bind*)]
[rhs* (map caddr bind*)]) [rhs* (map caddr bind*)])
(let ([nlhs* (gen-fml* lhs*)]) (let ([nlhs* (gen-fml* lhs*)])
(for-each
(lambda (lhs loc)
(set-var-global-loc! lhs loc))
nlhs* loc*)
(let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (let ([expr (make-rec*bind nlhs* (map E rhs* lhs*)
(let f ([nlhs* nlhs*] [loc* loc*]) (let f ([lhs* nlhs*] [loc* loc*])
(cond (cond
[(null? nlhs*) (E body ctxt)] [(null? lhs*) (E body ctxt)]
[(not (car loc*)) [(not (car loc*)) (f (cdr lhs*) (cdr loc*))]
(f (cdr nlhs*) (cdr loc*))] [else
[else (make-seq
(make-seq (make-global-set! (car loc*) (car lhs*))
(make-funcall (f (cdr lhs*) (cdr loc*)))])))])
(make-primref '$init-symbol-value!)
(list (make-constant (car loc*))
(car nlhs*)))
(f (cdr nlhs*) (cdr loc*)))])))])
(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-library-recbind nlhs* loc*
; (map E rhs* lhs*)
; (E body ctxt))])
; (ungen-fml* lhs*)
; expr))))]
[(case-lambda) [(case-lambda)
(let ([cls* (let ([cls*
(map (map
@ -359,6 +370,10 @@
[(rec*bind lhs* rhs* body) [(rec*bind lhs* rhs* body)
`(letrec* ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) `(letrec* ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))] ,(E body))]
;[(library-recbind lhs* loc* rhs* body)
; `(letrec ,(map (lambda (lhs loc rhs) (list (E lhs) loc (E rhs)))
; lhs* loc* rhs*)
; ,(E body))]
[(fix lhs* rhs* body) [(fix lhs* rhs* body)
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))] ,(E body))]
@ -548,6 +563,8 @@
(make-forcall rator (map Expr rand*))] (make-forcall rator (map Expr rand*))]
[(assign lhs rhs) [(assign lhs rhs)
(make-assign lhs (Expr rhs))] (make-assign lhs (Expr rhs))]
;[(library-recbind lhs* loc* rhs* body)
; (make-library-recbind lhs* loc* (map Expr rhs*) (Expr body))]
[else (error who "invalid expression" (unparse x))])) [else (error who "invalid expression" (unparse x))]))
(Expr x)) (Expr x))
@ -634,22 +651,15 @@
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)]) (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*) (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* 0 lhs* rhs* vref vcomp)]) (partition-rhs* 0 lhs* rhs* vref vcomp)])
(let ([v* (map (lambda (x) (make-constant (void))) clhs*)]) (let ([v* (map (lambda (x) (make-constant (void))) clhs*)])
;(let ([ls (make-bind slhs* srhs*
; (let f ([ls clhs*]) (make-bind clhs* v*
; (cond (make-fix llhs* lrhs*
; [(null? ls) '()] (if letrec?
; [(var-assigned (car ls)) (f (cdr ls))] (let ([t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
; [else (cons (var-name (car ls)) (f (cdr ls)))]))]) (make-bind t* crhs*
; (unless (null? ls) (printf "complex: ~s\n" ls))) (build-assign* clhs* t* body)))
(make-bind slhs* srhs* (build-assign* clhs* crhs* body)))))))))))
(make-bind clhs* v*
(make-fix llhs* lrhs*
(if letrec?
(let ([t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
(make-bind t* crhs*
(build-assign* clhs* t* body)))
(build-assign* clhs* crhs* body)))))))))))
(define (build-assign* lhs* rhs* body) (define (build-assign* lhs* rhs* body)
(cond (cond
[(null? lhs*) body] [(null? lhs*) body]
@ -707,11 +717,24 @@
(make-mvcall p c))] (make-mvcall p c))]
[(forcall rator rand*) [(forcall rator rand*)
(make-forcall rator (E* rand* ref comp))] (make-forcall rator (E* rand* ref comp))]
;[(library-recbind lhs* loc* rhs* body)
; (E (make-rec*bind lhs* rhs*
; (let f ([lhs* lhs*] [loc* loc*])
; (cond
; [(null? lhs*) body]
; [(not (car loc*)) (f (cdr lhs*) (cdr loc*))]
; [else (make-seq
; (make-funcall
; (make-primref '$init-symbol-value!)
; (list (make-constant (car loc*)) (car lhs*)))
; (f (cdr lhs*) (cdr loc*)))])))
; ref comp)]
[else (error who "invalid expression" (unparse x))])) [else (error who "invalid expression" (unparse x))]))
(E x (lambda (x) (error who "free var found" x)) (E x (lambda (x) (error who "free var found" x))
void)) void))
(define (uncover-assigned/referenced x) (define (uncover-assigned/referenced x)
(define who 'uncover-assigned/referenced) (define who 'uncover-assigned/referenced)
(define (Expr* x*) (define (Expr* x*)
@ -1391,7 +1414,7 @@
(let ([x (car lhs*)]) (let ([x (car lhs*)])
(let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))]) (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))])
(cond (cond
[(var-assigned x) [(and (var-assigned x) (not (var-global-loc x)))
(let ([t (unique-var 'assignment-tmp)]) (let ([t (unique-var 'assignment-tmp)])
(values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))] (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
[else [else
@ -1409,7 +1432,15 @@
[(var) [(var)
(cond (cond
[(var-assigned x) [(var-assigned x)
(make-funcall (make-primref '$vector-ref) (list x (make-constant 0)))] (cond
[(var-global-loc x) =>
(lambda (loc)
(make-funcall
(make-primref 'top-level-value)
(list (make-constant loc))))]
[else
(make-funcall (make-primref '$vector-ref)
(list x (make-constant 0)))])]
[else x])] [else x])]
[(primref) x] [(primref) x]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
@ -1441,8 +1472,14 @@
[(assign lhs rhs) [(assign lhs rhs)
(unless (var-assigned lhs) (unless (var-assigned lhs)
(error 'rewrite-assignments "not assigned" lhs x)) (error 'rewrite-assignments "not assigned" lhs x))
(make-funcall (make-primref '$vector-set!) (cond
(list lhs (make-constant 0) (Expr rhs)))] [(var-global-loc lhs) =>
(lambda (loc)
(make-funcall (make-primref '$init-symbol-value!)
(list (make-constant loc) (Expr rhs))))]
[else
(make-funcall (make-primref '$vector-set!)
(list lhs (make-constant 0) (Expr rhs)))])]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))] [(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression" (unparse x))])) [else (error who "invalid expression" (unparse x))]))
(Expr x)) (Expr x))