1 ;;;; that part of the loader is only needed on the target system
2 ;;;; (which is basically synonymous with "that part of the loader
3 ;;;; which is not needed by GENESIS")
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!FASL")
16 (defvar *load-source-default-type
* "lisp"
18 "The source file types which LOAD looks for by default.")
20 (declaim (type (or pathname null
) *load-truename
* *load-pathname
*))
21 (defvar *load-truename
* nil
23 "the TRUENAME of the file that LOAD is currently loading")
24 (defvar *load-pathname
* nil
26 "the defaulted pathname that LOAD is currently loading")
30 ;;; Load a text file. (Note that load-as-fasl is in another file.)
31 (defun load-as-source (stream verbose print
)
32 (maybe-announce-load stream verbose
)
33 (do ((sexpr (read stream nil
*eof-object
*)
34 (read stream nil
*eof-object
*)))
35 ((eq sexpr
*eof-object
*)
38 (let ((results (multiple-value-list (eval sexpr
))))
40 (format t
"~{~S~^, ~}~%" results
))
45 (define-condition fasl-header-missing
(invalid-fasl)
46 ((fhsss :reader invalid-fasl-fhsss
:initarg
:fhsss
))
48 (lambda (condition stream
)
49 (format stream
"~@<File ~S has a fasl file type, but no fasl header:~%~
50 Expected ~S, but got ~S.~:@>"
51 (invalid-fasl-stream condition
)
52 (invalid-fasl-expected condition
)
53 (invalid-fasl-fhsss condition
)))))
55 ;; Pretty well any way of doing LOAD will expose race conditions: for
56 ;; example, a file might get deleted or renamed after we open it but
57 ;; before we find its truename. It seems useful to say that
58 ;; detectible ways the file system can fail to be static are good
59 ;; enough reason to stop loading, but to stop in a way that
60 ;; distinguishes errors that occur mid-way through LOAD from the
61 ;; initial failure to OPEN the file, so that handlers can try do
62 ;; defaulting only when the file didn't exist at the start of LOAD,
63 ;; while allowing race conditions to get through.
64 (define-condition load-race-condition
(error)
65 ((pathname :reader load-race-condition-pathname
:initarg
:pathname
))
66 (:report
(lambda (condition stream
)
67 (format stream
"~@<File ~S was deleted or renamed during LOAD.~:>"
68 (load-race-condition-pathname condition
)))))
70 (defmacro resignal-race-condition
(&body body
)
71 `(handler-case (progn ,@body
)
73 (error 'load-race-condition
:pathname
(file-error-pathname error
)))))
75 ;;; The following comment preceded the pre 1.0.12.36 definition of
76 ;;; LOAD; it may no longer be accurate:
78 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
79 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
80 ;; that CMU CL does not correctly record source file information when
81 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
84 ;;; This is our real LOAD. The LOAD below is just a wrapper that does
85 ;;; some defaulting in case the user asks us to load a file that
86 ;;; doesn't exist at the time we start.
87 (defun %load
(pathspec &key
(verbose *load-verbose
*) (print *load-print
*)
88 (if-does-not-exist t
) (external-format :default
))
89 (when (streamp pathspec
)
90 (let* ( ;; Bindings required by ANSI.
91 (*readtable
* *readtable
*)
92 (*package
* (sane-package))
93 ;; FIXME: we should probably document the circumstances
94 ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
95 ;; pathnames during LOAD. ANSI makes no exceptions here.
96 (*load-pathname
* (handler-case (pathname pathspec
)
97 ;; FIXME: it should probably be a type
98 ;; error to try to get a pathname for a
99 ;; stream that doesn't have one, but I
100 ;; don't know if we guarantee that.
102 (*load-truename
* (when *load-pathname
*
103 (handler-case (truename *load-pathname
*)
104 (file-error () nil
))))
105 ;; Bindings used internally.
106 (*load-depth
* (1+ *load-depth
*))
107 ;; KLUDGE: I can't find in the ANSI spec where it says
108 ;; that DECLAIM/PROCLAIM of optimization policy should
109 ;; have file scope. CMU CL did this, and it seems
110 ;; reasonable, but it might not be right; after all,
111 ;; things like (PROCLAIM '(TYPE ..)) don't have file
112 ;; scope, and I can't find anything under PROCLAIM or
113 ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
114 ;; behavior. Hmm. -- WHN 2001-04-06
115 (sb!c
::*policy
* sb
!c
::*policy
*))
117 (if (equal (stream-element-type pathspec
) '(unsigned-byte 8))
118 (load-as-fasl pathspec verbose print
)
119 (load-as-source pathspec verbose print
)))))
120 ;; If we're here, PATHSPEC isn't a stream, so must be some other
121 ;; kind of pathname designator.
122 (with-open-file (stream pathspec
123 :element-type
'(unsigned-byte 8)
125 (if if-does-not-exist
:error nil
))
127 (return-from %load nil
))
128 (let* ((header-line (make-array
129 (length *fasl-header-string-start-string
*)
130 :element-type
'(unsigned-byte 8))))
131 (read-sequence header-line stream
)
132 (if (mismatch header-line
*fasl-header-string-start-string
*
133 :test
#'(lambda (code char
) (= code
(char-code char
))))
134 (let ((truename (resignal-race-condition (probe-file stream
))))
136 (string= (pathname-type truename
) *fasl-file-type
*))
137 (error 'fasl-header-missing
138 :stream
(namestring truename
)
140 :expected
*fasl-header-string-start-string
*)))
142 (file-position stream
:start
)
144 (%load stream
:verbose verbose
:print print
))))))
145 ;; Because we're just opening for input, we don't need
146 ;; WITH-OPEN-FILE's abort handling semantics, and we want to say
147 ;; it's an error for PATHSPEC to have existed before but not now, so
148 ;; WITH-OPEN-STREAM it is.
149 (with-open-stream (stream (resignal-race-condition
151 :external-format external-format
)))
152 (%load stream
:verbose verbose
:print print
)))
154 ;; Given a simple %LOAD like the above, one can implement any
155 ;; particular defaulting strategy with a wrapper like this one:
156 (defun load (pathspec &key
(verbose *load-verbose
*) (print *load-print
*)
157 (if-does-not-exist :error
) (external-format :default
))
159 "Load the file given by FILESPEC into the Lisp environment, returning
161 (handler-bind ((file-error
163 ;; This handler will run if %LOAD failed to OPEN
164 ;; the file to look for a fasl header.
165 (let ((pathname (file-error-pathname error
)))
166 ;; As PROBE-FILE returned NIL, the file
167 ;; doesn't exist. If the filename we tried to
168 ;; open lacked a type, try loading a filename
169 ;; determined by our defaulting.
170 (when (null (handler-case (probe-file pathname
)
171 (file-error (error) error
)))
172 (when (null (pathname-type pathname
))
173 (let ((default (probe-load-defaults pathname
)))
176 (resignal-race-condition
183 if-does-not-exist
))))))))
184 ;; If we're here, one of three things happened:
185 ;; (1) %LOAD errored and PROBE-FILE succeeded,
186 ;; in which case the file must be a bad symlink,
187 ;; unreadable, or it was created between %LOAD
188 ;; and PROBE-FILE; (2) %LOAD errored and
189 ;; PROBE-FILE errored, and so things are amiss
190 ;; in the file system (albeit possibly
191 ;; differently now than when OPEN errored); (3)
192 ;; our defaulting did not find a file. In any
193 ;; of these cases, decline to handle the
194 ;; original error or return NIL, depending on
195 ;; IF-DOES-NOT-EXIST.
196 (if if-does-not-exist
198 (return-from load nil
)))))
199 (%load pathspec
:verbose verbose
:print print
200 :external-format external-format
)))
202 ;; This implements the defaulting SBCL seems to have inherited from
203 ;; CMU. This routine does not try to perform any loading; all it does
204 ;; is return the pathname (not the truename) of a file to be loaded,
205 ;; or NIL if no such file can be found. This routine is supposed to
206 ;; signal an error if a fasl's timestamp is older than its source
207 ;; file, but we protect against errors in PROBE-FILE, because any of
208 ;; the ways that we might fail to find a defaulted file are reasons
209 ;; not to load it, but not worth exposing to the user who didn't
210 ;; expicitly ask us to load a file with a made-up name (e.g., the
211 ;; defaulted filename might exceed filename length limits).
212 (defun probe-load-defaults (pathname)
213 (destructuring-bind (defaulted-source-pathname
214 defaulted-source-truename
215 defaulted-fasl-pathname
216 defaulted-fasl-truename
)
217 (loop for type in
(list *load-source-default-type
*
219 as probe-pathname
= (make-pathname :type type
221 collect probe-pathname
222 collect
(handler-case (probe-file probe-pathname
)
223 (file-error () nil
)))
224 (cond ((and defaulted-fasl-truename
225 defaulted-source-truename
226 (> (resignal-race-condition
227 (file-write-date defaulted-source-truename
))
228 (resignal-race-condition
229 (file-write-date defaulted-fasl-truename
))))
231 (error "The object file ~A is~@
232 older than the presumed source:~% ~A."
233 defaulted-fasl-truename
234 defaulted-source-truename
)
235 (source () :report
"load source file"
236 defaulted-source-pathname
)
237 (object () :report
"load object file"
238 defaulted-fasl-pathname
)))
239 (defaulted-fasl-truename defaulted-fasl-pathname
)
240 (defaulted-source-truename defaulted-source-pathname
))))
242 ;;; Load a code object. BOX-NUM objects are popped off the stack for
243 ;;; the boxed storage section, then SIZE bytes of code are read in.
245 (defun load-code (box-num code-length
)
246 (declare (fixnum box-num code-length
))
248 (let ((code (%primitive sb
!c
:allocate-code-object box-num code-length
))
249 (index (+ sb
!vm
:code-trace-table-offset-slot box-num
)))
250 (declare (type index index
))
251 (setf (%code-debug-info code
) (pop-stack))
254 (setf (code-header-ref code
(decf index
)) (pop-stack)))
255 (sb!sys
:without-gcing
256 (read-n-bytes *fasl-input-stream
*
257 (code-instructions code
)
262 ;;; Moving native code during a GC or purify is not so trivial on the
265 ;;; Our strategy for allowing the loading of x86 native code into the
266 ;;; dynamic heap requires that the addresses of fixups be saved for
267 ;;; all these code objects. After a purify these fixups can be
268 ;;; dropped. In CMU CL, this policy was enabled with
269 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
271 (defun load-code (box-num code-length
)
272 (declare (fixnum box-num code-length
))
274 (let ((stuff (list (pop-stack))))
277 (push (pop-stack) stuff
))
278 (let* ((dbi (car (last stuff
))) ; debug-info
279 (tto (first stuff
))) ; trace-table-offset
281 (setq stuff
(nreverse stuff
))
283 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
284 (when *load-code-verbose
*
285 (format t
"stuff: ~S~%" stuff
)
288 (sb!c
::compiled-debug-info-p dbi
)
289 (sb!c
::debug-info-p dbi
)
290 (sb!c
::compiled-debug-info-name dbi
)
292 (format t
" loading to the dynamic space~%"))
294 (let ((code (%primitive sb
!c
:allocate-code-object
297 (index (+ sb
!vm
:code-trace-table-offset-slot box-num
)))
298 (declare (type index index
))
299 (when *load-code-verbose
*
302 (sb!kernel
::get-lisp-obj-address code
)))
303 (setf (%code-debug-info code
) (pop stuff
))
306 (setf (code-header-ref code
(decf index
)) (pop stuff
)))
307 (sb!sys
:without-gcing
308 (read-n-bytes *fasl-input-stream
*
309 (code-instructions code
)
316 ;;; how we learn about assembler routines at startup
317 (defvar *!initial-assembler-routines
*)
319 (defun !loader-cold-init
()
320 (/show0
"/!loader-cold-init")
321 (dolist (routine *!initial-assembler-routines
*)
322 (setf (gethash (car routine
) *assembler-routines
*) (cdr routine
))))