tests/system.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package "SB-VM")
  13
  14 ;;; This file defines a structure, so is an 'impure' test
  15 (defstruct my-struct one two three four)
  16
  17 #+(or x86 x86-64)
  18 (test-util:with-test (:name :basic-cpuid)
  19   (flet ((to-ascii (bits)
  20            (let ((s (make-array 4 :element-type 'base-char)))
  21              (setf (sap-ref-32 (vector-sap s) 0) bits)
  22              s)))
  23     (multiple-value-bind (a b c d)
  24         (%cpu-identification 0 0)
  25       ;; There's nothing to assert here since the result can vary
  26       (format t "~S (max function = ~D)~%"
  27               (concatenate 'string (to-ascii b) (to-ascii d) (to-ascii c))
  28               a))))
  29
  30 #+(or x86 x86-64)
  31 (progn
  32   (defun test-a-cons (acons oldcar oldcdr newcar newcdr)
  33     (declare (optimize (safety 0)))
  34     (%cons-cas-pair acons oldcar oldcdr newcar newcdr))
  35   (defun test-a-vect (avect ind old1 old2 new1 new2)
  36     (declare (optimize (safety 0)))
  37     (%vector-cas-pair avect ind old1 old2 new1 new2))
  38   (defun test-a-struct (inst ind old1 old2 new1 new2)
  39     (declare (optimize (safety 0)))
  40     (%instance-cas-pair inst ind old1 old2 new1 new2))
  41
  42   (defun test-wide-cmpxchg ()
  43     (let ((x (cons 'a 'b)))
  44       (multiple-value-bind (old1 old2) (test-a-cons x 'a 'b 'foo 'bar)
  45         (assert (and (eq old1 'a) (eq old2 'b) (equal x '(foo . bar)))))
  46       (multiple-value-bind (old1 old2) (test-a-cons x 0 0 1 2)
  47         (assert (and (eq old1 'foo) (eq old2 'bar) (equal x '(foo . bar))))))
  48
  49     ;; This is just testing that the offsets are correct.
  50     ;; Correct working of the instruction is tested by the CONS example.
  51     (let ((x (make-array 6 :initial-element nil)))
  52       (multiple-value-bind (old1 old2) (test-a-vect x 2 nil nil 'foo 'bar)
  53         (assert (and (null old1) (null old2) (equalp x #(nil nil foo bar nil nil))))))
  54
  55     ;; Same remark applies - just check that the offset to the slot is right.
  56     (let ((s (make-my-struct :three 'the :four 'floor)))
  57       ;; in slots 3 and 4 put your bootee (a baby shoe, i.e.) on the floor
  58       (multiple-value-bind (old1 old2) (test-a-struct s 3 'the 'floor 'your 'bootee)
  59         (assert (and (eq old1 'the) (eq old2 'floor)
  60                      (eq (my-struct-three s) 'your)
  61                      (eq (my-struct-four s) 'bootee)))))
  62     t))
  63
  64 #+(or x86 x86-64)
  65 (test-util:with-test (:name :wide-compare-and-exchange)
  66   (multiple-value-bind (a b c d) (%cpu-identification 0 0)
  67     (declare (ignore b c d))
  68     ;; paranoidly check for whether we can execute function ID 1
  69     (or (and (>= a 1) ; the highest function ID
  70              (multiple-value-bind (a b c d) (%cpu-identification 1 0)
  71                (declare (ignore a b) (ignorable c d))
  72                ;; paranoidly check for CMPXCHGxB presence
  73                ;; constants from Table 3-20 and 3-21 of Intel manual
  74                (and #+x86(logbitp 8 d) #+x86-64(logbitp 13 c)
  75                     (test-wide-cmpxchg))))
  76         (format t "Double-width compare-and-swap NOT TESTED~%"))))