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