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
parent
820eb7dcb9
commit
64aca7c80b
Binary file not shown.
|
|
@ -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]
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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 local-labels (make-parameter '()))
|
||||
(define (local-label? x) (and (memq x (local-labels)) #t))
|
||||
|
||||
(define (uncover-local-labels ls)
|
||||
(define locals '())
|
||||
(define g (gensym))
|
||||
(define mark
|
||||
(define find
|
||||
(lambda (x)
|
||||
(when (pair? x)
|
||||
(case (car x)
|
||||
[(label)
|
||||
(let ([name (label-name x)])
|
||||
(putprop name g 'local)
|
||||
(set! locals (cons name locals)))]
|
||||
(set! locals (cons (label-name x) 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))
|
||||
|
||||
(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*)]
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1866
|
||||
1867
|
||||
|
|
|
|||
Loading…
Reference in New Issue