X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ftype-vops.lisp;h=0727ca69052e43f5c706c6aa4f0225565d1bcf75;hb=3d544b84f2b7ecd617d220145a775079df6c7919;hp=2ba4b7e3fbaeeea3e63e4a5a6ccddb88149897d5;hpb=4dc4761909992ceb346d003f3fb19e5c837ee985;p=sbcl.git diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index 2ba4b7e..0727ca6 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/src/compiler/x86-64/type-vops.lisp @@ -1,4 +1,4 @@ -;;;; type testing and checking VOPs for the x86 VM +;;;; type testing and checking VOPs for the x86-64 VM ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -13,24 +13,25 @@ ;;;; test generation utilities -(defun make-byte-tn (tn) - (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg)) - (make-random-tn :kind :normal - :sc (sc-or-lose 'byte-reg) - :offset (tn-offset tn))) +;;; Optimize the case of moving a 64-bit value into RAX when not caring +;;; about the upper 32 bits: often the REX prefix can be spared. +(defun move-qword-to-eax (value) + (if (and (sc-is value any-reg descriptor-reg) + (< (tn-offset value) r8-offset)) + (move eax-tn (make-dword-tn value)) + (move rax-tn value))) (defun generate-fixnum-test (value) "zero flag set if VALUE is fixnum" - (let ((offset (tn-offset value))) - ;; The x86 backend uses a pun from E[A-D]X -> [A-D]L for these - ;; tests. The Athlon 64 optimization guide says that this is a - ;; bad idea, so it's been removed. - (cond ((sc-is value control-stack) - (inst test (make-ea :byte :base rbp-tn - :disp (- (* (1+ offset) n-word-bytes))) - sb!vm::fixnum-tag-mask)) - (t - (inst test value sb!vm::fixnum-tag-mask))))) + (inst test + (cond ((sc-is value any-reg descriptor-reg) + (make-byte-tn value)) + ((sc-is value control-stack) + (make-ea :byte :base rbp-tn + :disp (frame-byte-offset (tn-offset value)))) + (t + value)) + sb!vm::fixnum-tag-mask)) (defun %test-fixnum (value target not-p) (generate-fixnum-test value) @@ -49,73 +50,103 @@ (%test-immediate value target not-p immediate drop-through))) (defun %test-fixnum-immediate-and-headers (value target not-p immediate - headers) + headers) (let ((drop-through (gen-label))) (generate-fixnum-test value) (inst jmp :z (if not-p drop-through target)) (%test-immediate-and-headers value target not-p immediate headers - drop-through))) + drop-through))) (defun %test-immediate (value target not-p immediate - &optional (drop-through (gen-label))) + &optional (drop-through (gen-label))) ;; Code a single instruction byte test if possible. (cond ((sc-is value any-reg descriptor-reg) - (inst cmp (make-byte-tn value) immediate)) - (t - (move rax-tn value) - (inst cmp al-tn immediate))) - (inst jmp (if not-p :ne :e) target) - (emit-label drop-through)) + (inst cmp (make-byte-tn value) immediate)) + (t + (move rax-tn value) + (inst cmp al-tn immediate))) + (inst jmp (if not-p :ne :e) target) + (emit-label drop-through)) (defun %test-immediate-and-headers (value target not-p immediate headers - &optional (drop-through (gen-label))) + &optional (drop-through (gen-label))) ;; Code a single instruction byte test if possible. (cond ((sc-is value any-reg descriptor-reg) - (inst cmp (make-byte-tn value) immediate)) - (t - (move rax-tn value) - (inst cmp al-tn immediate))) + (inst cmp (make-byte-tn value) immediate)) + (t + (move rax-tn value) + (inst cmp al-tn immediate))) (inst jmp :e (if not-p drop-through target)) (%test-headers value target not-p nil headers drop-through)) (defun %test-lowtag (value target not-p lowtag) - (move rax-tn value) - (inst and rax-tn lowtag-mask) - (inst cmp rax-tn lowtag) - (inst jmp (if not-p :ne :e) target)) + (inst lea eax-tn (make-ea :dword :base value :disp (- lowtag))) + (inst test al-tn lowtag-mask) + (inst jmp (if not-p :nz :z) target)) (defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label))) + &optional (drop-through (gen-label))) (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) - (multiple-value-bind (equal less-or-equal when-true when-false) - ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. - ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know - ;; it's true and when we know it's false respectively. - (if not-p - (values :ne :a drop-through target) - (values :e :na target drop-through)) + (multiple-value-bind (equal less-or-equal greater-or-equal when-true + when-false) + ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions + ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the + ;; labels to branch to when we know it's true and when we know + ;; it's false respectively. + (if not-p + (values :ne :a :b drop-through target) + (values :e :na :nb target drop-through)) (%test-lowtag value when-false t lowtag) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (inst cmp al-tn header) - (if last - (inst jmp equal target) - (inst jmp :e when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (unless (= start bignum-widetag) - (inst cmp al-tn start) - (inst jmp :b when-false)) ; was :l - (inst cmp al-tn end) - (if last - (inst jmp less-or-equal target) - (inst jmp :be when-true))))))) ; was :le + (do ((remaining headers (cdr remaining)) + ;; It is preferable (smaller and faster code) to directly + ;; compare the value in memory instead of loading it into + ;; a register first. Find out if this is possible and set + ;; WIDETAG-TN accordingly. If impossible, generate the + ;; register load. + ;; Compared to x86 we additionally optimize the cases of a + ;; range starting with BIGNUM-WIDETAG or ending with + ;; COMPLEX-ARRAY-WIDETAG. + (widetag-tn (if (and (null (cdr headers)) + (or (atom (car headers)) + (= (caar headers) bignum-widetag) + (= (cdar headers) complex-array-widetag))) + (make-ea :byte :base value :disp (- lowtag)) + (progn + (inst mov eax-tn (make-ea :dword :base value + :disp (- lowtag))) + al-tn)))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst cmp widetag-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (cond + ((= start bignum-widetag) + (inst cmp widetag-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))) + ((= end complex-array-widetag) + (inst cmp widetag-tn start) + (if last + (inst jmp greater-or-equal target) + (inst jmp :b when-false))) + ((not last) + (inst cmp al-tn start) + (inst jmp :b when-false) + (inst cmp al-tn end) + (inst jmp :be when-true)) + (t + (inst sub al-tn start) + (inst cmp al-tn (- end start)) + (inst jmp less-or-equal target)))))))) (emit-label drop-through)))) @@ -141,8 +172,8 @@ (define-vop (simple-check-type) (:args (value :target result :scs (any-reg descriptor-reg))) (:results (result :scs (any-reg descriptor-reg) - :load-if (not (and (sc-is value any-reg descriptor-reg) - (sc-is result control-stack))))) + :load-if (not (and (sc-is value any-reg descriptor-reg) + (sc-is result control-stack))))) (:vop-var vop) (:save-p :compute-only)) @@ -152,34 +183,33 @@ (:info target not-p) (:policy :fast-safe)) -(defun cost-to-test-types (type-codes) - (+ (* 2 (length type-codes)) - (if (> (apply #'max type-codes) lowtag-limit) 7 2))) - (defmacro !define-type-vops (pred-name check-name ptype error-code - (&rest type-codes) - &key (variant nil variant-p) &allow-other-keys) + (&rest type-codes) + &key (variant nil variant-p) &allow-other-keys) ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the ;; expansion? - (let* ((cost (cost-to-test-types (mapcar #'eval type-codes))) - (prefix (if variant-p - (concatenate 'string (string variant) "-") - ""))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) - (:translate ,pred-name) - (:generator ,cost - (test-type value target not-p (,@type-codes)))))) - ,@(when check-name - `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value err-lab t (,@type-codes)) - (move result value)))))) - ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) + (flet ((cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2)))) + (let* ((cost (cost-to-test-types (mapcar #'eval type-codes))) + (prefix (if variant-p + (concatenate 'string (string variant) "-") + ""))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p (,@type-codes)))))) + ,@(when check-name + `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ',error-code value))) + (test-type value err-lab t (,@type-codes)) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype))))))) ;;;; other integer ranges @@ -187,68 +217,81 @@ (:args (value :scs (unsigned-reg))) (:arg-types unsigned-num) (:translate fixnump) - (:temporary (:sc unsigned-reg) tmp) + (:temporary (:sc unsigned-reg :from (:argument 0)) tmp) + (:info) + (:conditional :z) (:generator 5 - (inst mov tmp value) - (inst shr tmp 61) - (inst jmp (if not-p :nz :z) target))) - -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:generator 7 - ;; (and (fixnum) (or (no bits set >31) (all bits set >31)) - (move rax-tn value) - (inst test rax-tn 7) - (inst jmp :ne (if not-p target NOT-TARGET)) - (inst sar rax-tn (+ 32 3 -1)) - (if not-p - (progn - (inst jmp :nz MAYBE) - (inst jmp NOT-TARGET)) - (inst jmp :z target)) - MAYBE - (inst cmp rax-tn -1) - (inst jmp (if not-p :ne :eq) target) - NOT-TARGET)) - -(define-vop (check-signed-byte-32 check-type) - (:generator 8 - (let ((nope (generate-error-code vop - object-not-signed-byte-32-error - value)) - (ok (gen-label))) - (move rax-tn value) - (inst test rax-tn 7) - (inst jmp :ne nope) - (inst sar rax-tn (+ 32 3 -1)) - (inst jmp :z ok) - (inst cmp rax-tn -1) - (inst jmp :ne nope) - (emit-label ok) - (move result value)))) + (move tmp value) + (inst shr tmp n-positive-fixnum-bits))) + +#-#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or)) +(define-vop (fixnump/signed-byte-64 simple-type-predicate) + (:args (value :scs (signed-reg))) + (:info) + (:conditional :z) + (:temporary (:sc unsigned-reg :offset eax-offset) eax) + (:arg-types signed-num) + (:translate fixnump) + (:generator 5 + ;; Hackers Delight, p. 53: signed + ;; a <= x <= a + 2^n - 1 + ;; is equivalent to unsigned + ;; ((x-a) >> n) = 0 + (inst mov rax-tn #.(- sb!xc:most-negative-fixnum)) + (inst add rax-tn value) + (inst shr rax-tn n-fixnum-bits))) + +#+#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or)) +(define-vop (fixnump/signed-byte-64 simple-type-predicate) + (:args (value :scs (signed-reg) :target temp)) + (:info) + (:conditional :no) + (:temporary (:sc unsigned-reg :from (:argument 0)) temp) + (:arg-types signed-num) + (:translate fixnump) + (:generator 5 + (move temp value) + ;; The overflow flag will be set if the reg's sign bit changes. + (inst shl temp 1))) +;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with +;;; exactly one digit. -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:generator 7 - ;; (and (fixnum) (no bits set >31)) - (move rax-tn value) - (inst test rax-tn 7) - (inst jmp :ne (if not-p target NOT-TARGET)) - (inst shr rax-tn (+ 32 sb!vm::n-fixnum-tag-bits)) - (inst jmp (if not-p :nz :z) target) +(define-vop (signed-byte-64-p type-predicate) + (:translate signed-byte-64-p) + (:generator 45 + (multiple-value-bind (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (move-qword-to-eax value) + (inst test al-tn fixnum-tag-mask) + (inst jmp :e yep) + + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) + (inst jmp :ne nope) + (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag) + (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp (if not-p :ne :e) target)) NOT-TARGET)) -(define-vop (check-unsigned-byte-32 check-type) - (:generator 8 - (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value))) - (move rax-tn value) - (inst test rax-tn 7) +(define-vop (check-signed-byte-64 check-type) + (:generator 45 + (let ((nope (generate-error-code vop + 'object-not-signed-byte-64-error + value))) + (generate-fixnum-test value) + (inst jmp :e yep) + (move-qword-to-eax value) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) - (inst shr rax-tn (+ 32 sb!vm::n-fixnum-tag-bits)) - (inst jmp :nz nope) - (move result value)))) + (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag) + (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp :ne nope)) + YEP + (move result value))) ;;; An (unsigned-byte 64) can be represented with either a positive ;;; fixnum, a bignum with exactly one positive digit, or a bignum with @@ -257,90 +300,147 @@ (:translate unsigned-byte-64-p) (:generator 45 (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (gen-label))) + (single-word (gen-label)) + (fixnum (gen-label))) (multiple-value-bind (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fixnum? - (generate-fixnum-test value) - (move eax-tn value) - (inst jmp :e fixnum) - - ;; If not, is it an other pointer? - (inst and eax-tn lowtag-mask) - (inst cmp eax-tn other-pointer-lowtag) - (inst jmp :ne nope) - ;; Get the header. - (loadw eax-tn value 0 other-pointer-lowtag) - ;; Is it one? - (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) - (inst jmp :e single-word) - ;; If it's other than two, we can't be an (unsigned-byte 64) - (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) - (inst jmp :ne nope) - ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 64). - (inst or eax-tn eax-tn) - (inst jmp :z yep) - (inst jmp nope) - - (emit-label single-word) - ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) - - ;; positive implies (unsigned-byte 64). - (emit-label fixnum) - (inst or eax-tn eax-tn) - (inst jmp (if not-p :s :ns) target) - - (emit-label not-target))))) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (move rax-tn value) + (inst test al-tn fixnum-tag-mask) + (inst jmp :e fixnum) + + ;; If not, is it an other pointer? + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) + (inst jmp :ne nope) + ;; Get the header. + (loadw rax-tn value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 64) + (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 64). + (inst test rax-tn rax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw rax-tn value bignum-digits-offset other-pointer-lowtag) + + ;; positive implies (unsigned-byte 64). + (emit-label fixnum) + (inst test rax-tn rax-tn) + (inst jmp (if not-p :s :ns) target) + + (emit-label not-target))))) (define-vop (check-unsigned-byte-64 check-type) (:generator 45 (let ((nope - (generate-error-code vop object-not-unsigned-byte-64-error value)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) + (generate-error-code vop 'object-not-unsigned-byte-64-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) ;; Is it a fixnum? (generate-fixnum-test value) - (move eax-tn value) + (move rax-tn value) (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and eax-tn lowtag-mask) - (inst cmp eax-tn other-pointer-lowtag) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) ;; Get the header. - (loadw eax-tn value 0 other-pointer-lowtag) + (loadw rax-tn value 0 other-pointer-lowtag) ;; Is it one? - (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) (inst jmp :e single-word) ;; If it's other than two, we can't be an (unsigned-byte 64) - (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) (inst jmp :ne nope) ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) + (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) ;; All zeros, its an (unsigned-byte 64). - (inst or eax-tn eax-tn) + (inst test rax-tn rax-tn) (inst jmp :z yep) (inst jmp nope) - + (emit-label single-word) ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) + (loadw rax-tn value bignum-digits-offset other-pointer-lowtag) ;; positive implies (unsigned-byte 64). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst test rax-tn rax-tn) (inst jmp :s nope) (emit-label yep) (move result value)))) + +(defun power-of-two-limit-p (x) + (and (fixnump x) + (= (logcount (1+ x)) 1))) + +(define-vop (test-fixnum-mod-power-of-two) + (:args (value :scs (any-reg descriptor-reg + unsigned-reg signed-reg + immediate))) + (:arg-types * + (:constant (satisfies power-of-two-limit-p))) + (:translate fixnum-mod-p) + (:conditional :e) + (:info hi) + (:save-p :compute-only) + (:policy :fast-safe) + (:generator 4 + (aver (not (sc-is value immediate))) + (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) + hi + (fixnumize hi)))) + (inst test value (constantize (lognot fixnum-hi)))))) + +(define-vop (test-fixnum-mod-tagged-unsigned) + (:args (value :scs (any-reg descriptor-reg + unsigned-reg signed-reg + immediate))) + (:arg-types (:or tagged-num unsigned-num signed-num) + (:constant fixnum)) + (:translate fixnum-mod-p) + (:conditional :be) + (:info hi) + (:save-p :compute-only) + (:policy :fast-safe) + (:generator 5 + (aver (not (sc-is value immediate))) + (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) + hi + (fixnumize hi)))) + (inst cmp value (constantize fixnum-hi))))) + +(define-vop (test-fixnum-mod-*) + (:args (value :scs (any-reg descriptor-reg))) + (:arg-types * (:constant fixnum)) + (:translate fixnum-mod-p) + (:conditional) + (:info target not-p hi) + (:save-p :compute-only) + (:policy :fast-safe) + (:generator 6 + (let* ((fixnum-hi (fixnumize hi)) + (skip (gen-label))) + (generate-fixnum-test value) + (inst jmp :ne (if not-p target skip)) + (inst cmp value (constantize fixnum-hi)) + (inst jmp (if not-p :a :be) target) + (emit-label skip)))) ;;;; list/symbol types ;;; @@ -358,7 +458,7 @@ (define-vop (check-symbol check-type) (:generator 12 - (let ((error (generate-error-code vop object-not-symbol-error value))) + (let ((error (generate-error-code vop 'object-not-symbol-error value))) (inst cmp value nil-value) (inst jmp :e DROP-THRU) (test-type value error t (symbol-header-widetag))) @@ -376,8 +476,71 @@ (define-vop (check-cons check-type) (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) + (let ((error (generate-error-code vop 'object-not-cons-error value))) (inst cmp value nil-value) (inst jmp :e error) (test-type value error t (list-pointer-lowtag)) (move result value)))) + +#!+sb-simd-pack +(progn + (!define-type-vops simd-pack-p nil nil nil (simd-pack-widetag)) + + (define-vop (check-simd-pack check-type) + (:args (value :target result + :scs (any-reg descriptor-reg + int-sse-reg single-sse-reg double-sse-reg + int-sse-stack single-sse-stack double-sse-stack))) + (:results (result :scs (any-reg descriptor-reg + int-sse-reg single-sse-reg double-sse-reg))) + (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax) + (:ignore eax) + (:vop-var vop) + (:node-var node) + (:save-p :compute-only) + (:generator 50 + (sc-case value + ((int-sse-reg single-sse-reg double-sse-reg + int-sse-stack single-sse-stack double-sse-stack) + (sc-case result + ((int-sse-reg single-sse-reg double-sse-reg) + (move result value)) + ((any-reg descriptor-reg) + (with-fixed-allocation (result + simd-pack-widetag + simd-pack-size + node) + ;; see *simd-pack-element-types* + (storew (fixnumize + (sc-case value + ((int-sse-reg int-sse-stack) 0) + ((single-sse-reg single-sse-stack) 1) + ((double-sse-reg double-sse-stack) 2))) + result simd-pack-tag-slot other-pointer-lowtag) + (let ((ea (make-ea-for-object-slot + result simd-pack-lo-value-slot other-pointer-lowtag))) + (if (float-simd-pack-p value) + (inst movaps ea value) + (inst movdqa ea value))))))) + ((any-reg descriptor-reg) + (let ((leaf (sb!c::tn-leaf value))) + (unless (and (sb!c::lvar-p leaf) + (csubtypep (sb!c::lvar-type leaf) + (specifier-type 'simd-pack))) + (test-type + value + (generate-error-code vop 'object-not-simd-pack-error value) + t (simd-pack-widetag)))) + (sc-case result + ((int-sse-reg) + (let ((ea (make-ea-for-object-slot + value simd-pack-lo-value-slot other-pointer-lowtag))) + (inst movdqa result ea))) + ((single-sse-reg double-sse-reg) + (let ((ea (make-ea-for-object-slot + value simd-pack-lo-value-slot other-pointer-lowtag))) + (inst movaps result ea))) + ((any-reg descriptor-reg) + (move result value))))))) + + (primitive-type-vop check-simd-pack (:check) simd-pack-int simd-pack-single simd-pack-double))