diff --git a/scheme/ikarus.boot.8.prebuilt b/scheme/ikarus.boot.8.prebuilt index 7077084..41bb2a4 100644 Binary files a/scheme/ikarus.boot.8.prebuilt and b/scheme/ikarus.boot.8.prebuilt differ diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 669ae96..b5ca386 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -2104,18 +2104,20 @@ (let ([L_cwv_done (gensym)] [L_cwv_loop (gensym)] [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)]) + [L_cwv_call (gensym)] + [SL_nonprocedure (gensym "SL_nonprocedure")] + [SL_invalid_args (gensym "SL_invalid_args")]) (list 0 ; no free vars '(name call-with-values) (label SL_call_with_values) (cmpl (int (argc-convention 2)) eax) - (jne (label (sl-invalid-args-label))) + (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-error-label))) + (jne (label SL_nonprocedure)) (movl (int (argc-convention 0)) eax) (compile-call-frame 3 @@ -2129,7 +2131,7 @@ (movl (int (argc-convention 1)) eax) (andl (int closure-mask) ebx) (cmpl (int closure-tag) ebx) - (jne (label (sl-nonprocedure-error-label))) + (jne (label SL_nonprocedure)) (tail-indirect-cpr-call) ;;; multiple values returned (label L_cwv_multi_rp) @@ -2153,8 +2155,27 @@ (movl cpr ebx) (andl (int closure-mask) ebx) (cmpl (int closure-tag) ebx) - (jne (label (sl-nonprocedure-error-label))) - (tail-indirect-cpr-call))))) + (jne (label SL_nonprocedure)) + (tail-indirect-cpr-call) + + (label SL_nonprocedure) + (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg + (movl (obj (primref->symbol '$apply-nonprocedure-error-handler)) cpr) + (movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr) + (movl (int (argc-convention 1)) eax) + (tail-indirect-cpr-call) + + (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 (obj (primref->symbol '$incorrect-args-error-handler)) cpr) + (movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr) + (movl (int (argc-convention 2)) eax) + (tail-indirect-cpr-call) + + )))) SL_call_with_values] )) diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index 190ab3a..63452f0 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -35,9 +35,11 @@ [else (f (car ls) (fold f init (cdr ls)))]))) + (define convert-instructions (lambda (ls) - (fold convert-instruction '() ls))) + (parameterize ([local-labels (uncover-local-labels ls)]) + (fold convert-instruction '() ls)))) (define register-mapping ;;; reg cls idx REX.R @@ -216,7 +218,11 @@ (byte (sra n 24)) ac)] [(label? n) - (cons (cons 'relative (label-name n)) ac)] + (cond + [(local-label? (label-name n)) + (cons (cons 'local-relative (label-name n)) ac)] + [else + (cons (cons 'relative (label-name n)) ac)])] [else (die 'IMM32 "invalid" n)]))) (define IMM @@ -255,7 +261,12 @@ [(foreign? n) (cons (cons 'foreign-label (label-name n)) ac)] [(label? n) - (cons (cons 'relative (label-name n)) ac)] + (cond + [(local-label? (label-name n)) + (cons (cons 'local-relative (label-name n)) ac)] + [else + (cons (cons 'relative (label-name n)) ac)])] + ;(cons (cons 'relative (label-name n)) ac)] [else (die 'IMM "invalid" n)]))) @@ -376,6 +387,7 @@ (begin (add-instruction (name* instr ac arg** ...) b* b** ...) ...)])) + (define (convert-instruction a ac) (cond [(getprop (car a) *cogen*) => @@ -747,18 +759,20 @@ (cond [(reg? dst) (CR* #xF7 '/3 dst ac)] [else (die who "invalid" instr)])] - [(local-jmp dst) (CODE #xE9 (IMM32 dst ac))] [(jmp dst) (cond + [(and (label? dst) (local-label? (label-name dst))) + (CODE #xE9 (cons `(local-relative . ,(label-name dst)) ac))] [(imm? dst) - (if (= wordsize 4) + (if (= wordsize 4) (CODE #xE9 (IMM32 dst ac)) (jmp-pc-relative #xFF #x25 dst ac))] [(mem? dst) (CR* #xFF '/4 dst ac)] [else (die who "invalid jmp target" dst)])] - [(local-call dst) (CODE #xE8 (IMM32 dst ac))] [(call dst) (cond + [(and (label? dst) (local-label? (label-name dst))) + (CODE #xE8 (cons `(local-relative . ,(label-name dst)) ac))] [(imm? dst) (if (= wordsize 4) (CODE #xE8 (IMM32 dst ac)) @@ -904,37 +918,21 @@ (code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])] [else (die 'set-code-word! "unhandled" x)]))) -(define (preoptimize-local-jumps ls) - (define locals '()) - (define g (gensym)) - (define mark - (lambda (x) - (when (pair? x) - (case (car x) - [(label) - (let ([name (label-name x)]) - (putprop name g 'local) - (set! locals (cons name locals)))] - [(seq pad) - (for-each mark (cdr x))])))) - (define (local-label? x) - (and (label? x) (eq? (getprop (label-name x) g) 'local))) - (define opt - (lambda (x) - (when (pair? x) - (case (car x) - [(call) - (when (local-label? (cadr x)) - (set-car! x 'local-call))] - [(jmp) - (when (local-label? (cadr x)) - (set-car! x 'local-jmp))] - [(seq pad) - (for-each opt (cdr x))])))) - (for-each mark ls) - (for-each opt ls) - (for-each (lambda (x) (remprop x g)) locals)) +(define local-labels (make-parameter '())) +(define (local-label? x) (and (memq x (local-labels)) #t)) +(define (uncover-local-labels ls) + (define locals '()) + (define find + (lambda (x) + (when (pair? x) + (case (car x) + [(label) + (set! locals (cons (label-name x) locals))] + [(seq pad) + (for-each find (cdr x))])))) + (for-each find ls) + locals) (define (optimize-local-jumps ls) (define locals '()) @@ -1124,8 +1122,6 @@ (let ([closure-size* (map car ls*)] [code-name* (map code-name ls*)] [ls* (map code-list ls*)]) - (when (= wordsize 8) - (for-each preoptimize-local-jumps ls*)) (let* ([ls* (map convert-instructions ls*)] [ls* (map optimize-local-jumps ls*)]) (let ([n* (map compute-code-size ls*)] diff --git a/scheme/last-revision b/scheme/last-revision index 58d8972..824cab0 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1866 +1867