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 ((no (x)
  20          (assert
  21           (not (immediate-constant-sc x)))))
  22   (no #.(1+ most-positive-fixnum))
  23   (no #.(1- most-negative-fixnum)))
  24
  25 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
  26 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
  27 ;; and x86-64-specific not because of broken-ness, but because it uses
  28 ;; known random TNs to play with.
  29 (in-package "SB-C")
  30 #+x86-64
  31 (dotimes (i (ash 1 6))
  32   (labels ((make-tns (n)
  33              (mapcar 'copy-structure
  34                      (subseq `(,sb-vm::rax-tn ,sb-vm::rbx-tn ,sb-vm::rcx-tn) 0 n)))
  35            (link (list)
  36              (when list
  37                (setf (sb-c::tn-next (car list)) (link (cdr list)))
  38                (car list))))
  39     (let* ((normal     (make-tns (ldb (byte 2 0) i)))
  40            (restricted (make-tns (ldb (byte 2 2) i)))
  41            (wired      (make-tns (ldb (byte 2 4) i)))
  42            (expect     (append normal restricted wired))
  43            (comp       (sb-c::make-empty-component))
  44            (ir2-comp   (sb-c::make-ir2-component)))
  45       (setf (sb-c:component-info comp) ir2-comp
  46             (sb-c::ir2-component-normal-tns ir2-comp) (link normal)
  47             (sb-c::ir2-component-restricted-tns ir2-comp) (link restricted)
  48             (sb-c::ir2-component-wired-tns ir2-comp) (link wired))
  49       (let* ((list)
  50              (result (sb-c::do-packed-tns (tn comp 42) (push tn list))))
  51         (assert (eq result 42))
  52         (assert (equal expect (nreverse list))))
  53       (let* ((n 0) (list)
  54              (result (sb-c::do-packed-tns (tn comp 'bar)
  55                        (push tn list)
  56                        (if (= (incf n) 4) (return 'foo)))))
  57         (assert (eq result (if (>= (length expect) 4) 'foo 'bar)))
  58         (assert (equal (subseq expect 0 (min 4 (length expect)))
  59                        (nreverse list)))))))
  60
  61 (/show "done with tests/vm.before-xc.lisp")