mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Fix cross-compilation of immediates to targets with different word sizes

Browse source 
* module/system/vm/assembler.scm (immediate-bits): Rename from
  immediate?, and return the bits.  Take asm argument so that we measure
  what's an immediate not on the host but for the target.  Adapt all
  callers.
  (write-immediate): Take bits instead of SCM object.  Adapt callers.
  (write-placeholder): New helper, to write bits for #f.  Adapt callers
  that wrote #f to use write-placeholder.
This commit is contained in:
Andy Wingo 2016-01-29 09:50:32 +01:00
parent f61870979c
commit e4be4aea34
1 changed files with 61 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

93
module/system/vm/assembler.scm
View file

@ -919,9 +919,32 @@ lists. This procedure can be called many times before calling
;;; to the table. ;;; to the table.
;;; ;;;
(define-inline (immediate? x) (define tc2-int 2)
"Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise." (define (immediate-bits asm x)
(not (zero? (logand (object-address x) 6)))) "Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise."
(let* ((bits (object-address x))
(mask (case (asm-word-size asm)
((4) #xffffffff)
((8) #xffffffffFFFFFFFF)
(else (error "unexpected word size"))))
(fixnum-min (1- (ash mask -3)))
(fixnum-max (ash mask -3)))
(cond
((not (zero? (logand bits 6)))
;; Object is an immediate on the host. It's immediate if it can
;; fit into a word on the target.
(and (= bits (logand bits mask))
bits))
((and (exact-integer? x) (<= fixnum-min x fixnum-max))
;; Object is a bignum that would be an immediate on the target.
(let ((fixnum-bits (if (negative? x)
(+ fixnum-max 1 (logand x fixnum-max))
x)))
(logior (ash x 2) tc2-int)))
(else
;; Otherwise not an immediate.
#f))))
(define-record-type <stringbuf> (define-record-type <stringbuf>
(make-stringbuf string) (make-stringbuf string)
@ -1025,7 +1048,7 @@ table, its existing label is used directly."
(else (else
(error "don't know how to intern" obj)))) (error "don't know how to intern" obj))))
(cond (cond
((immediate? obj) #f) ((immediate-bits asm obj) #f)
((vhash-assoc obj (asm-constants asm)) => cdr) ((vhash-assoc obj (asm-constants asm)) => cdr)
(else (else
;; Note that calling intern may mutate asm-constants and asm-inits. ;; Note that calling intern may mutate asm-constants and asm-inits.
@ -1038,7 +1061,7 @@ table, its existing label is used directly."
(define (intern-non-immediate asm obj) (define (intern-non-immediate asm obj)
"Intern a non-immediate into the constant table, and return its "Intern a non-immediate into the constant table, and return its
label." label."
(when (immediate? obj) (when (immediate-bits asm obj)
(error "expected a non-immediate" obj)) (error "expected a non-immediate" obj))
(intern-constant asm obj)) (intern-constant asm obj))
@ -1076,15 +1099,15 @@ returned instead."
(define-macro-assembler (load-constant asm dst obj) (define-macro-assembler (load-constant asm dst obj)
(cond (cond
((immediate? obj) ((immediate-bits asm obj)
(let ((bits (object-address obj))) => (lambda (bits)
(cond (cond
((and (< dst 256) (zero? (ash bits -16))) ((and (< dst 256) (zero? (ash bits -16)))
(emit-make-short-immediate asm dst obj)) (emit-make-short-immediate asm dst obj))
((zero? (ash bits -32)) ((zero? (ash bits -32))
(emit-make-long-immediate asm dst obj)) (emit-make-long-immediate asm dst obj))
(else (else
(emit-make-long-long-immediate asm dst obj))))) (emit-make-long-long-immediate asm dst obj)))))
((statically-allocatable? obj) ((statically-allocatable? obj)
(emit-make-non-immediate asm dst (intern-non-immediate asm obj))) (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
(else (else
@ -1290,14 +1313,16 @@ corresponding linker symbol for the start of the section."
;;; residualizes instructions to initialize constants at load time. ;;; residualizes instructions to initialize constants at load time.
;;; ;;;
(define (write-immediate asm buf pos x) (define (write-immediate asm buf pos bits)
(let ((val (object-address x)) (let ((endianness (asm-endianness asm)))
(endianness (asm-endianness asm)))
(case (asm-word-size asm) (case (asm-word-size asm)
((4) (bytevector-u32-set! buf pos val endianness)) ((4) (bytevector-u32-set! buf pos bits endianness))
((8) (bytevector-u64-set! buf pos val endianness)) ((8) (bytevector-u64-set! buf pos bits endianness))
(else (error "bad word size" asm))))) (else (error "bad word size" asm)))))
(define (write-placeholder asm buf pos)
(write-immediate asm buf pos (immediate-bits asm #f)))
(define (emit-init-constants asm) (define (emit-init-constants asm)
"If there is writable data that needs initialization at runtime, emit "If there is writable data that needs initialization at runtime, emit
a procedure to do that and return its label. Otherwise return a procedure to do that and return its label. Otherwise return
@ -1365,8 +1390,12 @@ should be .data or .rodata), and return the resulting linker object.
word-size))) word-size)))
(define (write-constant-reference buf pos x) (define (write-constant-reference buf pos x)
;; The asm-inits will fix up any reference to a non-immediate. (let ((bits (immediate-bits asm x)))
(write-immediate asm buf pos (if (immediate? x) x #f))) (if bits
(write-immediate asm buf pos bits)
;; The asm-inits will fix up any reference to a
;; non-immediate.
(write-placeholder asm buf pos))))
(define (write buf pos obj) (define (write buf pos obj)
(cond (cond
@ -1414,19 +1443,19 @@ should be .data or .rodata), and return the resulting linker object.
(else (error "bad word size")))) (else (error "bad word size"))))
((cache-cell? obj) ((cache-cell? obj)
(write-immediate asm buf pos #f)) (write-placeholder asm buf pos))
((string? obj) ((string? obj)
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused? (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
(case word-size (case word-size
((4) ((4)
(bytevector-u32-set! buf pos tc7-ro-string endianness) (bytevector-u32-set! buf pos tc7-ro-string endianness)
(write-immediate asm buf (+ pos 4) #f) ; stringbuf (write-placeholder asm buf (+ pos 4)) ; stringbuf
(bytevector-u32-set! buf (+ pos 8) 0 endianness) (bytevector-u32-set! buf (+ pos 8) 0 endianness)
(bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness)) (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
((8) ((8)
(bytevector-u64-set! buf pos tc7-ro-string endianness) (bytevector-u64-set! buf pos tc7-ro-string endianness)
(write-immediate asm buf (+ pos 8) #f) ; stringbuf (write-placeholder asm buf (+ pos 8)) ; stringbuf
(bytevector-u64-set! buf (+ pos 16) 0 endianness) (bytevector-u64-set! buf (+ pos 16) 0 endianness)
(bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness)) (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
(else (error "bad word size"))))) (else (error "bad word size")))))
@ -1450,13 +1479,13 @@ should be .data or .rodata), and return the resulting linker object.
(lp (1+ i))))))) (lp (1+ i)))))))
((symbol? obj) ((symbol? obj)
(write-immediate asm buf pos #f)) (write-placeholder asm buf pos))
((keyword? obj) ((keyword? obj)
(write-immediate asm buf pos #f)) (write-placeholder asm buf pos))
((number? obj) ((number? obj)
(write-immediate asm buf pos #f)) (write-placeholder asm buf pos))
((simple-uniform-vector? obj) ((simple-uniform-vector? obj)
(let ((tag (if (bitvector? obj) (let ((tag (if (bitvector? obj)
@ -1472,7 +1501,7 @@ should be .data or .rodata), and return the resulting linker object.
(bytevector-length obj)) (bytevector-length obj))
endianness) ; length endianness) ; length
(bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
(write-immediate asm buf (+ pos 12) #f)) ; owner (write-placeholder asm buf (+ pos 12))) ; owner
((8) ((8)
(bytevector-u64-set! buf pos tag endianness) (bytevector-u64-set! buf pos tag endianness)
(bytevector-u64-set! buf (+ pos 8) (bytevector-u64-set! buf (+ pos 8)
@ -1481,7 +1510,7 @@ should be .data or .rodata), and return the resulting linker object.
(bytevector-length obj)) (bytevector-length obj))
endianness) ; length endianness) ; length
(bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
(write-immediate asm buf (+ pos 24) #f)) ; owner (write-placeholder asm buf (+ pos 24))) ; owner
(else (error "bad word size"))))) (else (error "bad word size")))))
((uniform-vector-backing-store? obj) ((uniform-vector-backing-store? obj)
@ -1502,7 +1531,7 @@ should be .data or .rodata), and return the resulting linker object.
((8) (values bytevector-u64-set! bytevector-s64-set!)) ((8) (values bytevector-u64-set! bytevector-s64-set!))
(else (error "bad word size"))))) (else (error "bad word size")))))
(bv-set! buf pos tag endianness) (bv-set! buf pos tag endianness)
(write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later) (write-placeholder asm buf (+ pos word-size)) ; root vector (fixed later)
(bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
(let lp ((pos (+ pos (* word-size 3))) (let lp ((pos (+ pos (* word-size 3)))
(bounds (array-shape obj)) (bounds (array-shape obj))
@ -1548,11 +1577,11 @@ these may be @code{#f}."
(cond (cond
((stringbuf? x) #t) ((stringbuf? x) #t)
((pair? x) ((pair? x)
(and (immediate? (car x)) (immediate? (cdr x)))) (and (immediate-bits asm (car x)) (immediate-bits asm (cdr x))))
((simple-vector? x) ((simple-vector? x)
(let lp ((i 0)) (let lp ((i 0))
(or (= i (vector-length x)) (or (= i (vector-length x))
(and (immediate? (vector-ref x i)) (and (immediate-bits asm (vector-ref x i))
(lp (1+ i)))))) (lp (1+ i))))))
((uniform-vector-backing-store? x) #t) ((uniform-vector-backing-store? x) #t)
(else #f))) (else #f)))