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 (locally (declare (notinline eql)) ; noise suppression
  54                  (eql (foo-y *foo*) *foo*)))
  55
  56 ;;; Logical pathnames should be dumpable, too, but what does it mean?
  57 ;;; As of sbcl-0.7.7.16, we've taken dumping the host part to mean
  58 ;;; dumping a reference to the name of the host (much as dumping a
  59 ;;; symbol involves dumping a reference to the name of its package).
  60 (eval-when (:compile-toplevel :load-toplevel :execute)
  61   (setf (logical-pathname-translations "MY-LOGICAL-HOST")
  62         (list '("**;*.*.*" "/tmp/*.*"))))
  63
  64 (defparameter *path* #p"MY-LOGICAL-HOST:FOO;BAR.LISP")
  65
  66 ;;; Non-SIMPLE-ARRAY VECTORs should be dumpable, though they can lose
  67 ;;; their complex attributes.
  68
  69 (defparameter *string* #.(make-array 3 :initial-element #\a
  70                                        :fill-pointer 2
  71                                        :element-type 'character))
  72
  73 ;;; SBCL 0.7.8 incorrectly read high bits of (COMPLEX DOUBLE-FLOAT)
  74 ;;; components as unsigned bytes.
  75 (defparameter *numbers*
  76   '(-1s0 -1f0 -1d0 -1l0
  77     #c(-1s0 -1s0) #c(-1f0 -1f0) #c(-1d0 -1d0) #c(-1l0 -1l0)))
  78 \f
  79 ;;; tests for MAKE-LOAD-FORM-SAVING-SLOTS
  80 (eval-when (:compile-toplevel :load-toplevel :execute)
  81   (defstruct savable-structure
  82     (a nil :type symbol)
  83     (b nil :type symbol :read-only t)
  84     (c nil :read-only t)
  85     (d 0 :type fixnum)
  86     (e 17 :type (unsigned-byte 32) :read-only t))
  87   (defmethod make-load-form ((s savable-structure) &optional env)
  88     (make-load-form-saving-slots s :environment env)))
  89 (defparameter *savable-structure*
  90   #.(make-savable-structure :a t :b 'frob :c 1 :d 39 :e 19))
  91 (assert (eql (savable-structure-a *savable-structure*) t))
  92 (assert (eql (savable-structure-b *savable-structure*) 'frob))
  93 (assert (eql (savable-structure-c *savable-structure*) 1))
  94 (assert (eql (savable-structure-d *savable-structure*) 39))
  95 (assert (eql (savable-structure-e *savable-structure*) 19))
  96
  97 ;;; null :SLOT-NAMES /= unsupplied
  98 (eval-when (:compile-toplevel :load-toplevel :execute)
  99   (defclass savable-class ()
 100     ((a :initform t :initarg :a)))
 101   (defmethod make-load-form ((s savable-class) &optional env)
 102     (make-load-form-saving-slots s :environment env :slot-names '())))
 103 (defparameter *savable-class*
 104   #.(make-instance 'savable-class :a 3))
 105 (assert (not (slot-boundp *savable-class* 'a)))
 106
 107 \f
 108 ;;; ensure that we can dump and reload specialized arrays whose element
 109 ;;; size is smaller than a byte (caused a few problems circa SBCL
 110 ;;; 0.8.14.4)
 111
 112 (defvar *1-bit* #.(make-array 5 :element-type 'bit :initial-element 0))
 113 (defvar *2-bit* #.(make-array 5 :element-type '(unsigned-byte 2) :initial-element 0))
 114 (defvar *4-bit* #.(make-array 5 :element-type '(unsigned-byte 4) :initial-element 1))
 115 \f
 116 ;;; tests for constant coalescing (and absence of such) in the
 117 ;;; presence of strings.
 118 (progn
 119   (defvar *character-string-1* #.(make-string 5 :initial-element #\a))
 120   (defvar *character-string-2* #.(make-string 5 :initial-element #\a))
 121   (assert (eq *character-string-1* *character-string-2*))
 122   (assert (typep *character-string-1* '(simple-array character (5)))))
 123
 124 (progn
 125   (defvar *base-string-1*
 126     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 127   (defvar *base-string-2*
 128     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 129   (assert (eq *base-string-1* *base-string-2*))
 130   (assert (typep *base-string-1* '(simple-base-string 5))))
 131
 132 #-#.(cl:if (cl:subtypep 'cl:character 'cl:base-char) '(and) '(or))
 133 (progn
 134   (defvar *base-string*
 135     #.(make-string 5 :element-type 'base-char :initial-element #\x))
 136   (defvar *character-string*
 137     #.(make-string 5 :initial-element #\x))
 138   (assert (not (eq *base-string* *character-string*)))
 139   (assert (typep *base-string* 'base-string))
 140   (assert (typep *character-string* '(vector character))))
 141
 142 ;; Preparation for more MAKE-LOAD-FORM tests
 143 (eval-when (:compile-toplevel :load-toplevel :execute)
 144
 145  (locally
 146   ;; this file's global SPEED proclamation generates a lot of unwanted noise
 147   (declare (optimize (speed 1)))
 148   (defstruct airport
 149     name code
 150     (latitude nil :type double-float)
 151     (longitude nil :type double-float))
 152
 153   (defmethod make-load-form ((self airport) &optional env)
 154     (make-load-form-saving-slots self :environment env))
 155
 156   (defun compute-airports (n)
 157     (let ((a (make-array n)))
 158       (dotimes (i n a)
 159         (setf (aref a i) (make-airport :code (format nil "~36,3,'0R" i)
 160                                        :name (format nil "airport~d" i)
 161                                        :latitude (+ 40 (/ i 1000.0d0))
 162                                        :longitude (+  100 (/ i 1000.0d0)))))))
 163   (defstruct s1
 164     (w 0 :type sb-ext:word)
 165     (sf 0f0 :type single-float)
 166     (df 0d0 :type double-float)
 167     (csf #c(0f0 0f0) :type (complex single-float))
 168     (cdf #c(0d0 0d0) :type (complex double-float))
 169     (kids nil)
 170     (friends nil))
 171
 172   (defstruct s2
 173     (id)
 174     (friends)
 175     (parent))
 176
 177   (defmethod make-load-form ((self s1) &optional env)
 178     (declare (ignore env))
 179     (ecase (s1-w self)
 180       (1
 181        ;; return gratuitously modified expressions
 182        (multiple-value-bind (alloc init)
 183            (make-load-form-saving-slots self)
 184          (values (list 'progn alloc) (list 'progn init))))
 185       (2
 186        ;; omit the (complex double-float) slot
 187        (make-load-form-saving-slots self
 188                                     ;; nonexistent names are ignored
 189                                     :slot-names '(w sf df csf bogus
 190                                                   kids friends)))
 191       (3
 192        (make-load-form-saving-slots self)))) ; normal
 193
 194   (defmethod make-load-form ((self s2) &optional env)
 195     (declare (ignore env))
 196     (make-load-form-saving-slots self))
 197
 198   (defun compute-tangled-stuff ()
 199     (flet ((circular-list (x)
 200              (let ((list (list x)))
 201                (rplacd list list))))
 202       (let* ((a (make-s1 :w 1
 203                          :sf 1.25f-9
 204                          :df 1048d50
 205                          :csf #c(8.45f1 -9.35f2)
 206                          :cdf #c(-5.430005d10 2.875d0)))
 207              (b (make-s1 :w 2
 208                          :sf 2f0
 209                          :df 3d0
 210                          :csf #c(4f0 5f0)
 211                          :cdf #c(6d0 7d0)))
 212              (c (make-s1 :w 3
 213                          :sf -2f0
 214                          :df -3d0
 215                          :csf #c(-4f0 -5f0)
 216                          :cdf #c(-6d0 -7d0)))
 217              (k1 (make-s2 :id 'b-kid1 :parent b))
 218              (k2 (make-s2 :id 'c-kid1 :parent c)))
 219         (setf (s2-friends k1) (list k2)
 220               (s2-friends k2) (list k1))
 221         (setf (s1-kids b) (list k1 (make-s2 :id 'b-kid2 :parent b))
 222               (s1-kids c) (list k2)
 223               (s1-friends a) (list* b c (circular-list a))
 224               (s1-friends b) (list a c)
 225               (s1-friends c) (list a b))
 226         (list a b c))))
 227
 228 )) ; end EVAL-WHEN
 229
 230 ;; Redefine the MAKE-LOAD-FORM method on FOO.
 231 (remove-method #'make-load-form (find-method #'make-load-form nil (list 'foo)))
 232 (defvar *foo-save-slots* nil)
 233 (defmethod make-load-form ((self foo) &optional env)
 234   (declare (ignore env))
 235   (if (eq *foo-save-slots* :all)
 236       (make-load-form-saving-slots self)
 237       (make-load-form-saving-slots self :slot-names *foo-save-slots*)))
 238 (with-test (:name :load-form-canonical-p)
 239   (let ((foo (make-foo :x 'x :y 'y)))
 240     (assert (eq (let ((*foo-save-slots* :all)) (sb-c::%make-load-form foo))
 241                 'sb-fasl::fop-struct))
 242     ;; specifying all slots is still canonical
 243     (assert (eq (let ((*foo-save-slots* '(y x))) (sb-c::%make-load-form foo))
 244                 'sb-fasl::fop-struct))
 245     ;; specifying only one slot is not canonical
 246     (assert (equal (let ((*foo-save-slots* '(x))) (sb-c::%make-load-form foo))
 247                    '(sb-kernel::new-instance foo)))))
 248
 249 ;; A huge constant vector. This took 9 seconds to compile (on a MacBook Pro)
 250 ;; prior to the optimization for using fops to dump.
 251 ;; This assertion is simply whether it comes out correctly, not the time taken.
 252 (defparameter *airport-vector* #.(compute-airports 4000))
 253
 254 ;; a tangled forest of structures,
 255 (defparameter *metadata* '#.(compute-tangled-stuff))
 256
 257 (test-util:with-test (:name :make-load-form-huge-vector)
 258   (assert (equalp (compute-airports (length (the vector *airport-vector*)))
 259                   *airport-vector*)))
 260
 261 (test-util:with-test (:name :make-load-form-circular-hair)
 262   (let ((testcase (compute-tangled-stuff)))
 263     (declare (optimize (speed 1)))
 264     ;; MAKE-LOAD-FORM discards the value of the CDF slot of one structure.
 265     ;; This probably isn't something "reasonable" to do, but it indicates
 266     ;; that SB-FASL::FOP-STRUCT was correctly not used.
 267     (setf (s1-cdf (second testcase)) #c(0d0 0d0))
 268     (assert (string= (write-to-string testcase :circle t :pretty nil)
 269                      (write-to-string *metadata* :circle t :pretty nil)))))
 270
 271 (eval-when (:compile-toplevel :load-toplevel :execute)
 272   (defclass twp ()
 273     ((node-name :initarg :name :accessor node-name)
 274      (parent :accessor node-parent :initform nil)
 275      (children :initarg :children :accessor node-children)))
 276
 277   (defmethod print-object ((self twp) stream)
 278     (declare (optimize (speed 0))) ; silence noise
 279     (format stream "#<Node ~A~@[->~A~]>"
 280             (node-name self)
 281             (handler-case (mapcar 'node-name (node-children self))
 282               (unbound-slot () nil))))
 283
 284   (defmethod make-load-form ((x twp) &optional environment)
 285     (declare (ignore environment))
 286     (values
 287      ;; creation form
 288      `(make-instance ',(class-of x)
 289                      ,@(if (slot-boundp x 'children)
 290                            `(:children ',(slot-value x 'children))))
 291      ;; initialization form
 292      `(setf (node-parent ',x) ',(slot-value x 'parent))))
 293
 294   (defun make-tree-from-spec (node-class specs)
 295     (let ((tree (make-hash-table)))
 296       (dolist (node-name (remove-duplicates (apply #'append specs)))
 297         (setf (gethash node-name tree)
 298               (make-instance node-class :name node-name)))
 299       (dolist (node-spec specs)
 300         (let ((par (gethash (car node-spec) tree))
 301               (kids (mapcar (lambda (x) (gethash x tree)) (cdr node-spec))))
 302           (dolist (kid kids)
 303             (assert (not (node-parent kid)))
 304             (setf (slot-value kid 'parent) par))
 305           (setf (slot-value par 'children) kids)))
 306       (values (gethash 'root tree)))))
 307
 308 (defun verify-tree (node)
 309   (dolist (kid (if (slot-boundp node 'children) (node-children node) nil))
 310     (unless (eq (node-parent kid) node)
 311       (error "Node ~S shoud have ~S as parent but has ~S~%"
 312              (node-name kid)
 313              (node-name node)
 314              (node-parent kid)))
 315     (verify-tree kid)))
 316
 317 (defvar *x*
 318   #.(make-tree-from-spec
 319       'twp
 320       '((root a b c f)
 321         (a x y)
 322         (b p q r s)
 323         (c d e g))))
 324
 325 (with-test (:name :tree-with-parent-hand-made-load-form)
 326   (verify-tree *x*))
 327
 328 (eval-when (:compile-toplevel :load-toplevel :execute)
 329   (defclass twp2 (twp) ())
 330   (defmethod make-load-form ((x twp2) &optional environment)
 331     (declare (ignore environment))
 332     (make-load-form-saving-slots x)))
 333
 334 ;; Track the make-load-form FOPs as they fly by at load-time.
 335 (defvar *call-tracker* nil)
 336 (dolist (fop-name 'sb-fasl::(fop-allocate-instance fop-set-slot-values))
 337   (let* ((index (position fop-name sb-fasl::**fop-funs**
 338                           :key
 339                           (lambda (x) (and (functionp x) (sb-kernel:%fun-name x)))))
 340          (fun (aref sb-fasl::**fop-funs** index)))
 341     (setf (aref sb-fasl::**fop-funs** index)
 342           (lambda (&rest args)
 343             (push fop-name *call-tracker*)
 344             (apply fun args)))))
 345
 346 ;; Same as *X* but the MAKE-LOAD-FORM method is different
 347 (defvar *y*
 348   #.(make-tree-from-spec
 349       'twp2
 350       '((root a b c f)
 351         (a x y)
 352         (b p q r s)
 353         (c d e g))))
 354
 355 (assert (= 14 (count 'sb-fasl::fop-allocate-instance *call-tracker*)))
 356 (assert (= 14 (count 'sb-fasl::fop-set-slot-values *call-tracker*)))
 357
 358 (with-test (:name :tree-with-parent-m-l-f-s-s)
 359   (verify-tree *y*))
 360
 361 (eval-when (:compile-toplevel :load-toplevel :execute)
 362   (defclass class-with-shared-slot ()
 363     ((a-slot :allocation :class :initarg :a :accessor thing-a)))
 364   (defmethod make-load-form ((self class-with-shared-slot) &optional environment)
 365     (declare (ignore environment))
 366     (make-load-form-saving-slots self :slot-names '(a-slot))))
 367
 368 (defvar *fool1* (make-instance 'class-with-shared-slot :a 42))
 369 (defvar *fool2* #.(let ((i (make-instance 'class-with-shared-slot)))
 370                     (slot-makunbound i 'a-slot)
 371                     i))
 372
 373 ;; The CLHS writeup is slightly ambiguous about what to with unbound
 374 ;; standard-object slots. Assuming that "initialized" and "uninitialized"
 375 ;; correspond to slots for which SLOT-BOUNDP would return T
 376 ;; and NIL respectively, the meaning of
 377 ;;  "initialized slots in object are initialized ..."
 378 ;; can only mean that you write values into slots of the reconstructed
 379 ;; object that were bound in the compile-time object.
 380 ;;
 381 ;; However "Uninitialized slots in object are not initialized" has two
 382 ;; opposing meanings depending on whether the verb is "are" which
 383 ;; expresses state versus "are [not] initialized" which expresses inaction.
 384 ;; For a similar grammatical construction, DEFINE-METHOD-COMBINATION
 385 ;; says in the "Short Form" description that:
 386 ;;   "that method serves as the effective method and operator is not called."
 387 ;; In that sentence "is [not] called" means that "calling" does NOT happen.
 388 ;; Analogously, "is [not] initialized" would imply that initializing
 389 ;; does NOT happen; it does NOT imply that "uninitializing" DOES happen.
 390 ;;
 391 ;; It seems though, that "are [not] initialized" actually means
 392 ;; SHALL be made to become uninitialized. This is based on the Notes
 393 ;; below the main description referencing SLOT-MAKUNBOUND.
 394 ;; (Though muddied by use of weasel-words "could" and "might")
 395 ;;
 396 ;; Ultimately the two end states (doing something / not doing something)
 397 ;; agree when the slot is local to the object, and no behavior is imparted
 398 ;; by ALLOCATE-INSTANCE to cause slots to be other than unbound.
 399 ;; This tests the edge case: that we DO call slot-makunbound.
 400 (with-test (:name :mlfss-slot-makunbound)
 401   (assert (not (slot-boundp *fool1* 'a-slot))))