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
  16   ;; The slots under test have to be naturally aligned for a double-Lispword,
  17   ;; at least on x86-64, so add a random slot if there is no layout slot.
  18   #+compact-instance-header fluff
  19   one two three four)
  20
  21 #-(and (or x86 x86-64) (not interpreter)) (sb-ext:exit :code 104)
  22
  23 (test-util:with-test (:name :basic-cpuid)
  24   (flet ((to-ascii (bits)
  25            (let ((s (make-array 4 :element-type 'base-char)))
  26              (setf (sap-ref-32 (vector-sap s) 0) bits)
  27              s)))
  28     (multiple-value-bind (a b c d)
  29         (%cpu-identification 0 0)
  30       ;; There's nothing to assert here since the result can vary
  31       (format t "~S (max function = ~D)~%"
  32               (concatenate 'string (to-ascii b) (to-ascii d) (to-ascii c))
  33               a))))
  34
  35 (progn
  36   (defun test-a-cons (acons oldcar oldcdr newcar newcdr)
  37     (declare (optimize (safety 0)))
  38     (%cons-cas-pair acons oldcar oldcdr newcar newcdr))
  39   (defun test-a-vect (avect ind old1 old2 new1 new2)
  40     (declare (optimize (safety 0)))
  41     (%vector-cas-pair avect ind old1 old2 new1 new2))
  42   (defun test-a-struct (inst ind old1 old2 new1 new2)
  43     (declare (optimize (safety 0)))
  44     (%instance-cas-pair inst ind old1 old2 new1 new2))
  45
  46   (defun test-wide-cmpxchg ()
  47     (let ((x (cons 'a 'b)))
  48       (multiple-value-bind (old1 old2) (test-a-cons x 'a 'b 'foo 'bar)
  49         (assert (and (eq old1 'a) (eq old2 'b) (equal x '(foo . bar)))))
  50       (multiple-value-bind (old1 old2) (test-a-cons x 0 0 1 2)
  51         (assert (and (eq old1 'foo) (eq old2 'bar) (equal x '(foo . bar))))))
  52
  53     ;; This is just testing that the offsets are correct.
  54     ;; Correct working of the instruction is tested by the CONS example.
  55     (let ((x (make-array 6 :initial-element nil)))
  56       (multiple-value-bind (old1 old2) (test-a-vect x 2 nil nil 'foo 'bar)
  57         (assert (and (null old1) (null old2) (equalp x #(nil nil foo bar nil nil))))))
  58
  59     ;; Same remark applies - just check that the offset to the slot is right.
  60     (let ((s (make-my-struct :three 'the :four 'floor)))
  61       ;; in slots 3 and 4 put your bootee (a baby shoe, i.e.) on the floor
  62       (multiple-value-bind (old1 old2) (test-a-struct s 3 'the 'floor 'your 'bootee)
  63         (assert (and (eq old1 'the) (eq old2 'floor)
  64                      (eq (my-struct-three s) 'your)
  65                      (eq (my-struct-four s) 'bootee)))))
  66     t))
  67
  68 (test-util:with-test (:name :wide-compare-and-exchange)
  69   (multiple-value-bind (a b c d) (%cpu-identification 0 0)
  70     (declare (ignore b c d))
  71     ;; paranoidly check for whether we can execute function ID 1
  72     (or (and (>= a 1) ; the highest function ID
  73              (multiple-value-bind (a b c d) (%cpu-identification 1 0)
  74                (declare (ignore a b) (ignorable c d))
  75                ;; paranoidly check for CMPXCHGxB presence
  76                ;; constants from Table 3-20 and 3-21 of Intel manual
  77                (and #+x86(logbitp 8 d) #+x86-64(logbitp 13 c)
  78                     (test-wide-cmpxchg))))
  79         (format t "Double-width compare-and-swap NOT TESTED~%"))))