[70ea77]: src / cold / warm.lisp Maximize Restore History

Download this file

warm.lisp    239 lines (216 with data), 10.5 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
;;;; "warm initialization": initialization which comes after cold init
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "COMMON-LISP-USER")
;;;; general warm init compilation policy
(proclaim '(optimize (compilation-speed 1)
(debug #+sb-show 2 #-sb-show 1)
(inhibit-warnings 2)
(safety 2)
(space 1)
(speed 2)))
;;;; package hacking
;;; Our cross-compilation host is out of the picture now, so we no
;;; longer need to worry about collisions between our package names
;;; and cross-compilation host package names, so now is a good time to
;;; rename any package with a bootstrap-only name SB!FOO to its
;;; permanent name SB-FOO.
;;;
;;; (In principle it might be tidier to do this when dumping the cold
;;; image in genesis, but in practice the logic might be a little
;;; messier because genesis dumps both symbols and packages, and we'd
;;; need to make sure that dumped symbols were renamed in the same way
;;; as dumped packages. Or we could do it in cold init, but it's
;;; easier to experiment with and debug things here in warm init than
;;; in cold init, so we do it here instead.)
(let ((boot-prefix "SB!")
(perm-prefix "SB-"))
(dolist (package (list-all-packages))
(let ((old-package-name (package-name package)))
(when (and (>= (length old-package-name) (length boot-prefix))
(string= boot-prefix old-package-name
:end2 (length boot-prefix)))
(let ((new-package-name (concatenate 'string
perm-prefix
(subseq old-package-name
(length boot-prefix)))))
(rename-package package
new-package-name
(package-nicknames package)))))))
;;; FIXME: This nickname is a deprecated hack for backwards
;;; compatibility with code which assumed the CMU-CL-style
;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
;;; in 0.7.0, so we should get rid of this nickname after a while.
(let ((package (find-package "SB-ALIEN")))
(rename-package package
(package-name package)
(cons "SB-C-CALL" (package-nicknames package))))
(let ((package (find-package "SB-SEQUENCE")))
(rename-package package (package-name package) (list "SEQUENCE")))
;;;; compiling and loading more of the system
(let* ((sys *default-pathname-defaults*)
(src
(merge-pathnames
(make-pathname :directory '(:relative "src" :wild-inferiors)
:name :wild :type :wild)
sys))
(contrib
(merge-pathnames
(make-pathname :directory '(:relative "contrib" :wild-inferiors)
:name :wild :type :wild)
sys)))
(setf (logical-pathname-translations "SYS")
`(("SYS:SRC;**;*.*.*" ,src)
("SYS:CONTRIB;**;*.*.*" ,contrib))))
;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
;;; COMPILE-PCL, at least some of which we should probably have too:
;;;
;;; (with-compilation-unit
;;; (:optimize '(optimize (debug #+(and (not high-security) small) .5
;;; #-(or high-security small) 2
;;; #+high-security 3)
;;; (speed 2) (safety #+(and (not high-security) small) 0
;;; #-(or high-security small) 2
;;; #+high-security 3)
;;; (inhibit-warnings 2))
;;; :optimize-interface '(optimize-interface #+(and (not high-security) small)
;;; (safety 1)
;;; #+high-security (safety 3))
;;; :context-declarations
;;; '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
;;; security 3)
;;; (debug #-high-security 1 #+high-s
;;; ecurity 3))))
;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
;;; (declare (optimize (speed 0))))))
;;;
;;; FIXME: This has mutated into a hack which crudely duplicates
;;; functionality from the existing mechanism to load files from
;;; build-order.lisp-expr, without being quite parallel. (E.g. object
;;; files end up alongside the source files instead of ending up in
;;; parallel directory trees.) Maybe we could merge the filenames here
;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to
;;; indicate that the files should be handled not in cold load but
;;; afterwards.
(dolist (stem '(;; CLOS, derived from the PCL reference implementation
;;
;; This PCL build order is based on a particular
;; (arbitrary) linearization of the declared build
;; order dependencies from the old PCL defsys.lisp
;; dependency database.
#+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr
"SRC;PCL;EARLY-LOW"
"SRC;PCL;MACROS"
"SRC;PCL;COMPILER-SUPPORT"
"SRC;PCL;LOW"
"SRC;PCL;SLOT-NAME"
"SRC;PCL;DEFCLASS"
"SRC;PCL;DEFS"
"SRC;PCL;FNGEN"
"SRC;PCL;CACHE"
"SRC;PCL;DLISP"
"SRC;PCL;DLISP2"
"SRC;PCL;BOOT"
"SRC;PCL;VECTOR"
"SRC;PCL;SLOTS-BOOT"
"SRC;PCL;COMBIN"
"SRC;PCL;DFUN"
"SRC;PCL;CTOR"
"SRC;PCL;BRAID"
"SRC;PCL;DLISP3"
"SRC;PCL;GENERIC-FUNCTIONS"
"SRC;PCL;SLOTS"
"SRC;PCL;INIT"
"SRC;PCL;STD-CLASS"
"SRC;PCL;CPL"
"SRC;PCL;FSC"
"SRC;PCL;METHODS"
"SRC;PCL;FIXUP"
"SRC;PCL;DEFCOMBIN"
"SRC;PCL;CTYPES"
"SRC;PCL;ENV"
"SRC;PCL;DOCUMENTATION"
"SRC;PCL;PRINT-OBJECT"
"SRC;PCL;PRECOM1"
"SRC;PCL;PRECOM2"
;; miscellaneous functionality which depends on CLOS
"SRC;CODE;FORCE-DELAYED-DEFBANGMETHODS"
"SRC;CODE;LATE-CONDITION"
;; CLOS-level support for the Gray OO streams
;; extension (which is also supported by various
;; lower-level hooks elsewhere in the code)
"SRC;PCL;GRAY-STREAMS-CLASS"
"SRC;PCL;GRAY-STREAMS"
;; CLOS-level support for User-extensible sequences.
"SRC;PCL;SEQUENCE"
;; other functionality not needed for cold init, moved
;; to warm init to reduce peak memory requirement in
;; cold init
"SRC;CODE;DESCRIBE"
"SRC;CODE;DESCRIBE-POLICY"
"SRC;CODE;INSPECT"
"SRC;CODE;PROFILE"
"SRC;CODE;NTRACE"
"SRC;CODE;STEP"
"SRC;CODE;RUN-PROGRAM"
;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
;; facility is still used in our ANSI DESCRIBE
;; facility, and should be compiled and loaded after
;; our DESCRIBE facility is compiled and loaded.
"SRC;PCL;DESCRIBE"))
(let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
(sb-int:/show "about to compile" fullname)
(flet ((report-recompile-restart (stream)
(format stream "Recompile file ~S" fullname))
(report-continue-restart (stream)
(format stream
"Continue, using possibly bogus file ~S"
(compile-file-pathname fullname))))
(tagbody
retry-compile-file
(multiple-value-bind (output-truename warnings-p failure-p)
(if *compile-files-p*
(compile-file fullname)
(compile-file-pathname fullname))
(declare (ignore warnings-p))
(sb-int:/show "done compiling" fullname)
(cond ((not output-truename)
(error "COMPILE-FILE of ~S failed." fullname))
(failure-p
(unwind-protect
(restart-case
(error "FAILURE-P was set when creating ~S."
output-truename)
(recompile ()
:report report-recompile-restart
(go retry-compile-file))
(continue ()
:report report-continue-restart
(setf failure-p nil)))
;; Don't leave failed object files lying around.
(when (and failure-p (probe-file output-truename))
(delete-file output-truename)
(format t "~&deleted ~S~%" output-truename))))
;; Otherwise: success, just fall through.
(t nil))
(unless (load output-truename)
(error "LOAD of ~S failed." output-truename))
(sb-int:/show "done loading" output-truename))))))
;;;; setting package documentation
;;; While we were running on the cross-compilation host, we tried to
;;; be portable and not overwrite the doc strings for the standard
;;; packages. But now the cross-compilation host is only a receding
;;; memory, and we can have our way with the doc strings.
(sb-int:/show "setting package documentation")
#+sb-doc (setf (documentation (find-package "COMMON-LISP") t)
"public: home of symbols defined by the ANSI language specification")
#+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t)
"public: the default package for user code and data")
#+sb-doc (setf (documentation (find-package "KEYWORD") t)
"public: home of keywords")