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