Fixed the ``relocation error'' that happens in 64-bit mode. What

used to be a relative jump from one code object to another is now
turned into a pc-relative jump, where the jump targets are stored
somewhere at the bottom of the code that performs the jump:

old code sequence:

        call-relative (Ltarget - L0)
    L0: ...

new code sequence:

        call-pc-relative (L1 - L0)
    L0: ...
        ...
    L1: <8-byte Ltarget>
This commit is contained in:
Abdulaziz Ghuloum 2009-12-31 03:41:22 +03:00
parent 69207de752
commit 820eb7dcb9
4 changed files with 116 additions and 51 deletions

Binary file not shown.

View File

@ -2480,12 +2480,7 @@
(define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence) (define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence)
(let ([L_CALL (label (gensym))] (let ([L_CALL (label (gensym))])
[padding
(- call-instruction-size
(instruction-size call-sequence))])
(when (< padding 0)
(error 'compile-call-frame "call sequence too long" call-sequence))
(list 'seq (list 'seq
(if (or (= framesize 0) (= framesize 1)) (if (or (= framesize 0) (= framesize 1))
'(seq) '(seq)
@ -2495,9 +2490,9 @@
`(int ,(* framesize wordsize)) `(int ,(* framesize wordsize))
'(current-frame-offset) '(current-frame-offset)
multiarg-rp multiarg-rp
`(byte-vector ,(make-vector padding 0)) `(pad ,call-instruction-size
L_CALL ,L_CALL
call-sequence ,call-sequence)
(if (or (= framesize 0) (= framesize 1)) (if (or (= framesize 0) (= framesize 1))
'(seq) '(seq)
`(addl ,(* (fxsub1 framesize) wordsize) ,fpr))))) `(addl ,(* (fxsub1 framesize) wordsize) ,fpr)))))

View File

@ -16,7 +16,7 @@
(library (ikarus.intel-assembler) (library (ikarus.intel-assembler)
(export instruction-size assemble-sources code-entry-adjustment) (export assemble-sources code-entry-adjustment)
(import (import
(ikarus) (ikarus)
(rnrs bytevectors) (rnrs bytevectors)
@ -400,6 +400,21 @@
(die 'convert-instruction "incorrect args" a))])))] (die 'convert-instruction "incorrect args" a))])))]
[(eq? (car a) 'seq) [(eq? (car a) 'seq)
(fold convert-instruction ac (cdr a))] (fold convert-instruction ac (cdr a))]
[(eq? (car a) 'pad)
(let ()
(define (find-prefix x ls)
(let f ([ls ls])
(cond
[(eq? ls x) '()]
[else
(let ([a (car ls)])
(if (and (pair? a) (eq? (car a) 'bottom-code))
(f (cdr ls))
(cons a (f (cdr ls)))))])))
(let ([n (cadr a)] [code (cddr a)])
(let ([ls (fold convert-instruction ac code)])
(let ([m (compute-code-size (find-prefix ac ls))])
(append (make-list (- n m) 0) ls)))))]
[else (die 'convert-instruction "unknown instruction" a)])) [else (die 'convert-instruction "unknown instruction" a)]))
(define (RM /d dst ac) (define (RM /d dst ac)
@ -562,6 +577,19 @@
(cons (car ls) (f (cdr ls)))))) (cons (car ls) (f (cdr ls))))))
ls) ls)
(define (jmp-pc-relative code0 code1 dst ac)
(when (= wordsize 4)
(error 'intel-assembler "no pc-relative jumps in 32-bit mode"))
(let ([g (gensym)])
(CODE code0
(CODE code1
(cons*
`(local-relative . ,g)
`(bottom-code
(label . ,g)
(label-addr . ,(label-name dst)))
ac)))))
(add-instructions instr ac (add-instructions instr ac
[(ret) (CODE #xC3 ac)] [(ret) (CODE #xC3 ac)]
[(cltd) (C #x99 ac)] [(cltd) (C #x99 ac)]
@ -719,14 +747,22 @@
(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
[(imm? dst) (CODE #xE9 (IMM32 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)] [(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
[(imm? dst) (CODE #xE8 (IMM32 dst ac))] [(imm? dst)
(if (= wordsize 4)
(CODE #xE8 (IMM32 dst ac))
(jmp-pc-relative #xFF #x15 dst ac))]
[(mem? dst) (CR* #xFF '/2 dst ac)] [(mem? dst) (CR* #xFF '/2 dst ac)]
[(reg? dst) (CR* #xFF '/2 dst ac)] [(reg? dst) (CR* #xFF '/2 dst ac)]
[else (die who "invalid jmp target" dst)])] [else (die who "invalid jmp target" dst)])]
@ -824,12 +860,13 @@
[(label) ac] [(label) ac]
[(word reloc-word reloc-word+ label-addr [(word reloc-word reloc-word+ label-addr
current-frame-offset foreign-label) current-frame-offset foreign-label)
(+ ac wordsize)] (fx+ ac wordsize)]
[(bottom-code)
(fx+ ac (compute-code-size (cdr x)))]
[else (die 'compute-code-size "unknown instr" x)]))) [else (die 'compute-code-size "unknown instr" x)])))
0 0
ls))) ls)))
(define set-label-loc! (define set-label-loc!
(lambda (x loc) (lambda (x loc)
(when (getprop x '*label-loc*) (when (getprop x '*label-loc*)
@ -841,7 +878,6 @@
(or (getprop x '*label-loc*) (or (getprop x '*label-loc*)
(die 'compile "undefined label" x)))) (die 'compile "undefined label" x))))
(define unset-label-loc! (define unset-label-loc!
(lambda (x) (lambda (x)
(remprop x '*label-loc*))) (remprop x '*label-loc*)))
@ -868,22 +904,57 @@
(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 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 (optimize-local-jumps ls) (define (optimize-local-jumps ls)
(define locals '()) (define locals '())
(define g (gensym)) (define g (gensym))
(for-each (define (mark x)
(lambda (x) (when (pair? x)
(when (and (pair? x) (eq? (car x) 'label)) (case (car x)
(putprop (cdr x) g 'local) [(label)
(set! locals (cons (cdr x) locals)))) (putprop (cdr x) g 'local)
ls) (set! locals (cons (cdr x) locals))]
(for-each [(bottom-code) (for-each mark (cdr x))])))
(lambda (x) (define (opt x)
(when (and (pair? x) (when (pair? x)
(eq? (car x) 'relative) (case (car x)
(eq? (getprop (cdr x) g) 'local)) [(relative)
(set-car! x 'local-relative))) (when (eq? (getprop (cdr x) g) 'local)
ls) (set-car! x 'local-relative))]
[(bottom-code) (for-each opt (cdr x))])))
(for-each mark ls)
(for-each opt ls)
(for-each (lambda (x) (remprop x g)) locals) (for-each (lambda (x) (remprop x g)) locals)
ls) ls)
@ -892,37 +963,41 @@
(define whack-instructions (define whack-instructions
(lambda (x ls) (lambda (x ls)
(define f (define f
(lambda (ls idx reloc) (lambda (ls idx reloc bot*)
(cond (cond
[(null? ls) reloc] [(null? ls)
(if (null? bot*)
reloc
(f (car bot*) idx reloc (cdr bot*)))]
[else [else
(let ([a (car ls)]) (let ([a (car ls)])
(if (fixnum? a) (if (fixnum? a)
(begin (begin
(code-set! x idx a) (code-set! x idx a)
(f (cdr ls) (fxadd1 idx) reloc)) (f (cdr ls) (fxadd1 idx) reloc bot*))
(case (car a) (case (car a)
[(byte) [(byte)
(code-set! x idx (cdr a)) (code-set! x idx (cdr a))
(f (cdr ls) (fx+ idx 1) reloc)] (f (cdr ls) (fx+ idx 1) reloc bot*)]
[(relative local-relative) [(relative local-relative)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc) bot*)]
[(reloc-word reloc-word+ label-addr foreign-label) [(reloc-word reloc-word+ label-addr foreign-label)
(f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))] (f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc) bot*)]
[(word) [(word)
(let ([v (cdr a)]) (let ([v (cdr a)])
(set-code-word! x idx v) (set-code-word! x idx v)
(f (cdr ls) (fx+ idx wordsize) reloc))] (f (cdr ls) (fx+ idx wordsize) reloc bot*))]
[(current-frame-offset) [(current-frame-offset)
(set-code-word! x idx idx) ;;; FIXME 64bit (set-code-word! x idx idx) ;;; FIXME 64bit
(f (cdr ls) (fx+ idx wordsize) reloc)] (f (cdr ls) (fx+ idx wordsize) reloc bot*)]
[(label) [(label)
(set-label-loc! (cdr a) (list x idx)) (set-label-loc! (cdr a) (list x idx))
(f (cdr ls) idx reloc)] (f (cdr ls) idx reloc bot*)]
[(bottom-code)
(f (cdr ls) idx reloc (cons (cdr a) bot*))]
[else [else
(die 'whack-instructions "unknown instr" a)])))]))) (die 'whack-instructions "unknown instr" a)])))])))
(f ls 0 '()))) (f ls 0 '() '())))
(define compute-reloc-size (define compute-reloc-size
(lambda (ls) (lambda (ls)
@ -930,9 +1005,10 @@
(if (fixnum? x) (if (fixnum? x)
ac ac
(case (car x) (case (car x)
[(word byte label current-frame-offset local-relative) ac]
[(reloc-word foreign-label) (fx+ ac 2)] [(reloc-word foreign-label) (fx+ ac 2)]
[(relative reloc-word+ label-addr) (fx+ ac 3)] [(relative reloc-word+ label-addr) (fx+ ac 3)]
[(word byte label current-frame-offset local-relative) ac] [(bottom-code) (fx+ ac (compute-reloc-size (cdr x)))]
[else (die 'compute-reloc-size "unknown instr" x)]))) [else (die 'compute-reloc-size "unknown instr" x)])))
0 0
ls))) ls)))
@ -1031,14 +1107,6 @@
[else (die 'whack-reloc "invalid reloc type" type)])) [else (die 'whack-reloc "invalid reloc type" type)]))
))) )))
(define (instruction-size x)
(unless (and (pair? x) (getprop (car x) *cogen*))
(die 'instruction-size "not an instruction" x))
;;; limitations: does not work if the instruction contains
;;; a jump to a local label, and the jump is later optimized
;;; to a short jump.
(compute-code-size
(convert-instruction x '())))
(define assemble-sources (define assemble-sources
@ -1056,6 +1124,8 @@
(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 @@
1865 1866