before adding make-once thunks

This commit is contained in:
Abdulaziz Ghuloum 2006-12-03 14:36:45 -05:00
parent 6c30b75e57
commit 6b2e48efb7
2 changed files with 29 additions and 22 deletions

Binary file not shown.

View File

@ -1102,7 +1102,8 @@
;(define thunk-count 0)
;(define total-count 0)
(define (convert-closures prog)
(define who 'convert-closures)
(define (Expr* x*)
@ -1136,6 +1137,10 @@
cls*)
(union (difference body-free fml*)
cls*-free)))])]))])
;(set! total-count (fxadd1 total-count))
;(when (null? free)
; (set! thunk-count (fxadd1 thunk-count))
; (printf "EMPTY CLOSURE ~s/~s\n" thunk-count total-count))
(values (make-closure (make-clambda-code (gensym) cls* free) free)
free))]))
(define (Expr ex)
@ -3623,7 +3628,9 @@
(handle-cases (car cases) (cdr cases)))]))
(record-case x
[(codes list body)
(cons (cons 0 (Tail body '()))
(cons (list* 0
(label (gensym))
(Tail body '()))
(map CodeExpr list))]))
@ -3872,15 +3879,15 @@
[p (insert-stack-overflow-checks p)]
[p (insert-allocation-checks p)]
[p (remove-local-variables p)]
[p (optimize-ap-check p)]
[ls* (generate-code p)]
[f (when (assembler-output)
[p (optimize-ap-check p)])
(let ([ls* (generate-code p)])
(when (assembler-output)
(for-each
(lambda (ls)
(for-each (lambda (x) (printf " ~s\n" x)) ls))
ls*))]
[code* (list*->code* ls*)])
(car code*)))
ls*))
(let ([code* (list*->code* ls*)])
(car code*)))))
(define compile-file
(lambda (input-file output-file . rest)