tests/vm.before-xc.lisp

   1 ;;;; tests of the compiler vm internal consistency intended to be
   2 ;;;; executed as soon as the cross-compiler is built.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 (in-package "SB!VM")
  16
  17 (/show "beginning tests/vm.before-xc.lisp")
  18
  19 (flet ((yes (x)
  20          (assert
  21           (eql immediate-sc-number
  22                (immediate-constant-sc x))))
  23        (no (x)
  24          (assert
  25           (not (immediate-constant-sc x)))))
  26   ;; target fixnums can be dealt with as immediates; target bignums
  27   ;; can not.
  28   (yes #.sb!xc:most-positive-fixnum)
  29   (yes #.sb!xc:most-negative-fixnum)
  30   (no #.(1+ sb!xc:most-positive-fixnum))
  31   (no #.(1- sb!xc:most-negative-fixnum)))
  32
  33 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
  34 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
  35 ;; and x86-64-specific not because of broken-ness, but because it uses
  36 ;; known random TNs to play with.
  37 (in-package "SB!C")
  38 #!+x86-64
  39 (dotimes (i (ash 1 6))
  40   (labels ((make-tns (n)
  41              (mapcar 'copy-structure
  42                      (subseq `(,sb!vm::rax-tn ,sb!vm::rbx-tn ,sb!vm::rcx-tn) 0 n)))
  43            (link (list)
  44              (when list
  45                (setf (sb!c::tn-next (car list)) (link (cdr list)))
  46                (car list))))
  47     (let* ((normal     (make-tns (ldb (byte 2 0) i)))
  48            (restricted (make-tns (ldb (byte 2 2) i)))
  49            (wired      (make-tns (ldb (byte 2 4) i)))
  50            (expect     (append normal restricted wired))
  51            (comp       (sb!c::make-empty-component))
  52            (ir2-comp   (sb!c::make-ir2-component)))
  53       (setf (sb!c::component-info comp) ir2-comp
  54             (sb!c::ir2-component-normal-tns ir2-comp) (link normal)
  55             (sb!c::ir2-component-restricted-tns ir2-comp) (link restricted)
  56             (sb!c::ir2-component-wired-tns ir2-comp) (link wired))
  57       (let* ((list)
  58              (result (sb!c::do-packed-tns (tn comp 42) (push tn list))))
  59         (assert (eq result 42))
  60         (assert (equal expect (nreverse list))))
  61       (let* ((n 0) (list)
  62              (result (sb!c::do-packed-tns (tn comp 'bar)
  63                        (push tn list)
  64                        (if (= (incf n) 4) (return 'foo)))))
  65         (assert (eq result (if (>= (length expect) 4) 'foo 'bar)))
  66         (assert (equal (subseq expect 0 (min 4 (length expect)))
  67                        (nreverse list)))))))
  68
  69 (/show "done with tests/vm.before-xc.lisp")