tests/simd-pack.impure.lisp

   1 ;;;; Potentially side-effectful tests of the simd-pack infrastructure.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 #+sb-simd-pack
  15 (defun make-constant-packs ()
  16   (values (sb-kernel:%make-simd-pack-ub64 1 2)
  17           (sb-kernel:%make-simd-pack-ub32 0 0 0 0)
  18           (sb-kernel:%make-simd-pack-ub64 (ldb (byte 64 0) -1)
  19                                           (ldb (byte 64 0) -1))
  20
  21           (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)
  22           (sb-kernel:%make-simd-pack-single 0f0 0f0 0f0 0f0)
  23           (sb-kernel:%make-simd-pack-single (sb-kernel:make-single-float -1)
  24                                             (sb-kernel:make-single-float -1)
  25                                             (sb-kernel:make-single-float -1)
  26                                             (sb-kernel:make-single-float -1))
  27
  28           (sb-kernel:%make-simd-pack-double 1d0 2d0)
  29           (sb-kernel:%make-simd-pack-double 0d0 0d0)
  30           (sb-kernel:%make-simd-pack-double (sb-kernel:make-double-float
  31                                              -1 (ldb (byte 32 0) -1))
  32                                             (sb-kernel:make-double-float
  33                                              -1 (ldb (byte 32 0) -1)))))
  34
  35 #+sb-simd-pack
  36 (with-test (:name :compile-simd-pack)
  37   (multiple-value-bind (i i0 i-1
  38                         f f0 f-1
  39                         d d0 d-1)
  40       (make-constant-packs)
  41     (loop for (lo hi) in (list '(1 2) '(0 0)
  42                                (list (ldb (byte 64 0) -1)
  43                                      (ldb (byte 64 0) -1)))
  44           for pack in (list i i0 i-1)
  45           do (assert (eql lo (sb-kernel:%simd-pack-low pack)))
  46              (assert (eql hi (sb-kernel:%simd-pack-high pack))))
  47     (loop for expected in (list '(1f0 2f0 3f0 4f0)
  48                                 '(0f0 0f0 0f0 0f0)
  49                                 (make-list
  50                                  4 :initial-element (sb-kernel:make-single-float -1)))
  51           for pack in (list f f0 f-1)
  52           do (assert (every #'eql expected
  53                             (multiple-value-list (sb-kernel:%simd-pack-singles pack)))))
  54     (loop for expected in (list '(1d0 2d0)
  55                                 '(0d0 0d0)
  56                                 (make-list
  57                                  2 :initial-element (sb-kernel:make-double-float
  58                                                      -1 (ldb (byte 32 0) -1))))
  59           for pack in (list d d0 d-1)
  60           do (assert (every #'eql expected
  61                             (multiple-value-list (sb-kernel:%simd-pack-doubles pack)))))))
  62
  63 #+sb-simd-pack
  64 (with-test (:name (simd-pack print :smoke))
  65   (let ((packs (multiple-value-list (make-constant-packs))))
  66     (flet ((print-them (expect)
  67              (dolist (pack packs)
  68                (flet ((do-it ()
  69                         (with-output-to-string (stream)
  70                           (write pack :stream stream :pretty t :escape nil))))
  71                  (case expect
  72                    (print-not-readable
  73                     (assert-error (do-it) print-not-readable))
  74                    (t
  75                     (typecase pack
  76                       ((simd-pack single-float)
  77                        (if (and *print-readably*
  78                                 (some #'float-nan-p (multiple-value-list
  79                                                      (%simd-pack-singles pack))))
  80                            (assert-error (do-it) print-not-readable)
  81                            (do-it)))
  82                       ((simd-pack double-float)
  83                        (if (and *print-readably*
  84                                 (some #'float-nan-p (multiple-value-list
  85                                                      (%simd-pack-doubles pack))))
  86                            (assert-error (do-it) print-not-readable)
  87                            (do-it)))
  88                       (t
  89                        (do-it)))))))))
  90       ;; Default
  91       (print-them t)
  92       ;; Readably
  93       (let ((*print-readably* t)
  94             (*read-eval* t))
  95         (print-them t))
  96       ;; Want readably but can't without *READ-EVAL*.
  97       (let ((*print-readably* t)
  98             (*read-eval* nil))
  99         (print-them 'print-not-readable)))))