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