tests/dump.impure-cload.lisp

   1 ;;;; tests related to the way objects are dumped into fasl files
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15
  16 (declaim (optimize (debug 3) (speed 2) (space 1)))
  17
  18 ;;; this would fail an AVER in NOTE-POTENTIAL-CIRCULARITY
  19 (defparameter *circular-2d-array* #1=#2A((a b) (#1# x)))
  20
  21 ;;; Don Geddis reported this test case 25 December 1999 on a CMU CL
  22 ;;; mailing list: dumping circular lists caused the compiler to enter
  23 ;;; an infinite loop. Douglas Crosher reported a patch 27 Dec 1999.
  24 ;;; The patch was tested on SBCL by Martin Atzmueller 2 Nov 2000, and
  25 ;;; merged in sbcl-0.6.8.11.
  26 (defun q-dg1999-1 () (dolist (x '#1=("A" "B" . #1#)) (progn x)))
  27 (defun q-dg1999-2 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
  28 (defun q-dg1999-3 () (dolist (x '#1=("E" "F" . #1#)) (progn x)))
  29 (defun q-dg1999-4 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
  30 (defun useful-dg1999 (keys)
  31   (declare (type list keys))
  32   (loop
  33       for c in '#1=("Red" "Blue" . #1#)
  34       for key in keys))
  35
  36 ;;; sbcl-0.6.11.25 or so had DEF!STRUCT/MAKE-LOAD-FORM/HOST screwed up
  37 ;;; so that the compiler couldn't dump pathnames.
  38 (format t "Now the compiler can dump pathnames again: ~S ~S~%" #p"" #p"/x/y/z")
  39
  40 (eval-when (:compile-toplevel :load-toplevel :execute)
  41   (defstruct foo x y)
  42   (defmethod make-load-form ((foo foo) &optional env)
  43     (declare (ignore env))
  44     ;; an extremely meaningless MAKE-LOAD-FORM method whose only point
  45     ;; is to exercise the mechanism a little bit
  46     (values `(make-foo :x (list ',(foo-x foo)))
  47             `(setf (foo-y ,foo) ',foo))))
  48
  49 (defparameter *foo*
  50   #.(make-foo :x "X" :y "Y"))
  51
  52 (assert (equalp (foo-x *foo*) '("X")))
  53 (assert (eql (foo-y *foo*) *foo*))
  54
  55 ;;; Logical pathnames should be dumpable, too, but what does it mean?
  56 ;;; As of sbcl-0.7.7.16, we've taken dumping the host part to mean
  57 ;;; dumping a reference to the name of the host (much as dumping a
  58 ;;; symbol involves dumping a reference to the name of its package).
  59 (eval-when (:compile-toplevel :load-toplevel :execute)
  60   (setf (logical-pathname-translations "MY-LOGICAL-HOST")
  61         (list '("**;*.*.*" "/tmp/*.*"))))
  62
  63 (defparameter *path* #p"MY-LOGICAL-HOST:FOO;BAR.LISP")
  64
  65 ;;; Non-SIMPLE-ARRAY VECTORs should be dumpable, though they can lose
  66 ;;; their complex attributes.
  67
  68 (defparameter *string* #.(make-array 3 :initial-element #\a
  69                                        :fill-pointer 2
  70                                        :element-type 'character))
  71
  72 ;;; SBCL 0.7.8 incorrectly read high bits of (COMPLEX DOUBLE-FLOAT)
  73 ;;; components as unsigned bytes.
  74 (defparameter *numbers*
  75   '(-1s0 -1f0 -1d0 -1l0
  76     #c(-1s0 -1s0) #c(-1f0 -1f0) #c(-1d0 -1d0) #c(-1l0 -1l0)))
  77 \f
  78 ;;; tests for MAKE-LOAD-FORM-SAVING-SLOTS
  79 (eval-when (:compile-toplevel :load-toplevel :execute)
  80   (defstruct savable-structure
  81     (a nil :type symbol)
  82     (b nil :type symbol :read-only t)
  83     (c nil :read-only t)
  84     (d 0 :type fixnum)
  85     (e 17 :type (unsigned-byte 32) :read-only t))
  86   (defmethod make-load-form ((s savable-structure) &optional env)
  87     (make-load-form-saving-slots s :environment env)))
  88 (defparameter *savable-structure*
  89   #.(make-savable-structure :a t :b 'frob :c 1 :d 39 :e 19))
  90 (assert (eql (savable-structure-a *savable-structure*) t))
  91 (assert (eql (savable-structure-b *savable-structure*) 'frob))
  92 (assert (eql (savable-structure-c *savable-structure*) 1))
  93 (assert (eql (savable-structure-d *savable-structure*) 39))
  94 (assert (eql (savable-structure-e *savable-structure*) 19))
  95
  96 ;;; null :SLOT-NAMES /= unsupplied
  97 (eval-when (:compile-toplevel :load-toplevel :execute)
  98   (defclass savable-class ()
  99     ((a :initform t :initarg :a)))
 100   (defmethod make-load-form ((s savable-class) &optional env)
 101     (make-load-form-saving-slots s :environment env :slot-names '())))
 102 (defparameter *savable-class*
 103   #.(make-instance 'savable-class :a 3))
 104 (assert (not (slot-boundp *savable-class* 'a)))
 105
 106 \f
 107 ;;; ensure that we can dump and reload specialized arrays whose element
 108 ;;; size is smaller than a byte (caused a few problems circa SBCL
 109 ;;; 0.8.14.4)
 110
 111 (defvar *1-bit* #.(make-array 5 :element-type 'bit :initial-element 0))
 112 (defvar *2-bit* #.(make-array 5 :element-type '(unsigned-byte 2) :initial-element 0))
 113 (defvar *4-bit* #.(make-array 5 :element-type '(unsigned-byte 4) :initial-element 1))
 114 \f
 115 ;;; tests for constant coalescing (and absence of such) in the
 116 ;;; presence of strings.
 117 (progn
 118   (defvar *character-string-1* #.(make-string 5 :initial-element #\a))
 119   (defvar *character-string-2* #.(make-string 5 :initial-element #\a))
 120   (assert (eq *character-string-1* *character-string-2*))
 121   (assert (typep *character-string-1* '(simple-array character (5)))))
 122
 123 (progn
 124   (defvar *base-string-1*
 125     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 126   (defvar *base-string-2*
 127     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 128   (assert (eq *base-string-1* *base-string-2*))
 129   (assert (typep *base-string-1* '(simple-base-string 5))))
 130
 131 #-#.(cl:if (cl:subtypep 'cl:character 'cl:base-char) '(and) '(or))
 132 (progn
 133   (defvar *base-string*
 134     #.(make-string 5 :element-type 'base-char :initial-element #\x))
 135   (defvar *character-string*
 136     #.(make-string 5 :initial-element #\x))
 137   (assert (not (eq *base-string* *character-string*)))
 138   (assert (typep *base-string* 'base-string))
 139   (assert (typep *character-string* '(vector character))))
 140
 141 ;; Preparation for more MAKE-LOAD-FORM tests
 142 (eval-when (:compile-toplevel :load-toplevel :execute)
 143
 144  (locally
 145   ;; this file's global SPEED proclamation generates a lot of unwanted noise
 146   (declare (optimize (speed 1)))
 147   (defstruct airport
 148     name code
 149     (latitude nil :type double-float)
 150     (longitude nil :type double-float))
 151
 152   (defmethod make-load-form ((self airport) &optional env)
 153     (make-load-form-saving-slots self :environment env))
 154
 155   (defun compute-airports (n)
 156     (let ((a (make-array n)))
 157       (dotimes (i n a)
 158         (setf (aref a i) (make-airport :code (format nil "~36,3,'0R" i)
 159                                        :name (format nil "airport~d" i)
 160                                        :latitude (+ 40 (/ i 1000.0d0))
 161                                        :longitude (+  100 (/ i 1000.0d0)))))))
 162   (defstruct s1
 163     (w 0 :type sb-ext:word)
 164     (sf 0f0 :type single-float)
 165     (df 0d0 :type double-float)
 166     (csf #c(0f0 0f0) :type (complex single-float))
 167     (cdf #c(0d0 0d0) :type (complex double-float))
 168     (kids nil)
 169     (friends nil))
 170
 171   (defstruct s2
 172     (id)
 173     (friends)
 174     (parent))
 175
 176   (defmethod make-load-form ((self s1) &optional env)
 177     (declare (ignore env))
 178     (ecase (s1-w self)
 179       (1
 180        ;; return gratuitously modified expressions
 181        (multiple-value-bind (alloc init)
 182            (make-load-form-saving-slots self)
 183          (values (list 'progn alloc) (list 'progn init))))
 184       (2
 185        ;; omit the (complex double-float) slot
 186        (make-load-form-saving-slots self
 187                                     ;; nonexistent names are ignored
 188                                     :slot-names '(w sf df csf bogus
 189                                                   kids friends)))
 190       (3
 191        (make-load-form-saving-slots self)))) ; normal
 192
 193   (defmethod make-load-form ((self s2) &optional env)
 194     (declare (ignore env))
 195     (make-load-form-saving-slots self))
 196
 197   (defun compute-tangled-stuff ()
 198     (flet ((circular-list (x)
 199              (let ((list (list x)))
 200                (rplacd list list))))
 201       (let* ((a (make-s1 :w 1
 202                          :sf 1.25f-9
 203                          :df 1048d50
 204                          :csf #c(8.45f1 -9.35f2)
 205                          :cdf #c(-5.430005d10 2.875d0)))
 206              (b (make-s1 :w 2
 207                          :sf 2f0
 208                          :df 3d0
 209                          :csf #c(4f0 5f0)
 210                          :cdf #c(6d0 7d0)))
 211              (c (make-s1 :w 3
 212                          :sf -2f0
 213                          :df -3d0
 214                          :csf #c(-4f0 -5f0)
 215                          :cdf #c(-6d0 -7d0)))
 216              (k1 (make-s2 :id 'b-kid1 :parent b))
 217              (k2 (make-s2 :id 'c-kid1 :parent c)))
 218         (setf (s2-friends k1) (list k2)
 219               (s2-friends k2) (list k1))
 220         (setf (s1-kids b) (list k1 (make-s2 :id 'b-kid2 :parent b))
 221               (s1-kids c) (list k2)
 222               (s1-friends a) (list* b c (circular-list a))
 223               (s1-friends b) (list a c)
 224               (s1-friends c) (list a b))
 225         (list a b c))))
 226
 227 )) ; end EVAL-WHEN
 228
 229 (with-test (:name :load-form-canonical-p)
 230   (let ((foo (make-foo :x 'x :y 'y)))
 231     (multiple-value-bind (create init)
 232         (make-load-form-saving-slots foo)
 233       (assert (sb-kernel::canonical-slot-saving-forms-p foo create init)))
 234     (multiple-value-bind (create init)
 235         ;; specifying all slots is still canonical
 236         (make-load-form-saving-slots foo :slot-names '(y x))
 237       (assert (sb-kernel::canonical-slot-saving-forms-p foo create init)))
 238     (multiple-value-bind (create init)
 239         (make-load-form-saving-slots foo :slot-names '(x))
 240       (assert (not (sb-kernel::canonical-slot-saving-forms-p
 241                     foo create init))))))
 242
 243 ;; A huge constant vector. This took 9 seconds to compile (on a MacBook Pro)
 244 ;; prior to the optimization for using :SB-JUST-DUMP-IT-NORMALLY.
 245 ;; This assertion is simply whether it comes out correctly, not the time taken.
 246 (defparameter *airport-vector* #.(compute-airports 4000))
 247
 248 ;; a tangled forest of structures,
 249 (defparameter *metadata* '#.(compute-tangled-stuff))
 250
 251 (test-util:with-test (:name :make-load-form-huge-vector)
 252   (assert (equalp (compute-airports (length (the vector *airport-vector*)))
 253                   *airport-vector*)))
 254
 255 (test-util:with-test (:name :make-load-form-circular-hair)
 256   (let ((testcase (compute-tangled-stuff)))
 257     (declare (optimize (speed 1)))
 258     ;; MAKE-LOAD-FORM discards the value of the CDF slot of one structure.
 259     ;; This probably isn't something "reasonable" to do, but it indicates
 260     ;; that :JUST-DUMP-IT-NORMALLY was correctly not used.
 261     (setf (s1-cdf (second testcase)) #c(0d0 0d0))
 262     (assert (string= (write-to-string testcase :circle t :pretty nil)
 263                      (write-to-string *metadata* :circle t :pretty nil)))))
 264
 265 (eval-when (:compile-toplevel :load-toplevel :execute)
 266   (defclass twp ()
 267     ((node-name :initarg :name :accessor node-name)
 268      (parent :accessor node-parent :initform nil)
 269      (children :initarg :children :accessor node-children)))
 270
 271   (defmethod print-object ((self twp) stream)
 272     (declare (optimize (speed 0))) ; silence noise
 273     (format stream "#<Node ~A~@[->~A~]>"
 274             (node-name self)
 275             (handler-case (mapcar 'node-name (node-children self))
 276               (unbound-slot () nil))))
 277
 278   (defmethod make-load-form ((x twp) &optional environment)
 279     (declare (ignore environment))
 280     (values
 281      ;; creation form
 282      `(make-instance ',(class-of x)
 283                      ,@(if (slot-boundp x 'children)
 284                            `(:children ',(slot-value x 'children))))
 285      ;; initialization form
 286      `(setf (node-parent ',x) ',(slot-value x 'parent))))
 287
 288   (defun make-tree-from-spec (node-class specs)
 289     (let ((tree (make-hash-table)))
 290       (dolist (node-name (remove-duplicates (apply #'append specs)))
 291         (setf (gethash node-name tree)
 292               (make-instance node-class :name node-name)))
 293       (dolist (node-spec specs)
 294         (let ((par (gethash (car node-spec) tree))
 295               (kids (mapcar (lambda (x) (gethash x tree)) (cdr node-spec))))
 296           (dolist (kid kids)
 297             (assert (not (node-parent kid)))
 298             (setf (slot-value kid 'parent) par))
 299           (setf (slot-value par 'children) kids)))
 300       (values (gethash 'root tree)))))
 301
 302 (defun verify-tree (node)
 303   (dolist (kid (if (slot-boundp node 'children) (node-children node) nil))
 304     (unless (eq (node-parent kid) node)
 305       (error "Node ~S shoud have ~S as parent but has ~S~%"
 306              (node-name kid)
 307              (node-name node)
 308              (node-parent kid)))
 309     (verify-tree kid)))
 310
 311 (defvar *x*
 312   #.(make-tree-from-spec
 313       'twp
 314       '((root a b c f)
 315         (a x y)
 316         (b p q r s)
 317         (c d e g))))
 318
 319 (with-test (:name :tree-with-parent-hand-made-load-form)
 320   (verify-tree *x*))
 321
 322 (eval-when (:compile-toplevel :load-toplevel :execute)
 323   (defclass twp2 (twp) ())
 324   (defmethod make-load-form ((x twp2) &optional environment)
 325     (declare (ignore environment))
 326     (make-load-form-saving-slots x))
 327   (defvar *call-tracker* nil)
 328   (defun call-tracker (f &rest args)
 329     (push f *call-tracker*)
 330     (apply (the function f) args))
 331   (defvar *track-funs*
 332      'sb-c::(fopcompile-allocate-instance
 333              fopcompile-constant-init-forms
 334              compile-make-load-form-init-forms))
 335   (dolist (f *track-funs*)
 336     (sb-int:encapsulate f 'track #'call-tracker)))
 337
 338 ;; Same as *X* but the MAKE-LOAD-FORM method is different
 339 (defvar *y*
 340   #.(make-tree-from-spec
 341       'twp2
 342       '((root a b c f)
 343         (a x y)
 344         (b p q r s)
 345         (c d e g))))
 346
 347 (eval-when (:compile-toplevel)
 348   (dolist (f *track-funs*)
 349     (sb-int:unencapsulate f 'track))
 350   (assert (= 14 (count #'sb-c::fopcompile-allocate-instance
 351                        *call-tracker*)))
 352   (assert (= 14 (count #'sb-c::fopcompile-constant-init-forms
 353                        *call-tracker*)))
 354   (assert (not (find #'sb-c::compile-make-load-form-init-forms
 355                      *call-tracker*))))
 356
 357 (with-test (:name :tree-with-parent-m-l-f-s-s)
 358   (verify-tree *y*))