("src/compiler/target/move")
("src/compiler/target/float")
+ #!+sb-simd-pack
+ ("src/compiler/target/simd-pack")
("src/compiler/target/sap")
("src/compiler/target/system")
("src/compiler/target/char")
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR"
#!+long-float
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR"
+ #!+sb-simd-pack
+ "OBJECT-NOT-SIMD-PACK-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-ERROR"
"SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND"
"SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
"SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "SPECIFIER-TYPE"
+ #!+sb-simd-pack "SIMD-PACK-SINGLE"
+ #!+sb-simd-pack "SIMD-PACK-DOUBLE"
+ #!+sb-simd-pack "SIMD-PACK-INT"
#!+sb-simd-pack "SIMD-PACK"
#!+sb-simd-pack "SIMD-PACK-P"
#!+sb-simd-pack "SIMD-PACK-TYPE"
#!+long-float "COMPLEX-LONG-FLOAT-WIDETAG"
#!+long-float "COMPLEX-LONG-REG-SC-NUMBER"
#!+long-float "COMPLEX-LONG-STACK-SC-NUMBER"
+ #!+sb-simd-pack "SIMD-PACK-TAG-SLOT"
+ #!+sb-simd-pack "SIMD-PACK-HI-VALUE-SLOT"
+ #!+sb-simd-pack "SIMD-PACK-LO-VALUE-SLOT"
+ #!+sb-simd-pack "SIMD-PACK-SIZE"
+ #!+sb-simd-pack "SIMD-PACK-WIDETAG"
#!-x86-64 #!-x86-64
"COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT"
#!+x86-64
:prototype-form (complex 42l0 42l0))
#!+sb-simd-pack
(simd-pack
- :translation simd-pack)
+ :translation simd-pack
+ :codes (#.sb!vm:simd-pack-widetag)
+ :prototype-form (%make-simd-pack-ub64 42 42))
(real :translation real :inherits (number))
(float
:translation float
:datum object
:expected-type '(complex long-float)))
+#!+sb-simd-pack
+(deferr object-not-simd-pack-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type 'simd-pack))
+
(deferr object-not-weak-pointer-error (object)
(error 'type-error
:datum object
(def-type-predicate-wrapper realp)
(def-type-predicate-wrapper short-float-p)
(def-type-predicate-wrapper single-float-p)
+ #!+sb-simd-pack (def-type-predicate-wrapper simd-pack-p)
(def-type-predicate-wrapper %instancep)
(def-type-predicate-wrapper symbolp)
(def-type-predicate-wrapper %other-pointer-p)
array-type
character-set-type
built-in-classoid
- cons-type)
+ cons-type
+ #!+sb-simd-pack simd-pack-type)
(values (%typep obj type) t))
(classoid
(if (if (csubtypep type (specifier-type 'function))
(numeric-type-p ctype)
(array-type-p ctype)
(cons-type-p ctype)
+ #!+sb-simd-pack
+ (simd-pack-type-p ctype)
(intersection-type-p ctype)
(union-type-p ctype)
(negation-type-p ctype)
(and (consp object)
(%%typep (car object) (cons-type-car-type type) strict)
(%%typep (cdr object) (cons-type-cdr-type type) strict)))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (and (simd-pack-p object)
+ (let* ((tag (%simd-pack-tag object))
+ (name (nth tag *simd-pack-element-types*)))
+ (not (not (member name (simd-pack-type-element-type type)))))))
(character-set-type
(and (characterp object)
(let ((code (char-code object))
fdefn-widetag ; 01010110
no-tls-value-marker-widetag ; 01011010
- unused01-widetag ; 01011110
+ #!-sb-simd-pack
+ unused01-widetag
+ #!+sb-simd-pack
+ simd-pack-widetag ; 01011110
unused02-widetag ; 01100010
unused03-widetag ; 01100110
unused04-widetag ; 01101010
#!+long-float
(object-not-complex-long-float
"Object is not of type (COMPLEX LONG-FLOAT).")
+ #!+sb-simd-pack
+ (object-not-simd-pack
+ "Object is not of type SIMD-PACK.")
(object-not-weak-pointer
"Object is not a WEAK-POINTER.")
(object-not-instance
(real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
(imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
+#!+sb-simd-pack
+(define-primitive-object (simd-pack
+ :lowtag other-pointer-lowtag
+ :widetag simd-pack-widetag)
+ (tag :ref-trans %simd-pack-tag
+ :attributes (movable flushable)
+ :type fixnum)
+ (lo-value :c-type "long" :type (unsigned-byte 64))
+ (hi-value :c-type "long" :type (unsigned-byte 64)))
+
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that
;;; it makes sense to define it here anyway, so that the GENESIS machinery
(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
(!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
:type (complex double-float))
-
+#!+sb-simd-pack
+(progn
+ (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
+ (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
+ :type (simd-pack single-float))
+ (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
+ :type (simd-pack double-float))
+ (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
+ :type (simd-pack integer))
+ (!def-primitive-type-alias simd-pack (:or simd-pack-single simd-pack-double simd-pack-int)))
;;; primitive other-pointer array types
(/show0 "primtype.lisp 96")
(= (cdar pairs) (1- sb!xc:char-code-limit)))
(exactly character)
(part-of character))))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (let ((eltypes (simd-pack-type-element-type type)))
+ (cond ((member 'integer eltypes)
+ (exactly simd-pack-int))
+ ((member 'single-float eltypes)
+ (exactly simd-pack-single))
+ ((member 'double-float eltypes)
+ (exactly simd-pack-double)))))
(built-in-classoid
(case (classoid-name type)
+ #!+sb-simd-pack
+ ;; Can't tell what specific type; assume integers.
+ (simd-pack
+ (exactly simd-pack-int))
((complex function system-area-pointer weak-pointer)
(values (primitive-type-or-lose (classoid-name type)) t))
(cons-type
(in-package "SB!C")
;;; the maximum number of SCs in any implementation
-(def!constant sc-number-limit 40)
+(def!constant sc-number-limit 62)
\f
;;; Modular functions
(define-type-predicate unsigned-byte-64-p (unsigned-byte 64))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(define-type-predicate signed-byte-64-p (signed-byte 64))
+#!+sb-simd-pack
+(define-type-predicate simd-pack-p simd-pack)
(define-type-predicate vector-nil-p (vector nil))
(define-type-predicate weak-pointer-p weak-pointer)
(define-type-predicate code-component-p code-component)
collect
`(<= ,(car pair) ,n-code ,(cdr pair)))))))))))
+#!+sb-simd-pack
+(defun source-transform-simd-pack-typep (object type)
+ (if (type= type (specifier-type 'simd-pack))
+ `(simd-pack-p ,object)
+ (once-only ((n-obj object))
+ (let ((n-tag (gensym "TAG")))
+ `(and
+ (simd-pack-p ,n-obj)
+ (let ((,n-tag (%simd-pack-tag ,n-obj)))
+ (or ,@(loop
+ for type in (simd-pack-type-element-type type)
+ for index = (position type *simd-pack-element-types*)
+ collect `(eql ,n-tag ,index)))))))))
+
;;; Return the predicate and type from the most specific entry in
;;; *TYPE-PREDICATES* that is a supertype of TYPE.
(defun find-supertype-predicate (type)
(source-transform-cons-typep object ctype))
(character-set-type
(source-transform-character-set-typep object ctype))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (source-transform-simd-pack-typep object ctype))
(t nil))
`(%typep ,object ',type))))
;; FIXME: might as well be COND instead of having to use #. readmacro
;; to hack up the code
(case (sc-name (tn-sc thing))
+ #!+sb-simd-pack
+ (#.*oword-sc-names*
+ :oword)
(#.*qword-sc-names*
:qword)
(#.*dword-sc-names*
((complex single-float)
(setf constant (list :complex-single-float first)))
((complex double-float)
- (setf constant (list :complex-double-float first)))))
+ (setf constant (list :complex-double-float first)))
+ #!+sb-simd-pack
+ (#+sb-xc-host nil
+ #-sb-xc-host simd-pack
+ (setf constant (list :sse (logior (%simd-pack-low first)
+ (ash (%simd-pack-high first)
+ 64)))))))
(destructuring-bind (type value) constant
(ecase type
((:byte :word :dword :qword)
((double-reg complex-double-reg)
(aver (xmm-register-p src))
(inst movapd dst src))
+ #!+sb-simd-pack
+ ((int-sse-reg sse-reg)
+ (aver (xmm-register-p src))
+ (inst movdqa dst src))
+ #!+sb-simd-pack
+ ((single-sse-reg double-sse-reg)
+ (aver (xmm-register-p src))
+ (inst movaps dst src))
(t
(inst mov dst src)))))
--- /dev/null
+;;;; SSE intrinsics support for x86-64
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+(defun ea-for-sse-stack (tn &optional (base rbp-tn))
+ (make-ea :qword :base base
+ :disp (frame-byte-offset (1+ (tn-offset tn)))))
+
+(defun float-sse-p (tn)
+ (sc-is tn single-sse-reg single-sse-stack single-sse-immediate
+ double-sse-reg double-sse-stack double-sse-immediate))
+(defun int-sse-p (tn)
+ (sc-is tn int-sse-reg int-sse-stack int-sse-immediate))
+\f
+(define-move-fun (load-int-sse-immediate 1) (vop x y)
+ ((int-sse-immediate) (int-sse-reg))
+ (let* ((x (tn-value x))
+ (lo (%simd-pack-low x))
+ (hi (%simd-pack-high x)))
+ (cond ((= lo hi 0)
+ (inst pxor y y))
+ ((= lo hi (ldb (byte 64 0) -1))
+ ;; don't think this is recognized as dependency breaking...
+ (inst pcmpeqd y y))
+ (t
+ (inst movdqa y (register-inline-constant x))))))
+
+(define-move-fun (load-float-sse-immediate 1) (vop x y)
+ ((single-sse-immediate double-sse-immediate)
+ (single-sse-reg double-sse-reg))
+ (let* ((x (tn-value x))
+ (lo (%simd-pack-low x))
+ (hi (%simd-pack-high x)))
+ (cond ((= lo hi 0)
+ (inst xorps y y))
+ ((= lo hi (ldb (byte 64 0) -1))
+ (inst pcmpeqd y y))
+ (t
+ (inst movaps y (register-inline-constant x))))))
+
+(define-move-fun (load-int-sse 2) (vop x y)
+ ((int-sse-stack) (int-sse-reg))
+ (inst movdqu y (ea-for-sse-stack x)))
+
+(define-move-fun (load-float-sse 2) (vop x y)
+ ((single-sse-stack double-sse-stack) (single-sse-reg double-sse-reg))
+ (inst movups y (ea-for-sse-stack x)))
+
+(define-move-fun (store-int-sse 2) (vop x y)
+ ((int-sse-reg) (int-sse-stack))
+ (inst movdqu (ea-for-sse-stack y) x))
+
+(define-move-fun (store-float-sse 2) (vop x y)
+ ((double-sse-reg single-sse-reg) (double-sse-stack single-sse-stack))
+ (inst movups (ea-for-sse-stack y) x))
+
+(define-vop (sse-move)
+ (:args (x :scs (single-sse-reg double-sse-reg int-sse-reg)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (single-sse-reg double-sse-reg int-sse-reg)
+ :load-if (not (location= x y))))
+ (:note "SSE move")
+ (:generator 0
+ (move y x)))
+(define-move-vop sse-move :move
+ (int-sse-reg single-sse-reg double-sse-reg)
+ (int-sse-reg single-sse-reg double-sse-reg))
+
+(define-vop (move-from-sse)
+ (:args (x :scs (single-sse-reg double-sse-reg int-sse-reg)))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "SSE to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ simd-pack-widetag
+ simd-pack-size
+ node)
+ ;; see *simd-pack-element-types*
+ (storew (fixnumize
+ (sc-case x
+ (single-sse-reg 1)
+ (double-sse-reg 2)
+ (int-sse-reg 0)
+ (t 0)))
+ y simd-pack-tag-slot other-pointer-lowtag)
+ (let ((ea (make-ea-for-object-slot
+ y simd-pack-lo-value-slot other-pointer-lowtag)))
+ (if (float-sse-p x)
+ (inst movaps ea x)
+ (inst movdqa ea x))))))
+(define-move-vop move-from-sse :move
+ (int-sse-reg single-sse-reg double-sse-reg) (descriptor-reg))
+
+(define-vop (move-to-sse)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (int-sse-reg double-sse-reg single-sse-reg)))
+ (:note "pointer to SSE coercion")
+ (:generator 2
+ (let ((ea (make-ea-for-object-slot
+ x simd-pack-lo-value-slot other-pointer-lowtag)))
+ (if (float-sse-p y)
+ (inst movaps y ea)
+ (inst movdqa y ea)))))
+(define-move-vop move-to-sse :move
+ (descriptor-reg)
+ (int-sse-reg double-sse-reg single-sse-reg))
+
+(define-vop (move-sse-arg)
+ (:args (x :scs (int-sse-reg double-sse-reg single-sse-reg) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y int-sse-reg double-sse-reg single-sse-reg))))
+ (:results (y))
+ (:note "SSE argument move")
+ (:generator 4
+ (sc-case y
+ ((int-sse-reg double-sse-reg single-sse-reg)
+ (unless (location= x y)
+ (if (or (float-sse-p x)
+ (float-sse-p y))
+ (inst movaps y x)
+ (inst movdqa y x))))
+ ((int-sse-stack double-sse-stack single-sse-stack)
+ (if (float-sse-p x)
+ (inst movups (ea-for-sse-stack y fp) x)
+ (inst movdqu (ea-for-sse-stack y fp) x))))))
+(define-move-vop move-sse-arg :move-arg
+ (int-sse-reg double-sse-reg single-sse-reg descriptor-reg)
+ (int-sse-reg double-sse-reg single-sse-reg))
+
+(define-move-vop move-arg :move-arg
+ (int-sse-reg double-sse-reg single-sse-reg)
+ (descriptor-reg))
+
+\f
+(define-vop (%simd-pack-low)
+ (:translate %simd-pack-low)
+ (:args (x :scs (int-sse-reg double-sse-reg single-sse-reg)))
+ (:arg-types simd-pack)
+ (:results (dst :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 3
+ (inst movd dst x)))
+
+(defun %simd-pack-low (x)
+ (declare (type simd-pack x))
+ (%simd-pack-low x))
+
+(define-vop (%simd-pack-high)
+ (:translate %simd-pack-high)
+ (:args (x :scs (int-sse-reg double-sse-reg single-sse-reg)))
+ (:arg-types simd-pack)
+ (:temporary (:sc sse-reg) tmp)
+ (:results (dst :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 3
+ (inst movdqa tmp x)
+ (inst psrldq tmp 8)
+ (inst movd dst tmp)))
+
+(defun %simd-pack-high (x)
+ (declare (type simd-pack x))
+ (%simd-pack-high x))
+
+(define-vop (%make-simd-pack)
+ (:translate %make-simd-pack)
+ (:policy :fast-safe)
+ (:args (tag :scs (any-reg))
+ (lo :scs (unsigned-reg))
+ (hi :scs (unsigned-reg)))
+ (:arg-types tagged-num unsigned-num unsigned-num)
+ (:results (dst :scs (descriptor-reg) :from :load))
+ (:result-types t)
+ (:node-var node)
+ (:generator 13
+ (with-fixed-allocation (dst
+ simd-pack-widetag
+ simd-pack-size
+ node)
+ ;; see *simd-pack-element-types*
+ (storew tag
+ dst simd-pack-tag-slot other-pointer-lowtag)
+ (storew lo
+ dst simd-pack-lo-value-slot other-pointer-lowtag)
+ (storew hi
+ dst simd-pack-hi-value-slot other-pointer-lowtag))))
+
+(defun %make-simd-pack (tag low high)
+ (declare (type fixnum tag)
+ (type (unsigned-byte 64) low high))
+ (%make-simd-pack tag low high))
+
+(define-vop (%make-simd-pack-ub64)
+ (:translate %make-simd-pack-ub64)
+ (:policy :fast-safe)
+ (:args (lo :scs (unsigned-reg))
+ (hi :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:temporary (:sc sse-reg) tmp)
+ (:results (dst :scs (int-sse-reg)))
+ (:result-types simd-pack-int)
+ (:generator 5
+ (inst movd dst lo)
+ (inst movd tmp hi)
+ (inst punpcklqdq dst tmp)))
+
+(defun %make-simd-pack-ub64 (low high)
+ (declare (type (unsigned-byte 64) low high))
+ (%make-simd-pack-ub64 low high))
+
+#-sb-xc-host
+(declaim (inline %make-simd-pack-ub64))
+#-sb-xc-host
+(defun %make-simd-pack-ub32 (w x y z)
+ (declare (type (unsigned-byte 32) w x y z))
+ (%make-simd-pack-ub64 (logior w (ash x 32))
+ (logior y (ash z 32))))
+
+#-sb-xc-host
+(progn
+ (declaim (inline %simd-pack-ub32s %simd-pack-ub64s))
+ (defun %simd-pack-ub32s (pack)
+ (declare (type simd-pack pack))
+ (let ((lo (%simd-pack-low pack))
+ (hi (%simd-pack-high pack)))
+ (values (ldb (byte 32 0) lo)
+ (ash lo -32)
+ (ldb (byte 32 0) hi)
+ (ash hi -32))))
+
+ (defun %simd-pack-ub64s (pack)
+ (declare (type simd-pack pack))
+ (values (%simd-pack-low pack)
+ (%simd-pack-high pack))))
+
+
+(define-vop (%make-simd-pack-double)
+ (:translate %make-simd-pack-double)
+ (:policy :fast-safe)
+ (:args (lo :scs (double-reg))
+ (hi :scs (double-reg)))
+ (:arg-types double-float double-float)
+ (:temporary (:sc double-sse-reg) tmp)
+ (:results (dst :scs (double-sse-reg)))
+ (:result-types simd-pack-double)
+ (:generator 5
+ (move dst lo)
+ (move tmp hi)
+ (inst unpcklpd dst tmp)))
+
+(defun %make-simd-pack-double (low high)
+ (declare (type double-float low high))
+ (%make-simd-pack-double low high))
+
+(define-vop (%make-simd-pack-single)
+ (:translate %make-simd-pack-single)
+ (:policy :fast-safe)
+ (:args (x :scs (single-reg))
+ (y :scs (single-reg))
+ (z :scs (single-reg))
+ (w :scs (single-reg)))
+ (:arg-types single-float single-float single-float single-float)
+ (:temporary (:sc sse-reg) tmp)
+ (:results (dst :scs (single-sse-reg)))
+ (:result-types simd-pack-single)
+ (:generator 5
+ (move dst x)
+ (inst unpcklps dst z)
+ (move tmp y)
+ (inst unpcklps tmp w)
+ (inst unpcklps dst tmp)))
+
+(defun %make-simd-pack-single (x y z w)
+ (declare (type single-float x y z w))
+ (%make-simd-pack-single x y z w))
+
+(defun %simd-pack-tag (pack)
+ (%simd-pack-tag pack))
+
+(define-vop (%simd-pack-single-item)
+ (:args (x :scs (int-sse-reg double-sse-reg single-sse-reg)))
+ (:arg-types simd-pack)
+ (:info index)
+ (:results (dst :scs (single-reg)))
+ (:result-types single-float)
+ (:temporary (:sc sse-reg) tmp)
+ (:policy :fast-safe)
+ (:generator 3
+ (inst movdqa tmp x)
+ (inst psrldq tmp (* 4 index))
+ (inst xorps dst dst)
+ (inst movss dst tmp)))
+
+#-sb-xc-host
+(declaim (inline %simd-pack-singles))
+#-sb-xc-host
+(defun %simd-pack-singles (pack)
+ (declare (type simd-pack pack))
+ (values (%primitive %simd-pack-single-item pack 0)
+ (%primitive %simd-pack-single-item pack 1)
+ (%primitive %simd-pack-single-item pack 2)
+ (%primitive %simd-pack-single-item pack 3)))
+
+(define-vop (%simd-pack-double-item)
+ (:args (x :scs (int-sse-reg double-sse-reg single-sse-reg)))
+ (:info index)
+ (:arg-types simd-pack)
+ (:results (dst :scs (double-reg)))
+ (:result-types double-float)
+ (:temporary (:sc sse-reg) tmp)
+ (:policy :fast-safe)
+ (:generator 3
+ (inst movdqa tmp x)
+ (inst psrldq tmp (* 8 index))
+ (inst xorpd dst dst)
+ (inst movsd dst tmp)))
+
+#-sb-xc-host
+(declaim (inline %simd-pack-doubles))
+#-sb-xc-host
+(defun %simd-pack-doubles (pack)
+ (declare (type simd-pack pack))
+ (values (%primitive %simd-pack-double-item pack 0)
+ (%primitive %simd-pack-double-item pack 1)))
(: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)
;; 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)))))))
\f
;;;; other integer ranges
(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))
+
+ #!+x86-64
+ (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))
(fp-complex-single-immediate immediate-constant)
(fp-complex-double-immediate immediate-constant)
+ #!+sb-simd-pack (int-sse-immediate immediate-constant)
+ #!+sb-simd-pack (double-sse-immediate immediate-constant)
+ #!+sb-simd-pack (single-sse-immediate immediate-constant)
+
(immediate immediate-constant)
;;
(double-stack stack)
(complex-single-stack stack) ; complex-single-floats
(complex-double-stack stack :element-size 2) ; complex-double-floats
-
+ #!+sb-simd-pack
+ (int-sse-stack stack :element-size 2)
+ #!+sb-simd-pack
+ (double-sse-stack stack :element-size 2)
+ #!+sb-simd-pack
+ (single-sse-stack stack :element-size 2)
;;
;; magic SCs
:save-p t
:alternate-scs (complex-double-stack))
+ ;; temporary only
+ #!+sb-simd-pack
+ (sse-reg float-registers
+ :locations #.*float-regs*)
+ ;; regular values
+ #!+sb-simd-pack
+ (int-sse-reg float-registers
+ :locations #.*float-regs*
+ :constant-scs (int-sse-immediate)
+ :save-p t
+ :alternate-scs (int-sse-stack))
+ #!+sb-simd-pack
+ (double-sse-reg float-registers
+ :locations #.*float-regs*
+ :constant-scs (double-sse-immediate)
+ :save-p t
+ :alternate-scs (double-sse-stack))
+ #!+sb-simd-pack
+ (single-sse-reg float-registers
+ :locations #.*float-regs*
+ :constant-scs (single-sse-immediate)
+ :save-p t
+ :alternate-scs (single-sse-stack))
+
;; a catch or unwind block
(catch-block stack :element-size kludge-nondeterministic-catch-block-size))
(defparameter *double-sc-names* '(double-reg double-stack))
(defparameter *complex-sc-names* '(complex-single-reg complex-single-stack
complex-double-reg complex-double-stack))
+#!+sb-simd-pack
+(defparameter *oword-sc-names* '(sse-reg int-sse-reg single-sse-reg double-sse-reg
+ sse-stack int-sse-stack single-sse-stack double-sse-stack))
) ; EVAL-WHEN
\f
;;;; miscellaneous TNs for the various registers
(sc-number-or-lose
(if (eql value #c(0d0 0d0))
'fp-complex-double-zero
- 'fp-complex-double-immediate)))))
+ 'fp-complex-double-immediate)))
+ #!+sb-simd-pack
+ (#+sb-xc-host nil
+ #-sb-xc-host (simd-pack double-float)
+ (sc-number-or-lose 'double-sse-immediate))
+ #!+sb-simd-pack
+ (#+sb-xc-host nil
+ #-sb-xc-host (simd-pack single-float)
+ (sc-number-or-lose 'single-sse-immediate))
+ #!+sb-simd-pack
+ (#+sb-xc-host nil
+ #-sb-xc-host simd-pack
+ (sc-number-or-lose 'int-sse-immediate))))
(!def-vm-support-routine boxed-immediate-sc-p (sc)
(eql sc (sc-number-or-lose 'immediate)))
#ifdef COMPLEX_LONG_FLOAT_WIDETAG
scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
#endif
+#ifdef SIMD_PACK_WIDETAG
+ scavtab[SIMD_PACK_WIDETAG] = scav_unboxed;
+#endif
scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
transother[CHARACTER_WIDETAG] = trans_immediate;
transother[SAP_WIDETAG] = trans_unboxed;
+#ifdef SIMD_PACK_WIDETAG
+ transother[SIMD_PACK_WIDETAG] = trans_unboxed;
+#endif
transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate;
transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
sizetab[CHARACTER_WIDETAG] = size_immediate;
sizetab[SAP_WIDETAG] = size_unboxed;
+#ifdef SIMD_PACK_WIDETAG
+ sizetab[SIMD_PACK_WIDETAG] = size_unboxed;
+#endif
sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate;
sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
#ifdef COMPLEX_LONG_FLOAT_WIDETAG
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
+#ifdef SIMD_PACK_WIDETAG
+ case SIMD_PACK_WIDETAG:
+#endif
case SIMPLE_ARRAY_WIDETAG:
case COMPLEX_BASE_STRING_WIDETAG:
#ifdef COMPLEX_CHARACTER_STRING_WIDETAG
#ifdef COMPLEX_LONG_FLOAT_WIDETAG
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
+#ifdef SIMD_PACK_WIDETAG
+ case SIMD_PACK_WIDETAG:
+#endif
case SIMPLE_BASE_STRING_WIDETAG:
#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
case SIMPLE_CHARACTER_STRING_WIDETAG:
projects / sbcl.git / commitdiff