one more fix for 64-bit jumps and calls. Some conditional jumps

required cross-code offsets which are now eliminated.
This commit is contained in:
Abdulaziz Ghuloum 2009-12-31 16:41:13 +03:00
parent 820eb7dcb9
commit 64aca7c80b
4 changed files with 62 additions and 45 deletions

Binary file not shown.

View File

@ -2104,18 +2104,20 @@
(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)]
[L_cwv_call (gensym)]) [L_cwv_call (gensym)]
[SL_nonprocedure (gensym "SL_nonprocedure")]
[SL_invalid_args (gensym "SL_invalid_args")])
(list (list
0 ; no free vars 0 ; no free vars
'(name call-with-values) '(name call-with-values)
(label SL_call_with_values) (label SL_call_with_values)
(cmpl (int (argc-convention 2)) eax) (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 (mem (fx- 0 wordsize) fpr) ebx) ; producer
(movl ebx cpr) (movl ebx cpr)
(andl (int closure-mask) ebx) (andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label))) (jne (label SL_nonprocedure))
(movl (int (argc-convention 0)) eax) (movl (int (argc-convention 0)) eax)
(compile-call-frame (compile-call-frame
3 3
@ -2129,7 +2131,7 @@
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(andl (int closure-mask) ebx) (andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label))) (jne (label SL_nonprocedure))
(tail-indirect-cpr-call) (tail-indirect-cpr-call)
;;; multiple values returned ;;; multiple values returned
(label L_cwv_multi_rp) (label L_cwv_multi_rp)
@ -2153,8 +2155,27 @@
(movl cpr ebx) (movl cpr ebx)
(andl (int closure-mask) ebx) (andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label))) (jne (label SL_nonprocedure))
(tail-indirect-cpr-call))))) (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] SL_call_with_values]
)) ))

View File

@ -35,9 +35,11 @@
[else [else
(f (car ls) (fold f init (cdr ls)))]))) (f (car ls) (fold f init (cdr ls)))])))
(define convert-instructions (define convert-instructions
(lambda (ls) (lambda (ls)
(fold convert-instruction '() ls))) (parameterize ([local-labels (uncover-local-labels ls)])
(fold convert-instruction '() ls))))
(define register-mapping (define register-mapping
;;; reg cls idx REX.R ;;; reg cls idx REX.R
@ -216,7 +218,11 @@
(byte (sra n 24)) (byte (sra n 24))
ac)] ac)]
[(label? n) [(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)]))) [else (die 'IMM32 "invalid" n)])))
(define IMM (define IMM
@ -255,7 +261,12 @@
[(foreign? n) [(foreign? n)
(cons (cons 'foreign-label (label-name n)) ac)] (cons (cons 'foreign-label (label-name n)) ac)]
[(label? n) [(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)]))) [else (die 'IMM "invalid" n)])))
@ -376,6 +387,7 @@
(begin (begin
(add-instruction (name* instr ac arg** ...) b* b** ...) ...)])) (add-instruction (name* instr ac arg** ...) b* b** ...) ...)]))
(define (convert-instruction a ac) (define (convert-instruction a ac)
(cond (cond
[(getprop (car a) *cogen*) => [(getprop (car a) *cogen*) =>
@ -747,18 +759,20 @@
(cond (cond
[(reg? dst) (CR* #xF7 '/3 dst ac)] [(reg? dst) (CR* #xF7 '/3 dst ac)]
[else (die who "invalid" instr)])] [else (die who "invalid" instr)])]
[(local-jmp dst) (CODE #xE9 (IMM32 dst ac))]
[(jmp dst) [(jmp dst)
(cond (cond
[(and (label? dst) (local-label? (label-name dst)))
(CODE #xE9 (cons `(local-relative . ,(label-name dst)) ac))]
[(imm? dst) [(imm? dst)
(if (= wordsize 4) (if (= wordsize 4)
(CODE #xE9 (IMM32 dst ac)) (CODE #xE9 (IMM32 dst ac))
(jmp-pc-relative #xFF #x25 dst ac))] (jmp-pc-relative #xFF #x25 dst ac))]
[(mem? dst) (CR* #xFF '/4 dst ac)] [(mem? dst) (CR* #xFF '/4 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
[(local-call dst) (CODE #xE8 (IMM32 dst ac))]
[(call dst) [(call dst)
(cond (cond
[(and (label? dst) (local-label? (label-name dst)))
(CODE #xE8 (cons `(local-relative . ,(label-name dst)) ac))]
[(imm? dst) [(imm? dst)
(if (= wordsize 4) (if (= wordsize 4)
(CODE #xE8 (IMM32 dst ac)) (CODE #xE8 (IMM32 dst ac))
@ -904,37 +918,21 @@
(code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])] (code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])]
[else (die 'set-code-word! "unhandled" x)]))) [else (die 'set-code-word! "unhandled" x)])))
(define (preoptimize-local-jumps ls) (define local-labels (make-parameter '()))
(define locals '()) (define (local-label? x) (and (memq x (local-labels)) #t))
(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 (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 (optimize-local-jumps ls)
(define locals '()) (define locals '())
@ -1124,8 +1122,6 @@
(let ([closure-size* (map car ls*)] (let ([closure-size* (map car ls*)]
[code-name* (map code-name ls*)] [code-name* (map code-name ls*)]
[ls* (map code-list ls*)]) [ls* (map code-list ls*)])
(when (= wordsize 8)
(for-each preoptimize-local-jumps ls*))
(let* ([ls* (map convert-instructions ls*)] (let* ([ls* (map convert-instructions ls*)]
[ls* (map optimize-local-jumps ls*)]) [ls* (map optimize-local-jumps ls*)])
(let ([n* (map compute-code-size ls*)] (let ([n* (map compute-code-size ls*)]

View File

@ -1 +1 @@
1866 1867