Back end work for short vector SIMD packs
authorPaul Khuong <pvk@pvk.ca>
Tue, 21 May 2013 19:11:26 +0000 (15:11 -0400)
committerPaul Khuong <pvk@pvk.ca>
Tue, 21 May 2013 19:11:26 +0000 (15:11 -0400)
 * Platform-agnostic changes:
   - Declare type testing/checking routines.
   - Define three primitive types: simd-pack-double for packs
     of doubles, simd-pack-single for packs of singles, and
     simd-pack-int for packs of integer/unknown.
   - Define a heap-representation for 128-bit SIMD packs,
     along with reserving a widetag and filling the corresponding
     entries in gencgc's tables.
   - Make the simd-pack class definition fully concrete.
   - Teach IR1 how to expand SIMD-PACK type checks.
   - IR2-conversion maps SIMD-PACK types to the right primitive type.
   - Increase the limit on the number of storage classes: SIMD packs
     went way past the previous (arbitrary?) limit of 40.

 * Platform-specific changes, in src/compiler/target/simd-pack:
   - Create new storage classes (that are backed by the float-reg [i.e. SSE]
     storage base): one for each of double, single and integer sse packs.
   - Also create the corresponding immediate-constant and stack storage
     classes.
   - Teach the assembler and the inline constant code about this new kind
     of registers/constants, and how to map constant SIMD-PACKs to which SC.
   - Define movement/conversion VOPs for SSE packs, along with VOP routines
     needed for basic creation/manipulation of SSE packs.
   - The type-checking VOP in generic/late-type-vops is extremely
     x86-64-specific... IIRC, there are ordering issues I do not
     want to tangle with.

 * Implementation idiosyncrasy: while type *tests* (i.e. TYPEP calls) consider
   the element type, type *checks* (e.g. THE or DECLARE) only check for
   SIMD-PACKness, without looking at the element type.  This is allowed by the
   standard, is similar to what Python does for FUNCTION types, and helps
   code remain efficient even when type checks can't be fully elided.

The vast majority of the code is verbatim or heavily inspired by Alexander
Gavrilov's branch.

22 files changed:
build-order.lisp-expr
package-data-list.lisp-expr
src/code/class.lisp
src/code/interr.lisp
src/code/pred.lisp
src/code/target-type.lisp
src/code/typecheckfuns.lisp
src/code/typep.lisp
src/compiler/generic/early-objdef.lisp
src/compiler/generic/interr.lisp
src/compiler/generic/objdef.lisp
src/compiler/generic/primtype.lisp
src/compiler/generic/vm-macs.lisp
src/compiler/generic/vm-typetran.lisp
src/compiler/typetran.lisp
src/compiler/x86-64/insts.lisp
src/compiler/x86-64/macros.lisp
src/compiler/x86-64/simd-pack.lisp [new file with mode: 0644]
src/compiler/x86-64/type-vops.lisp
src/compiler/x86-64/vm.lisp
src/runtime/gc-common.c
src/runtime/gencgc.c

index f15a238..9a64d39 100644 (file)
 
  ("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")
index 4b3c99b..e6b9b96 100644 (file)
@@ -1644,6 +1644,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "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"
@@ -1748,6 +1750,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "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"
@@ -2667,6 +2672,11 @@ structure representations"
                #!+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
index f6224ec..6b868bd 100644 (file)
       :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
index b870da5..fb16a77 100644 (file)
          :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
index ae1dd7f..f303f81 100644 (file)
   (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)
index 5bff4bd..1310453 100644 (file)
@@ -35,7 +35,8 @@
          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))
index 8fe8217..3e0174f 100644 (file)
            (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)
index 531b1ab..374d3bc 100644 (file)
      (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))
index 5543acf..eb69275 100644 (file)
   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
index 539d632..9ff81d3 100644 (file)
   #!+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
index 262f472..c242a4d 100644 (file)
   (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
index 4fee64c..fa33e9c 100644 (file)
 (/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
index f77dc25..74a9e09 100644 (file)
 (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
 
index fbf1736..6c42ff0 100644 (file)
 (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)
index aeb9a7b..6f25b7d 100644 (file)
                             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))))
 
index 640fec0..533655b 100644 (file)
      ;; 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)
index e77d9c1..04d7ae5 100644 (file)
       ((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)))))
 
diff --git a/src/compiler/x86-64/simd-pack.lisp b/src/compiler/x86-64/simd-pack.lisp
new file mode 100644 (file)
index 0000000..717265c
--- /dev/null
@@ -0,0 +1,336 @@
+;;;; 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)))
index bc246c5..04fa745 100644 (file)
   (: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))
index 91298cc..ef34846 100644 (file)
   (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)))
index c0a7119..b601c9e 100644 (file)
@@ -1948,6 +1948,9 @@ gc_init_tables(void)
 #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
@@ -2186,6 +2189,9 @@ gc_init_tables(void)
     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;
@@ -2329,6 +2335,9 @@ gc_init_tables(void)
     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;
@@ -2501,6 +2510,9 @@ looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr)
 #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
index c082d38..0c87faf 100644 (file)
@@ -3085,6 +3085,9 @@ verify_space(lispobj *start, size_t words)
 #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: