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

Procedure codes no longer save their cp if the cp has no free vars.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 22:43:42 -05:00
parent 62b42e8bb8
commit 876a2d7824
2 changed files with 217 additions and 208 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.

45
lib/libcompile.ss
View File

@ -221,7 +221,7 @@
(define-record eval-cp (check body)) (define-record eval-cp (check body))
(define-record return (value)) (define-record return (value))
(define-record call-cp (define-record call-cp
(call-convention label rp-convention base-idx arg-count live-mask)) (call-convention label save-cp? rp-convention base-idx arg-count live-mask))
(define-record tailcall-cp (convention label arg-count)) (define-record tailcall-cp (convention label arg-count))
(define-record primcall (op arg*)) (define-record primcall (op arg*))
(define-record primref (name)) (define-record primref (name))
@ -467,7 +467,7 @@
`(save-cp ,(E expr))] `(save-cp ,(E expr))]
[(eval-cp check body) [(eval-cp check body)
`(eval-cp ,check ,(E body))] `(eval-cp ,check ,(E body))]
[(call-cp call-convention label rp-convention base-idx arg-count live-mask) [(call-cp call-convention label save-cp? rp-convention base-idx arg-count live-mask)
`(call-cp [conv: ,call-convention] `(call-cp [conv: ,call-convention]
[label: ,label] [label: ,label]
[rpconv: ,rp-convention] [rpconv: ,rp-convention]
@ -1945,6 +1945,7 @@
(define (remove-local-variables x) (define (remove-local-variables x)
(define who 'remove-local-variables) (define who 'remove-local-variables)
(define (Body orig-x orig-si orig-r orig-live save-cp?)
(define (simple* x* r) (define (simple* x* r)
(map (lambda (x) (map (lambda (x)
(cond (cond
@ -1969,30 +1970,37 @@
[(closure? x) #f] [(closure? x) #f]
[else #t])) [else #t]))
(define (do-new-frame label op rand* si r call-convention rp-convention orig-live) (define (do-new-frame label op rand* si r call-convention rp-convention orig-live)
(make-new-frame (fxadd1 si) (fx+ (length rand*) 2) (let ([start-si (if save-cp? (fxadd1 si) si)])
(let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) (make-new-frame start-si (fx+ (length rand*) 2)
(let f ([r* rand*] [nsi (fxadd1 start-si)] [live orig-live])
(cond (cond
[(null? r*) [(null? r*)
(make-seq (make-seq
(make-seq (make-seq
(if save-cp?
(make-save-cp (make-frame-var si)) (make-save-cp (make-frame-var si))
(nop))
(case call-convention (case call-convention
[(normal apply direct) [(normal apply)
(make-eval-cp (check? op) (Expr op nsi r (cons si live)))]
[(direct)
(make-eval-cp (check? op) (Expr op nsi r (cons si live)))] (make-eval-cp (check? op) (Expr op nsi r (cons si live)))]
[(foreign) [(foreign)
(make-eval-cp #f (make-foreign-label op))] (make-eval-cp #f (make-foreign-label op))]
[else (error who "invalid convention ~s" call-convention)])) [else (error who "invalid convention ~s" call-convention)]))
(make-call-cp call-convention label (make-call-cp call-convention label save-cp?
rp-convention rp-convention
(fxadd1 si) ; frame size start-si ; frame size
(length rand*) ; argc (length rand*) ; argc
(env->mask (cons si orig-live) ; cp and everything before it (env->mask (if save-cp?
(fxadd1 si))))] ; mask-size ~~ frame size (cons si orig-live)
orig-live)
start-si)))] ; mask-size ~~ frame size
[else [else
(make-seq (make-seq
(make-assign (make-frame-var nsi) (make-assign (make-frame-var nsi)
(Expr (car r*) nsi r live)) (Expr (car r*) nsi r live))
(f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))) (f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))))
(define (nop) (make-primcall 'void '())) (define (nop) (make-primcall 'void '()))
(define (do-bind lhs* rhs* body si r live k) (define (do-bind lhs* rhs* body si r live k)
(let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live])
@ -2149,6 +2157,7 @@
[(appcall op rand*) [(appcall op rand*)
(do-new-frame #f op rand* si r 'apply 'value live)] (do-new-frame #f op rand* si r 'apply 'value live)]
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(Tail orig-x orig-si orig-r orig-live))
(define (bind-fml* fml* r) (define (bind-fml* fml* r)
(let f ([si 1] [fml* fml*]) (let f ([si 1] [fml* fml*])
(cond (cond
@ -2169,7 +2178,7 @@
(f (cdr free*) (fxadd1 idx) (f (cdr free*) (fxadd1 idx)
(cons (cons (car free*) (make-cp-var idx)) r))]))) (cons (cons (car free*) (make-cp-var idx)) r))])))
(define CaseExpr (define CaseExpr
(lambda (r) (lambda (r save-cp?)
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case info body) [(clambda-case info body)
@ -2178,17 +2187,17 @@
(let-values ([(fml* si r live) (bind-fml* fml* r)]) (let-values ([(fml* si r live) (bind-fml* fml* r)])
(make-clambda-case (make-clambda-case
(make-case-info label fml* proper) (make-case-info label fml* proper)
(Tail body si r live)))])])))) (Body body si r live save-cp?)))])]))))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
(let ([r (bind-free* free)]) (let ([r (bind-free* free)])
(make-clambda L (map (CaseExpr r) cases) free))])) (make-clambda L (map (CaseExpr r (not (null? free))) cases) free))]))
(define (CodesExpr x) (define (CodesExpr x)
(record-case x (record-case x
[(codes list body) [(codes list body)
(make-codes (map CodeExpr list) (make-codes (map CodeExpr list)
(Tail body 1 '() '()))])) (Body body 1 '() '() #f))]))
(CodesExpr x)) (CodesExpr x))
(define (optimize-ap-check x) (define (optimize-ap-check x)
@ -3619,7 +3628,7 @@
(do-value-prim op rand* ac)] (do-value-prim op rand* ac)]
[(new-frame base-idx size body) [(new-frame base-idx size body)
(NonTail body ac)] (NonTail body ac)]
[(call-cp call-convention direct-label rp-convention offset size mask) [(call-cp call-convention direct-label save-cp? rp-convention offset size mask)
(let ([L_CALL (unique-label)]) (let ([L_CALL (unique-label)])
(case call-convention (case call-convention
[(normal) [(normal)
@ -3635,7 +3644,7 @@
`(byte 0) ; direct calls are ok `(byte 0) ; direct calls are ok
L_CALL L_CALL
(indirect-cpr-call) (indirect-cpr-call)
(movl (mem 0 fpr) cpr) (if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr) (subl (int (frame-adjustment offset)) fpr)
ac)] ac)]
[(direct) [(direct)
@ -3649,7 +3658,7 @@
(rp-label rp-convention) (rp-label rp-convention)
L_CALL L_CALL
(call (label direct-label)) (call (label direct-label))
(movl (mem 0 fpr) cpr) (if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr) (subl (int (frame-adjustment offset)) fpr)
ac)] ac)]
[(foreign) [(foreign)
@ -3667,7 +3676,7 @@
'(byte 0) '(byte 0)
L_CALL L_CALL
(call ebx) (call ebx)
(movl (mem 0 fpr) cpr) (if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr) (subl (int (frame-adjustment offset)) fpr)
ac)] ac)]
[else [else