Skip to content

Commit

Permalink
Fix LDB and DPB instructions on ARM64.
Browse files Browse the repository at this point in the history 
Don't transform LDB/DPB to UBFM/BFM when the modification would touch
the sign bits or not fit in the primitive types.
  • Loading branch information
@stassats
stassats committed Dec 23, 2016
1 parent 32fe3b5 commit 86a0d4b
Show file tree
Hide file tree
Showing 4 changed files with 79 additions and 48 deletions.
8 changes: 6 additions & 2 deletions src/compiler/arm64/arith.lisp
View file
Expand Up @@ -684,7 +684,9 @@
(:policy :fast-safe)
(:generator 3
(move res y)
(inst bfm res x (- n-word-bits posn) (1- size))))
(inst bfm res x (if (= posn 0)
0
(- n-word-bits posn)) (1- size))))

(define-vop (dpb-c/unsigned)
(:translate %%dpb)
Expand All @@ -699,7 +701,9 @@
(:policy :fast-safe)
(:generator 3
(move res y)
(inst bfm res x (- n-word-bits posn) (1- size))))
(inst bfm res x (if (= posn 0)
0
(- n-word-bits posn)) (1- size))))

;;; Modular functions
(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
Expand Down
46 changes: 23 additions & 23 deletions src/compiler/arm64/macros.lisp
View file
Expand Up @@ -396,19 +396,19 @@
(:result-types ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
,@(ecase size (eq size :byte)
(:byte
`((inst add lip object index)
(inst ,(if signed 'ldrsb 'ldrb)
value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:short
`((inst add lip object (lsl index 1))
(inst ,(if signed 'ldrsh 'ldrh)
value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:word
`((inst add lip object (lsl index 2))
(inst ,(if signed 'ldrsw 'ldr) (32-bit-reg value)
(@ lip (- (* ,offset n-word-bytes) ,lowtag)))))))))
,@(ecase size
(:byte
`((inst add lip object index)
(inst ,(if signed 'ldrsb 'ldrb)
value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:short
`((inst add lip object (lsl index 1))
(inst ,(if signed 'ldrsh 'ldrh)
value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:word
`((inst add lip object (lsl index 2))
(inst ,(if signed 'ldrsw 'ldr) (32-bit-reg value)
(@ lip (- (* ,offset n-word-bytes) ,lowtag)))))))))

(defmacro define-partial-setter (name type size offset lowtag scs el-type
&optional translate)
Expand All @@ -424,16 +424,16 @@
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 5
,@(ecase size (eq size :byte)
(:byte
`((inst add lip object index)
(inst strb value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:short
`((inst add lip object (lsl index 1))
(inst strh value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:word
`((inst add lip object (lsl index 2))
(inst str (32-bit-reg value) (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
,@(ecase size
(:byte
`((inst add lip object index)
(inst strb value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:short
`((inst add lip object (lsl index 1))
(inst strh value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
(:word
`((inst add lip object (lsl index 2))
(inst str (32-bit-reg value) (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
(move result value))))

(sb!xc:defmacro with-pinned-objects ((&rest objects) &body body)
Expand Down
35 changes: 12 additions & 23 deletions src/compiler/arm64/vm.lisp
View file
Expand Up @@ -311,15 +311,13 @@
`(function ,args ,result)))))
(case (sb!c::combination-fun-source-name node)
(logtest
(if (or (valid-funtype '(fixnum fixnum) '*)
(valid-funtype '(signed-word signed-word) '*)
(if (or (valid-funtype '(signed-word signed-word) '*)
(valid-funtype '(word word) '*))
(values :maybe nil)
(values :default nil)))
(logbitp
(cond
((or (valid-funtype '((constant-arg (integer 0 #.(1- n-fixnum-bits))) fixnum) '*)
(valid-funtype '((constant-arg (integer 0 #.(1- n-word-bits))) signed-word) '*)
((or (valid-funtype '((constant-arg (integer 0 #.(1- n-word-bits))) signed-word) '*)
(valid-funtype '((constant-arg (integer 0 #.(1- n-word-bits))) word) '*))
(values :transform '(lambda (index integer)
(%logbitp integer index))))
Expand All @@ -337,29 +335,20 @@
(<= (+ (sb!c::lvar-value size)
(sb!c::lvar-value posn))
width))))))
(if (or (validp 'fixnum n-fixnum-bits)
(validp '(signed-byte 64) 64)
(validp '(unsigned-byte 64) 64))
(if (or (validp 'word (1- n-word-bits))
(validp 'signed-word (1- n-word-bits)))
(values :transform '(lambda (size posn integer)
(%%ldb integer size posn)))
(values :default nil))))
(%dpb
(flet ((validp (type width)
(and (valid-funtype `(,type
(constant-arg (mod ,width))
(constant-arg (mod ,width))
,type)
'integer)
(destructuring-bind (newbyte size posn integer)
(sb!c::basic-combination-args node)
(declare (ignore integer newbyte))
(and (plusp (sb!c::lvar-value posn))
(<= (+ (sb!c::lvar-value size)
(sb!c::lvar-value posn))
width))))))
(if (or (validp 'fixnum n-fixnum-bits)
(validp '(signed-byte 64) 64)
(validp '(unsigned-byte 64) 64))
(flet ((validp (type result-type)
(valid-funtype `(,type
(constant-arg (mod ,n-word-bits))
(constant-arg (mod ,n-word-bits))
,type)
result-type)))
(if (or (validp 'signed-word 'signed-word)
(validp 'word 'word))
(values :transform '(lambda (newbyte size posn integer)
(%%dpb newbyte size posn integer)))
(values :default nil))))
Expand Down
38 changes: 38 additions & 0 deletions tests/arith.pure.lisp
View file
Expand Up @@ -745,3 +745,41 @@
(with-test (:name :bignum-ashift-left-fixnum)
(assert (= (eval '(ash most-negative-fixnum (1- sb-vm:n-word-bits)))
(eval '(* most-negative-fixnum (expt 2 (1- sb-vm:n-word-bits)))))))

(with-test (:name :fixnum-ldb-sign-bits)
(let ((fun (checked-compile `(lambda (x)
(declare (fixnum x))
(ldb (byte (/ sb-vm:n-word-bits 2)
(/ sb-vm:n-word-bits 2)) x)))))
(assert (= (funcall fun
most-positive-fixnum)
(ash most-positive-fixnum (- (/ sb-vm:n-word-bits 2)))))
(assert (= (funcall fun -1)
(1- (expt 2 (/ sb-vm:n-word-bits 2)))))))

(with-test (:name :dpb-sign-bits)
(let ((fun (checked-compile `(lambda (x)
(declare (fixnum x))
(dpb 1 (byte (/ sb-vm:n-word-bits 2)
(/ sb-vm:n-word-bits 2)) x)))))
(assert (= (funcall fun -1)
(logior (ash 1 (/ sb-vm:n-word-bits 2))
(logandc2 -1
(mask-field (byte (/ sb-vm:n-word-bits 2)
(/ sb-vm:n-word-bits 2))
-1)))))
(assert (= (funcall fun most-positive-fixnum)
(logior (ash 1 (/ sb-vm:n-word-bits 2))
(logandc2 most-positive-fixnum
(mask-field (byte (/ sb-vm:n-word-bits 2)
(/ sb-vm:n-word-bits 2))
-1)))))))

(with-test (:name :dpb-position-zero)
(let ((fun (checked-compile `(lambda (x)
(declare (sb-vm:word x))
(dpb 0 (byte (/ sb-vm:n-word-bits 2) 0) x)))))
(assert (= (funcall fun 1) 0))
(assert (= (funcall fun sb-ext:most-positive-word)
(logxor sb-ext:most-positive-word
(1- (expt 2 (/ sb-vm:n-word-bits 2))))))))

0 comments on commit 86a0d4b

Please sign in to comment.