Use defglobal more
[sbcl.git] / tests / system.impure.lisp
blobf4a26245689e23c796e0f0bcc40c8322169ec310
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.
12 (in-package "SB-VM")
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)
21 #-(and (or x86 x86-64) (not interpreter)) (sb-ext:exit :code 104)
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))))
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))
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))))))
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))))))
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))
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~%"))))