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

* refresh-cached-labels! is good now.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 06:07:55 -04:00
parent 664492e688
commit bc4e23ebbe
2 changed files with 76 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

130
src/libcompile.ss
View File

@ -4895,18 +4895,35 @@
body) body)
(map CodeExpr ls)))])) (map CodeExpr ls)))]))
(module ;assembly-labels (module ;assembly-labels
(sl-apply-label sl-fx+-type-label sl-fx+-types-label (refresh-cached-labels!
sl-apply-label sl-fx+-type-label sl-fx+-types-label
sl-continuation-code-label sl-invalid-args-label sl-continuation-code-label sl-invalid-args-label
sl-mv-ignore-rp-label sl-mv-error-rp-label sl-values-label sl-mv-ignore-rp-label sl-mv-error-rp-label sl-values-label
sl-cwv-label sl-top-level-value-error-label sl-cadr-error-label sl-cwv-label sl-top-level-value-error-label sl-cadr-error-label
sl-cdr-error-label sl-car-error-label sl-nonprocedure-error-label sl-cdr-error-label sl-car-error-label sl-nonprocedure-error-label
sl-fxsub1-error-label sl-fxadd1-error-label sl-fx+-overflow-label) sl-fxsub1-error-label sl-fxadd1-error-label sl-fx+-overflow-label)
(define (sl-apply-label) (define-syntax define-cached
(lambda (x)
(syntax-case x ()
[(_ refresh [(name*) b* b** ...] ...)
(with-syntax ([(v* ...) (generate-temporaries #'(name* ...))])
#'(begin
(define v* #f) ...
(define (name*)
(or v* (error 'name* "uninitialized label"))) ...
(define (refresh)
(define-syntax name*
(lambda (stx) (syntax-error stx "cannot use label before it is defined")))
...
(let* ([name* (let ([label (let () b* b** ...)])
(set! v* label)
(lambda () label))] ...)
(void)))))])))
(define-cached refresh-cached-labels!
[(sl-apply-label)
(let ([SL_apply (gensym "SL_apply")] (let ([SL_apply (gensym "SL_apply")]
[L_apply_done (gensym)] [L_apply_done (gensym)]
[L_apply_loop (gensym)]) [L_apply_loop (gensym)])
@ -4927,8 +4944,8 @@
(label L_apply_done) (label L_apply_done)
(addl (int wordsize) eax) (addl (int wordsize) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_apply)) SL_apply)]
(define (sl-fx+-type-label) [(sl-fx+-type-label)
(define SL_fx+_type (gensym "SL_fx+_type")) (define SL_fx+_type (gensym "SL_fx+_type"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -4938,8 +4955,8 @@
(movl (primref-loc 'fx+-type-error) cpr) (movl (primref-loc 'fx+-type-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_fx+_type) SL_fx+_type]
(define (sl-fx+-types-label) [(sl-fx+-types-label)
(define SL_fx+_types (gensym "SL_fx+_types")) (define SL_fx+_types (gensym "SL_fx+_types"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -4950,8 +4967,8 @@
(movl (primref-loc 'fx+-types-error) cpr) (movl (primref-loc 'fx+-types-error) cpr)
(movl (int (argc-convention 2)) eax) (movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_fx+_types) SL_fx+_types]
(define (sl-continuation-code-label) [(sl-continuation-code-label)
(define SL_continuation_code (gensym "SL_continuation_code")) (define SL_continuation_code (gensym "SL_continuation_code"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -4996,8 +5013,8 @@
(movl ebx fpr) (movl ebx fpr)
(movl (mem 0 ebx) ebx) (movl (mem 0 ebx) ebx)
(jmp (mem disp-multivalue-rp ebx)))))) (jmp (mem disp-multivalue-rp ebx))))))
SL_continuation_code) SL_continuation_code]
(define (sl-invalid-args-label) [(sl-invalid-args-label)
(define SL_invalid_args (gensym "SL_invalid_args")) (define SL_invalid_args (gensym "SL_invalid_args"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5010,16 +5027,16 @@
(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))))
SL_invalid_args) SL_invalid_args]
(define (sl-mv-ignore-rp-label) [(sl-mv-ignore-rp-label)
(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) (define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
(list 0 (list 0
(label SL_multiple_values_ignore_rp) (label SL_multiple_values_ignore_rp)
(ret)))) (ret))))
SL_multiple_values_ignore_rp) SL_multiple_values_ignore_rp]
(define (sl-mv-error-rp-label) [(sl-mv-error-rp-label)
(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) (define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5027,8 +5044,8 @@
(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))))
SL_multiple_values_error_rp) SL_multiple_values_error_rp]
(define (sl-values-label) [(sl-values-label)
(define SL_values (gensym "SL_values")) (define SL_values (gensym "SL_values"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5044,8 +5061,19 @@
(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)))))
SL_values) SL_values]
(define (sl-cwv-label) [(sl-nonprocedure-error-label)
(define SL_nonprocedure (gensym "SL_nonprocedure"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_nonprocedure)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_nonprocedure]
[(sl-cwv-label)
(define SL_call_with_values (gensym "SL_call_with_values")) (define SL_call_with_values (gensym "SL_call_with_values"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5109,8 +5137,8 @@
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label))) (jne (label (sl-nonprocedure-error-label)))
(tail-indirect-cpr-call))))) (tail-indirect-cpr-call)))))
SL_call_with_values) SL_call_with_values]
(define (sl-top-level-value-error-label) [(sl-top-level-value-error-label)
(define SL_top_level_value_error (gensym "SL_top_level_value_error")) (define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5120,8 +5148,8 @@
(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))))
SL_top_level_value_error) SL_top_level_value_error]
(define (sl-cadr-error-label) [(sl-cadr-error-label)
(define SL_cadr_error (gensym "SL_cadr_error")) (define SL_cadr_error (gensym "SL_cadr_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5131,8 +5159,8 @@
(movl (primref-loc 'cadr-error) cpr) (movl (primref-loc 'cadr-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_cadr_error) SL_cadr_error]
(define (sl-cdr-error-label) [(sl-cdr-error-label)
(define SL_cdr_error (gensym "SL_cdr_error")) (define SL_cdr_error (gensym "SL_cdr_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5142,8 +5170,8 @@
(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))))
SL_cdr_error) SL_cdr_error]
(define (sl-car-error-label) [(sl-car-error-label)
(define SL_car_error (gensym "SL_car_error")) (define SL_car_error (gensym "SL_car_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5153,19 +5181,8 @@
(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))))
SL_car_error) SL_car_error]
(define (sl-nonprocedure-error-label) [(sl-fxsub1-error-label)
(define SL_nonprocedure (gensym "SL_nonprocedure"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_nonprocedure)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_nonprocedure)
(define (sl-fxsub1-error-label)
(define SL_fxsub1_error (gensym "SL_fxsub1_error")) (define SL_fxsub1_error (gensym "SL_fxsub1_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5175,8 +5192,8 @@
(movl (primref-loc 'fxsub1-error) cpr) (movl (primref-loc 'fxsub1-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_fxsub1_error) SL_fxsub1_error]
(define (sl-fxadd1-error-label) [(sl-fxadd1-error-label)
(define SL_fxadd1_error (gensym "SL_fxadd1_error")) (define SL_fxadd1_error (gensym "SL_fxadd1_error"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5186,8 +5203,8 @@
(movl (primref-loc 'fxadd1-error) cpr) (movl (primref-loc 'fxadd1-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_fxadd1_error) SL_fxadd1_error]
(define (sl-fx+-overflow-label) [(sl-fx+-overflow-label)
(define SL_fx+_overflow (gensym "SL_fx+_overflow")) (define SL_fx+_overflow (gensym "SL_fx+_overflow"))
(list*->code* (lambda (x) #f) (list*->code* (lambda (x) #f)
(list (list
@ -5198,7 +5215,7 @@
(movl (primref-loc 'fx+-overflow-error) cpr) (movl (primref-loc 'fx+-overflow-error) cpr)
(movl (int (argc-convention 2)) eax) (movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call)))) (tail-indirect-cpr-call))))
SL_fx+_overflow) SL_fx+_overflow])
) )
(define (compile-core-expr->code p) (define (compile-core-expr->code p)
@ -5250,15 +5267,20 @@
(primitive-set! 'compile-core-expr-to-port compile-core-expr-to-port) (primitive-set! 'compile-core-expr-to-port compile-core-expr-to-port)
(primitive-set! 'assembler-output (make-parameter #f)) (primitive-set! 'assembler-output (make-parameter #f))
(primitive-set! 'current-primitive-locations
(make-parameter
(lambda (x) #f)
(lambda (x)
(if (procedure? x)
x
(error 'current-primitive-locations "~s is not a procedure" x)))))
;(initialize-system) (primitive-set! 'current-primitive-locations
(let ([plocs (lambda (x) #f)])
(case-lambda
[() plocs]
[(p)
(if (procedure? p)
(begin
(set! plocs p)
(refresh-cached-labels!))
(error 'current-primitive-locations "~s is not a procedure" p))])))
(refresh-cached-labels!)
(primitive-set! 'eval-core (primitive-set! 'eval-core
(lambda (x) ((compile-core-expr x)))) (lambda (x) ((compile-core-expr x))))