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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

51
lib/libcompile.ss
View File

@ -1102,7 +1102,8 @@
;(define thunk-count 0)
;(define total-count 0)
(define (convert-closures prog) (define (convert-closures prog)
(define who 'convert-closures) (define who 'convert-closures)
(define (Expr* x*) (define (Expr* x*)
@ -1136,6 +1137,10 @@
cls*) cls*)
(union (difference body-free fml*) (union (difference body-free fml*)
cls*-free)))])]))]) 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) (values (make-closure (make-clambda-code (gensym) cls* free) free)
free))])) free))]))
(define (Expr ex) (define (Expr ex)
@ -3623,7 +3628,9 @@
(handle-cases (car cases) (cdr cases)))])) (handle-cases (car cases) (cdr cases)))]))
(record-case x (record-case x
[(codes list body) [(codes list body)
(cons (cons 0 (Tail body '())) (cons (list* 0
(label (gensym))
(Tail body '()))
(map CodeExpr list))])) (map CodeExpr list))]))
@ -3654,21 +3661,21 @@
(movl (primref-loc 'car-error) cpr) (movl (primref-loc 'car-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0 (list 0
(label SL_cdr_error) (label SL_cdr_error)
(movl ebx (mem (fx- 0 wordsize) fpr)) (movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cdr-error) cpr) (movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0 (list 0
(label SL_top_level_value_error) (label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr)) (movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'top-level-value-error) cpr) (movl (primref-loc 'top-level-value-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(let ([L_cwv_done (gensym)] (let ([L_cwv_done (gensym)]
[L_cwv_loop (gensym)] [L_cwv_loop (gensym)]
[L_cwv_multi_rp (gensym)] [L_cwv_multi_rp (gensym)]
@ -3729,7 +3736,7 @@
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure)) (jne (label SL_nonprocedure))
(tail-indirect-cpr-call))) (tail-indirect-cpr-call)))
(let ([L_values_one_value (gensym)] (let ([L_values_one_value (gensym)]
[L_values_many_values (gensym)]) [L_values_many_values (gensym)])
(list 0 ; no freevars (list 0 ; no freevars
@ -3742,7 +3749,7 @@
(label L_values_one_value) (label L_values_one_value)
(movl (mem (fx- 0 wordsize) fpr) eax) (movl (mem (fx- 0 wordsize) fpr) eax)
(ret))) (ret)))
(let ([L_apply_done (gensym)] (let ([L_apply_done (gensym)]
[L_apply_loop (gensym)]) [L_apply_loop (gensym)])
(list 0 (list 0
@ -3760,23 +3767,23 @@
(label L_apply_done) (label L_apply_done)
(addl (int wordsize) eax) (addl (int wordsize) eax)
(tail-indirect-cpr-call))) (tail-indirect-cpr-call)))
(list 0 (list 0
(label SL_nonprocedure) (label SL_nonprocedure)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(movl (primref-loc '$apply-nonprocedure-error-handler) cpr) (movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0 (list 0
(label SL_multiple_values_error_rp) (label SL_multiple_values_error_rp)
(movl (primref-loc '$multiple-values-error) cpr) (movl (primref-loc '$multiple-values-error) cpr)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0 (list 0
(label SL_multiple_values_ignore_rp) (label SL_multiple_values_ignore_rp)
(ret)) (ret))
(list 0 (list 0
(label SL_invalid_args) (label SL_invalid_args)
;;; ;;;
@ -3786,7 +3793,7 @@
(movl (primref-loc '$incorrect-args-error-handler) cpr) (movl (primref-loc '$incorrect-args-error-handler) cpr)
(movl (int (argc-convention 2)) eax) (movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(let ([Lset (gensym)] [Lloop (gensym)]) (let ([Lset (gensym)] [Lloop (gensym)])
(list 0 (list 0
(label SL_foreign_call) (label SL_foreign_call)
@ -3809,7 +3816,7 @@
(movl (pcb-ref 'frame-pointer) fpr) (movl (pcb-ref 'frame-pointer) fpr)
(movl (pcb-ref 'allocation-pointer) apr) (movl (pcb-ref 'allocation-pointer) apr)
(ret))) (ret)))
(let ([L_cont_zero_args (gensym)] (let ([L_cont_zero_args (gensym)]
[L_cont_mult_args (gensym)] [L_cont_mult_args (gensym)]
[L_cont_one_arg (gensym)] [L_cont_one_arg (gensym)]
@ -3872,15 +3879,15 @@
[p (insert-stack-overflow-checks p)] [p (insert-stack-overflow-checks p)]
[p (insert-allocation-checks p)] [p (insert-allocation-checks p)]
[p (remove-local-variables p)] [p (remove-local-variables p)]
[p (optimize-ap-check p)] [p (optimize-ap-check p)])
[ls* (generate-code p)] (let ([ls* (generate-code p)])
[f (when (assembler-output) (when (assembler-output)
(for-each (for-each
(lambda (ls) (lambda (ls)
(for-each (lambda (x) (printf " ~s\n" x)) ls)) (for-each (lambda (x) (printf " ~s\n" x)) ls))
ls*))] ls*))
[code* (list*->code* ls*)]) (let ([code* (list*->code* ls*)])
(car code*))) (car code*)))))
(define compile-file (define compile-file
(lambda (input-file output-file . rest) (lambda (input-file output-file . rest)