make-target-2-load.lisp

   1 ;;; Do warm init without compiling files.
   2 (progn
   3   (defvar *compile-files-p* nil)
   4   "about to LOAD warm.lisp (with *compile-files-p* = NIL)")
   5
   6 (progn
   7   (load "src/cold/warm.lisp")
   8
   9   ;;; Remove docstrings that snuck in, as will happen with
  10   ;;; any file compiled in warm load.
  11   #-sb-doc
  12   (let ((count 0))
  13     (macrolet ((clear-it (place)
  14                  `(when ,place
  15                     (setf ,place nil)
  16                     (incf count))))
  17       ;; 1. Functions, macros, special operators
  18       (sb-vm::map-allocated-objects
  19        (lambda (obj type size)
  20          (declare (ignore size))
  21          (case type
  22           (#.sb-vm:code-header-widetag
  23            (dotimes (i (sb-kernel:code-n-entries obj))
  24              (let ((f (sb-kernel:%code-entry-point obj i)))
  25                (clear-it (sb-kernel:%simple-fun-doc f)))))
  26           (#.sb-vm:instance-header-widetag
  27            (when (typep obj 'class)
  28              (when (slot-boundp obj 'sb-pcl::%documentation)
  29                (clear-it (slot-value obj 'sb-pcl::%documentation)))))
  30           (#.sb-vm:funcallable-instance-header-widetag
  31            (when (typep obj 'standard-generic-function)
  32              (when (slot-boundp obj 'sb-pcl::%documentation)
  33                (clear-it (slot-value obj 'sb-pcl::%documentation)))))))
  34        :all)
  35       ;; 2. Variables, types, and anything else
  36       (do-all-symbols (s)
  37         (dolist (category '(:variable :type :typed-structure :setf))
  38           (clear-it (sb-int:info category :documentation s)))
  39         (clear-it (sb-int:info :random-documentation :stuff s))))
  40     (when (plusp count)
  41       (format t "~&Removed ~D doc string~:P" count)))
  42
  43   ;; Share identical FUN-INFOs
  44   sb-int::
  45   (let ((ht (make-hash-table :test 'equalp))
  46         (old-count 0))
  47     (sb-c::call-with-each-globaldb-name
  48      (lambda (name)
  49        (binding* ((info (info :function :info name) :exit-if-null)
  50                   (shared-info (gethash info ht info)))
  51          (incf old-count)
  52          (if (eq info shared-info)
  53              (setf (gethash info ht) info)
  54            (setf (info :function :info name) shared-info)))))
  55     (format t "~&FUN-INFO: Collapsed ~D -> ~D~%"
  56             old-count (hash-table-count ht)))
  57
  58   ;; Share identical FUN-TYPEs.
  59   (let ((ht (make-hash-table :test 'equal))
  60         (raw-accessor
  61          (compile nil '(lambda (f) (sb-vm::%%simple-fun-type f)))))
  62     (sb-vm::map-allocated-objects
  63      (lambda (obj type size)
  64        (declare (ignore type size))
  65        (when (sb-kernel:code-component-p obj)
  66          (dotimes (i (sb-kernel:code-n-entries obj))
  67            (let* ((f (sb-kernel:%code-entry-point obj i))
  68                   (type (funcall raw-accessor f)))
  69              (setf (sb-kernel:%simple-fun-type f)
  70                    (or (gethash type ht) (setf (gethash type ht) type)))))))
  71      :all))
  72
  73   (sb-disassem::!compile-inst-printers)
  74
  75   ;; Unintern no-longer-needed stuff before the possible PURIFY in
  76   ;; SAVE-LISP-AND-DIE.
  77   #-sb-fluid (sb-impl::!unintern-init-only-stuff)
  78
  79   ;; A symbol whose INFO slot underwent any kind of manipulation
  80   ;; such that it now has neither properties nor globaldb info,
  81   ;; can have the slot set back to NIL if it wasn't already.
  82   (do-all-symbols (symbol)
  83     (when (and (sb-kernel:symbol-info symbol)
  84                (null (sb-kernel:symbol-info-vector symbol))
  85                (null (symbol-plist symbol)))
  86       (setf (sb-kernel:symbol-info symbol) nil)))
  87
  88   ;; Set doc strings for the standard packages.
  89   #+sb-doc
  90   (setf (documentation (find-package "COMMON-LISP") t)
  91         "public: home of symbols defined by the ANSI language specification"
  92         (documentation (find-package "COMMON-LISP-USER") t)
  93         "public: the default package for user code and data"
  94         (documentation (find-package "KEYWORD") t)
  95         "public: home of keywords")
  96
  97   "done with warm.lisp, about to GC :FULL T")
  98
  99 (sb-ext:gc :full t)
 100
 101 ;;; resetting compilation policy to neutral values in preparation for
 102 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
 103 ;;; SB-C::*POLICY* has file scope)
 104 (setq sb-c::*policy* (copy-structure sb-c::**baseline-policy**))
 105
 106 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
 107 (dolist (rt (list sb-impl::*standard-readtable* *debug-readtable*))
 108   (setf (readtable-base-char-preference rt) :symbols))
 109 ;;; Change the internal constructor's default too.
 110 sb-kernel::(setf (dsd-default
 111                   (find 'sb-impl::%readtable-string-preference
 112                         (dd-slots (find-defstruct-description 'readtable))
 113                         :key #'dsd-name)) 'character)
 114
 115 ;;; Lock internal packages
 116 #+sb-package-locks
 117 (dolist (p (list-all-packages))
 118   (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER")))
 119     (sb-ext:lock-package p)))
 120
 121 "done with warm.lisp, about to SAVE-LISP-AND-DIE"
 122 ;;; Even if /SHOW output was wanted during build, it's probably
 123 ;;; not wanted by default after build is complete. (And if it's
 124 ;;; wanted, it can easily be turned back on.)
 125 #+sb-show (setf sb-int:*/show* nil)
 126 ;;; The system is complete now, all standard functions are
 127 ;;; defined.
 128 ;;; The call to CTYPE-OF-CACHE-CLEAR is probably redundant.
 129 ;;; SAVE-LISP-AND-DIE calls DEINIT which calls DROP-ALL-HASH-CACHES.
 130 (sb-kernel::ctype-of-cache-clear)
 131 (setq sb-c::*flame-on-necessarily-undefined-thing* t)
 132
 133 ;;; Clean up stray symbols from the CL-USER package.
 134 (with-package-iterator (iter "CL-USER" :internal :external)
 135   (loop (multiple-value-bind (winp symbol) (iter)
 136           (if winp (unintern symbol "CL-USER") (return)))))
 137
 138 ;;; In case there is xref data for internals, repack it here to
 139 ;;; achieve a more compact encoding.
 140 ;;;
 141 ;;; However, repacking changes
 142 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
 143 ;;; the interpretation of xref data written into and loaded from
 144 ;;; fasls. Since fasls should be compatible between images originating
 145 ;;; from the same SBCL build, REPACK-XREF is of no use after the
 146 ;;; target image has been built.
 147 #+sb-xref-for-internals (sb-c::repack-xref :verbose t)
 148 (with-unlocked-packages (#:sb-c)
 149   (fmakunbound 'sb-c::repack-xref))
 150
 151 #+immobile-code (setq sb-c::*compile-to-memory-space* :dynamic)
 152 #+sb-fasteval (setq sb-ext:*evaluator-mode* :interpret)
 153 (sb-ext:save-lisp-and-die
 154  (progn
 155    ;; See comment in 'readtable.lisp'
 156    (setf (readtable-base-char-preference *readtable*) :symbols)
 157    ;; This is a base string since the flag wasn't set to NIL yet.
 158    "output/sbcl.core"))