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

* cleaned up the assembly-labels code.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 05:01:38 -04:00
parent cc159a4926
commit 664492e688
2 changed files with 281 additions and 258 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.

547
src/libcompile.ss
View File

@ -3242,8 +3242,8 @@
(define who 'generate-code) (define who 'generate-code)
(define (rp-label x L_multi) (define (rp-label x L_multi)
(case x (case x
[(value) (label-address SL_multiple_values_error_rp)] [(value) (label-address (sl-mv-error-rp-label))]
[(effect) (label-address SL_multiple_values_ignore_rp)] [(effect) (label-address (sl-mv-ignore-rp-label))]
[else [else
(if (clambda? x) (if (clambda? x)
(label-address L_multi) (label-address L_multi)
@ -3576,9 +3576,9 @@
(NonTail (car arg*) (NonTail (car arg*)
(list* (movl eax ebx) (list* (movl eax ebx)
(andl (int fx-mask) ebx) (andl (int fx-mask) ebx)
(jne (label SL_fxadd1_error)) (jne (label (sl-fxadd1-error-label)))
(addl (int (fxsll 1 fx-shift)) eax) (addl (int (fxsll 1 fx-shift)) eax)
(jo (label SL_fxadd1_error)) (jo (label (sl-fxadd1-error-label)))
ac))] ac))]
[(fx+) [(fx+)
(let foo ([a0 (car arg*)] [a1 (cadr arg*)]) (let foo ([a0 (car arg*)] [a1 (cadr arg*)])
@ -3594,7 +3594,7 @@
(add-handler! (add-handler!
(list L (list L
(movl (Simple a1) ebx) (movl (Simple a1) ebx)
(jmp (label SL_fx+_overflow)))) (jmp (label (sl-fx+-overflow-label)))))
L)]) L)])
(NonTail a0 (NonTail a0
(list* (list*
@ -3623,16 +3623,16 @@
(jne (label (sl-fx+-types-label))) (jne (label (sl-fx+-types-label)))
(addl ebx eax) (addl ebx eax)
;;; args in eax (ac),ebx ;;; args in eax (ac),ebx
(jo (label SL_fx+_overflow)) (jo (label (sl-fx+-overflow-label)))
ac))])] ac))])]
[else (foo a1 a0)]))] [else (foo a1 a0)]))]
[(fxsub1) [(fxsub1)
(NonTail (car arg*) (NonTail (car arg*)
(list* (movl eax ebx) (list* (movl eax ebx)
(andl (int fx-mask) ebx) (andl (int fx-mask) ebx)
(jne (label SL_fxsub1_error)) (jne (label (sl-fxsub1-error-label)))
(subl (int (fxsll 1 fx-shift)) eax) (subl (int (fxsll 1 fx-shift)) eax)
(jo (label SL_fxsub1_error)) (jo (label (sl-fxsub1-error-label)))
ac))] ac))]
[($fxsub1) [($fxsub1)
(list* (movl (Simple (car arg*)) eax) (list* (movl (Simple (car arg*)) eax)
@ -3822,11 +3822,11 @@
(cmpl (int pair-tag) eax) (cmpl (int pair-tag) eax)
(if (eq? op 'car) (if (eq? op 'car)
(list* (list*
(jne (label SL_car_error)) (jne (label (sl-car-error-label)))
(movl (mem (fx- disp-car pair-tag) ebx) eax) (movl (mem (fx- disp-car pair-tag) ebx) eax)
ac) ac)
(list* (list*
(jne (label SL_cdr_error)) (jne (label (sl-cdr-error-label)))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax) (movl (mem (fx- disp-cdr pair-tag) ebx) eax)
ac)))))] ac)))))]
[(cadr) [(cadr)
@ -3835,12 +3835,12 @@
(movl eax ebx) (movl eax ebx)
(andl (int pair-mask) eax) (andl (int pair-mask) eax)
(cmpl (int pair-tag) eax) (cmpl (int pair-tag) eax)
(jne (label SL_cadr_error)) (jne (label (sl-cadr-error-label)))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax) (movl (mem (fx- disp-cdr pair-tag) ebx) eax)
(movl eax ecx) (movl eax ecx)
(andl (int pair-mask) eax) (andl (int pair-mask) eax)
(cmpl (int pair-tag) eax) (cmpl (int pair-tag) eax)
(jne (label SL_cadr_error)) (jne (label (sl-cadr-error-label)))
(movl (mem (fx- disp-car pair-tag) ecx) eax) (movl (mem (fx- disp-car pair-tag) ecx) eax)
ac))] ac))]
[(top-level-value) [(top-level-value)
@ -3854,12 +3854,12 @@
(movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax) (movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax)
(movl (obj v) ebx) (movl (obj v) ebx)
(cmpl (int unbound) eax) (cmpl (int unbound) eax)
(je (label SL_top_level_value_error)) (je (label (sl-top-level-value-error-label)))
ac)] ac)]
[else [else
(list* (list*
(movl (obj v) ebx) (movl (obj v) ebx)
(jmp (label SL_top_level_value_error)) (jmp (label (sl-top-level-value-error-label)))
ac)]))] ac)]))]
[else [else
(NonTail x (NonTail x
@ -3867,10 +3867,10 @@
(movl eax ebx) (movl eax ebx)
(andl (int symbol-mask) eax) (andl (int symbol-mask) eax)
(cmpl (int symbol-tag) eax) (cmpl (int symbol-tag) eax)
(jne (label SL_top_level_value_error)) (jne (label (sl-top-level-value-error-label)))
(movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax) (movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax)
(cmpl (int unbound) eax) (cmpl (int unbound) eax)
(je (label SL_top_level_value_error)) (je (label (sl-top-level-value-error-label)))
ac))]))] ac))]))]
[($vector-ref) [($vector-ref)
(list* (movl (Simple (car arg*)) ebx) (list* (movl (Simple (car arg*)) ebx)
@ -4138,15 +4138,15 @@
ac)] ac)]
[($frame->continuation) [($frame->continuation)
(NonTail (NonTail
(make-closure (make-code-loc SL_continuation_code) arg*) (make-closure (make-code-loc (sl-continuation-code-label)) arg*)
ac)] ac)]
[($make-call-with-values-procedure) [($make-call-with-values-procedure)
(NonTail (NonTail
(make-closure (make-code-loc SL_call_with_values) arg*) (make-closure (make-code-loc (sl-cwv-label)) arg*)
ac)] ac)]
[($make-values-procedure) [($make-values-procedure)
(NonTail (NonTail
(make-closure (make-code-loc SL_values) arg*) (make-closure (make-code-loc (sl-values-label)) arg*)
ac)] ac)]
[($memq) [($memq)
(record-case (cadr arg*) (record-case (cadr arg*)
@ -4643,7 +4643,7 @@
(movl eax cpr) (movl eax cpr)
(andl (int closure-mask) eax) (andl (int closure-mask) eax)
(cmpl (int closure-tag) eax) (cmpl (int closure-tag) eax)
(jne (label SL_nonprocedure)) (jne (label (sl-nonprocedure-error-label)))
ac))] ac))]
[(primref? body) [(primref? body)
(list* (movl (primref-loc (primref-name body)) cpr) ac)] (list* (movl (primref-loc (primref-name body)) cpr) ac)]
@ -4713,12 +4713,12 @@
(list* (list*
(subl (int (frame-adjustment offset)) fpr) (subl (int (frame-adjustment offset)) fpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(jmp (label SL_invalid_args)) (jmp (label (sl-invalid-args-label)))
(label L_multi) (label L_multi)
(if save-cp? (movl (mem wordsize fpr) cpr) '(nop)) (if save-cp? (movl (mem wordsize fpr) cpr) '(nop))
(subl (int (frame-adjustment (fxadd1 offset))) fpr) (subl (int (frame-adjustment (fxadd1 offset))) fpr)
(cmpl (int (argc-convention (length args))) eax) (cmpl (int (argc-convention (length args))) eax)
(jne (label SL_invalid_args)) (jne (label (sl-invalid-args-label)))
(k body ac))])])] (k body ac))])])]
[else [else
(list* (list*
@ -4780,7 +4780,7 @@
(define LOOP_HEAD (unique-label)) (define LOOP_HEAD (unique-label))
(define L_CALL (unique-label)) (define L_CALL (unique-label))
(list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
(jg (label SL_invalid_args)) (jg (label (sl-invalid-args-label)))
(jl CONS_LABEL) (jl CONS_LABEL)
(movl (int nil) ebx) (movl (int nil) ebx)
(jmp DONE_LABEL) (jmp DONE_LABEL)
@ -4839,7 +4839,7 @@
(cond (cond
[(and proper check?) [(and proper check?)
(list* (cmpl (int (argc-convention (length fml*))) eax) (list* (cmpl (int (argc-convention (length fml*))) eax)
(jne (label SL_invalid_args)) (jne (label (sl-invalid-args-label)))
ac)] ac)]
[proper ac] [proper ac]
[else [else
@ -4895,245 +4895,66 @@
body) body)
(map CodeExpr ls)))])) (map CodeExpr ls)))]))
(define (sl-apply-label)
(let ([SL_apply (gensym "SL_apply")]
[L_apply_done (gensym)]
[L_apply_loop (gensym)])
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_apply)
(movl (mem fpr eax) ebx)
(cmpl (int nil) ebx)
(je (label L_apply_done))
(label L_apply_loop)
(movl (mem (fx- disp-car pair-tag) ebx) ecx)
(movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
(movl ecx (mem fpr eax))
(subl (int wordsize) eax)
(cmpl (int nil) ebx)
(jne (label L_apply_loop))
(label L_apply_done)
(addl (int wordsize) eax)
(tail-indirect-cpr-call))))
SL_apply))
(define (sl-fx+-type-label)
(define SL_fx+_type (gensym "SL_fx+_type"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fx+_type)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fx+-type-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_fx+_type)
(define (sl-fx+-types-label)
(define SL_fx+_types (gensym "SL_fx+_types"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fx+_types)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-types-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))))
SL_fx+_types)
(begin ;;; ASSEMBLY HELPERS
(define SL_fx+_overflow (gensym "SL_fx+_overflow"))
(define SL_fxadd1_error (gensym "SL_fxadd1_error"))
(define SL_fxsub1_error (gensym "SL_fxsub1_error"))
(define SL_nonprocedure (gensym "SL_nonprocedure"))
(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(define SL_car_error (gensym "SL_car_error"))
(define SL_cdr_error (gensym "SL_cdr_error"))
(define SL_cadr_error (gensym "SL_cadr_error"))
(define SL_invalid_args (gensym "SL_invalid_args"))
(define SL_foreign_call (gensym "SL_foreign_call"))
(define SL_continuation_code (gensym "SL_continuation_code"))
(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values"))
(define SL_underflow_handler (gensym "SL_underflow_handler"))
(define SL_scheme_exit (gensym "SL_scheme_exit"))
(define SL_values (gensym "SL_values"))
(define SL_call_with_values (gensym "SL_call_with_values"))
(define (initialize-system)
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fxadd1_error)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fxadd1-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_fx+_overflow)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-overflow-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_fxsub1_error)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fxsub1-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_car_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'car-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_cdr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_cadr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cadr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'top-level-value-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(let ([L_cwv_done (gensym)]
[L_cwv_loop (gensym)]
[L_cwv_multi_rp (gensym)]
[L_cwv_call (gensym)])
(list
0 ; no free vars
(label SL_call_with_values)
(cmpl (int (argc-convention 2)) eax)
(jne (label SL_invalid_args))
(movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
(movl ebx cpr)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(movl (int (argc-convention 0)) eax)
(subl (int (fx* wordsize 2)) fpr)
(jmp (label L_cwv_call))
; MV NEW FRAME
(byte-vector '#(#b110))
`(int ,(fx* wordsize 3))
'(current-frame-offset)
(label-address L_cwv_multi_rp)
(byte 0)
(byte 0)
(label L_cwv_call)
(indirect-cpr-call)
;;; one value returned
(addl (int (fx* wordsize 2)) fpr)
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
(movl ebx cpr)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (int (argc-convention 1)) eax)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(tail-indirect-cpr-call)
;;; multiple values returned
(label L_cwv_multi_rp)
; because values does not pop the return point
; we have to adjust fp one more word here
(addl (int (fx* wordsize 3)) fpr)
(movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
(cmpl (int (argc-convention 0)) eax)
(je (label L_cwv_done))
(movl (int (fx* -4 wordsize)) ebx)
(addl fpr ebx) ; ebx points to first value
(movl ebx ecx)
(addl eax ecx) ; ecx points to the last value
(label L_cwv_loop)
(movl (mem 0 ebx) edx)
(movl edx (mem (fx* 3 wordsize) ebx))
(subl (int wordsize) ebx)
(cmpl ecx ebx)
(jge (label L_cwv_loop))
(label L_cwv_done)
(movl cpr ebx)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(tail-indirect-cpr-call)))
(let ([L_values_one_value (gensym)]
[L_values_many_values (gensym)])
(list 0 ; no freevars
(label SL_values)
(cmpl (int (argc-convention 1)) eax)
(je (label L_values_one_value))
(label L_values_many_values)
(movl (mem 0 fpr) ebx) ; return point
(jmp (mem disp-multivalue-rp ebx)) ; go
(label L_values_one_value)
(movl (mem (fx- 0 wordsize) fpr) eax)
(ret)))
(list 0 (module ;assembly-labels
(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))
(list 0 (sl-apply-label sl-fx+-type-label sl-fx+-types-label
(label SL_multiple_values_error_rp) sl-continuation-code-label sl-invalid-args-label
(movl (primref-loc '$multiple-values-error) cpr) sl-mv-ignore-rp-label sl-mv-error-rp-label sl-values-label
(tail-indirect-cpr-call)) 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-fxsub1-error-label sl-fxadd1-error-label sl-fx+-overflow-label)
(list 0 (define (sl-apply-label)
(label SL_multiple_values_ignore_rp) (let ([SL_apply (gensym "SL_apply")]
(ret)) [L_apply_done (gensym)]
[L_apply_loop (gensym)])
(list 0 (list*->code* (lambda (x) #f)
(label SL_invalid_args) (list
;;;
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(negl eax)
(movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
(movl (primref-loc '$incorrect-args-error-handler) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))
(let ([Lset (gensym)] [Lloop (gensym)])
(list 0 (list 0
(label SL_foreign_call) (label SL_apply)
(movl fpr (pcb-ref 'frame-pointer)) (movl (mem fpr eax) ebx)
(movl apr (pcb-ref 'allocation-pointer)) (cmpl (int nil) ebx)
(movl fpr ebx) (je (label L_apply_done))
(movl (pcb-ref 'system-stack) esp) (label L_apply_loop)
(pushl pcr) (movl (mem (fx- disp-car pair-tag) ebx) ecx)
(cmpl (int 0) eax) (movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
(je (label Lset)) (movl ecx (mem fpr eax))
(label Lloop) (subl (int wordsize) eax)
(movl (mem ebx eax) ecx) (cmpl (int nil) ebx)
(pushl ecx) (jne (label L_apply_loop))
(addl (int 4) eax) (label L_apply_done)
(cmpl (int 0) eax) (addl (int wordsize) eax)
(jne (label Lloop)) (tail-indirect-cpr-call))))
(label Lset) SL_apply))
; FOREIGN NEW FRAME (define (sl-fx+-type-label)
(call cpr) (define SL_fx+_type (gensym "SL_fx+_type"))
(movl (pcb-ref 'frame-pointer) fpr) (list*->code* (lambda (x) #f)
(movl (pcb-ref 'allocation-pointer) apr) (list
(ret))) (list 0
(label SL_fx+_type)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fx+-type-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_fx+_type)
(define (sl-fx+-types-label)
(define SL_fx+_types (gensym "SL_fx+_types"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fx+_types)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-types-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))))
SL_fx+_types)
(define (sl-continuation-code-label)
(define SL_continuation_code (gensym "SL_continuation_code"))
(list*->code* (lambda (x) #f)
(list
(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)]
@ -5174,9 +4995,211 @@
(jne (label L_cont_mult_copy_loop)) (jne (label L_cont_mult_copy_loop))
(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)
)))) (define (sl-invalid-args-label)
(define SL_invalid_args (gensym "SL_invalid_args"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_invalid_args)
;;;
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(negl eax)
(movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
(movl (primref-loc '$incorrect-args-error-handler) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))))
SL_invalid_args)
(define (sl-mv-ignore-rp-label)
(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_multiple_values_ignore_rp)
(ret))))
SL_multiple_values_ignore_rp)
(define (sl-mv-error-rp-label)
(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_multiple_values_error_rp)
(movl (primref-loc '$multiple-values-error) cpr)
(tail-indirect-cpr-call))))
SL_multiple_values_error_rp)
(define (sl-values-label)
(define SL_values (gensym "SL_values"))
(list*->code* (lambda (x) #f)
(list
(let ([L_values_one_value (gensym)]
[L_values_many_values (gensym)])
(list 0 ; no freevars
(label SL_values)
(cmpl (int (argc-convention 1)) eax)
(je (label L_values_one_value))
(label L_values_many_values)
(movl (mem 0 fpr) ebx) ; return point
(jmp (mem disp-multivalue-rp ebx)) ; go
(label L_values_one_value)
(movl (mem (fx- 0 wordsize) fpr) eax)
(ret)))))
SL_values)
(define (sl-cwv-label)
(define SL_call_with_values (gensym "SL_call_with_values"))
(list*->code* (lambda (x) #f)
(list
(let ([L_cwv_done (gensym)]
[L_cwv_loop (gensym)]
[L_cwv_multi_rp (gensym)]
[L_cwv_call (gensym)])
(list
0 ; no free vars
(label SL_call_with_values)
(cmpl (int (argc-convention 2)) eax)
(jne (label (sl-invalid-args-label)))
(movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
(movl ebx cpr)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label)))
(movl (int (argc-convention 0)) eax)
(subl (int (fx* wordsize 2)) fpr)
(jmp (label L_cwv_call))
; MV NEW FRAME
(byte-vector '#(#b110))
`(int ,(fx* wordsize 3))
'(current-frame-offset)
(label-address L_cwv_multi_rp)
(byte 0)
(byte 0)
(label L_cwv_call)
(indirect-cpr-call)
;;; one value returned
(addl (int (fx* wordsize 2)) fpr)
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
(movl ebx cpr)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (int (argc-convention 1)) eax)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label)))
(tail-indirect-cpr-call)
;;; multiple values returned
(label L_cwv_multi_rp)
; because values does not pop the return point
; we have to adjust fp one more word here
(addl (int (fx* wordsize 3)) fpr)
(movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
(cmpl (int (argc-convention 0)) eax)
(je (label L_cwv_done))
(movl (int (fx* -4 wordsize)) ebx)
(addl fpr ebx) ; ebx points to first value
(movl ebx ecx)
(addl eax ecx) ; ecx points to the last value
(label L_cwv_loop)
(movl (mem 0 ebx) edx)
(movl edx (mem (fx* 3 wordsize) ebx))
(subl (int wordsize) ebx)
(cmpl ecx ebx)
(jge (label L_cwv_loop))
(label L_cwv_done)
(movl cpr ebx)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label)))
(tail-indirect-cpr-call)))))
SL_call_with_values)
(define (sl-top-level-value-error-label)
(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'top-level-value-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_top_level_value_error)
(define (sl-cadr-error-label)
(define SL_cadr_error (gensym "SL_cadr_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_cadr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cadr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_cadr_error)
(define (sl-cdr-error-label)
(define SL_cdr_error (gensym "SL_cdr_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_cdr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_cdr_error)
(define (sl-car-error-label)
(define SL_car_error (gensym "SL_car_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_car_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'car-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_car_error)
(define (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)
(define (sl-fxsub1-error-label)
(define SL_fxsub1_error (gensym "SL_fxsub1_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fxsub1_error)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fxsub1-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_fxsub1_error)
(define (sl-fxadd1-error-label)
(define SL_fxadd1_error (gensym "SL_fxadd1_error"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fxadd1_error)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fxadd1-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))))
SL_fxadd1_error)
(define (sl-fx+-overflow-label)
(define SL_fx+_overflow (gensym "SL_fx+_overflow"))
(list*->code* (lambda (x) #f)
(list
(list 0
(label SL_fx+_overflow)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-overflow-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))))
SL_fx+_overflow)
)
(define (compile-core-expr->code p) (define (compile-core-expr->code p)
(let* ([p (recordize p)] (let* ([p (recordize p)]
@ -5235,7 +5258,7 @@
x x
(error 'current-primitive-locations "~s is not a procedure" x))))) (error 'current-primitive-locations "~s is not a procedure" x)))))
(initialize-system) ;(initialize-system)
(primitive-set! 'eval-core (primitive-set! 'eval-core
(lambda (x) ((compile-core-expr x)))) (lambda (x) ((compile-core-expr x))))