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 (resignal-race-condition
146 (with-open-file (stream pathspec
149 (%load stream :verbose verbose :print print))))
151 ;; Given a simple %LOAD like the above, one can implement any
152 ;; particular defaulting strategy with a wrapper like this one:
153 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
154 (if-does-not-exist :error) (external-format :default))
156 "Load the file given by FILESPEC into the Lisp environment, returning
158 (handler-bind ((file-error
160 ;; This handler will run if %LOAD failed to OPEN
161 ;; the file to look for a fasl header.
162 (let ((pathname (file-error-pathname error)))
163 ;; As PROBE-FILE returned NIL, the file
164 ;; doesn't exist. If the filename we tried to
165 ;; open lacked a type, try loading a filename
166 ;; determined by our defaulting.
167 (when (null (handler-case (probe-file pathname)
168 (file-error (error) error)))
169 (when (null (pathname-type pathname))
170 (let ((default (probe-load-defaults pathname)))
173 (resignal-race-condition
180 if-does-not-exist))))))))
181 ;; If we're here, one of three things happened:
182 ;; (1) %LOAD errored and PROBE-FILE succeeded,
183 ;; in which case the file must be a bad symlink,
184 ;; unreadable, or it was created between %LOAD
185 ;; and PROBE-FILE; (2) %LOAD errored and
186 ;; PROBE-FILE errored, and so things are amiss
187 ;; in the file system (albeit possibly
188 ;; differently now than when OPEN errored); (3)
189 ;; our defaulting did not find a file. In any
190 ;; of these cases, decline to handle the
191 ;; original error or return NIL, depending on
192 ;; IF-DOES-NOT-EXIST.
193 (if if-does-not-exist
195 (return-from load nil)))))
196 (%load pathspec :verbose verbose :print print
197 :external-format external-format)))
199 ;; This implements the defaulting SBCL seems to have inherited from
200 ;; CMU. This routine does not try to perform any loading; all it does
201 ;; is return the pathname (not the truename) of a file to be loaded,
202 ;; or NIL if no such file can be found. This routine is supposed to
203 ;; signal an error if a fasl's timestamp is older than its source
204 ;; file, but we protect against errors in PROBE-FILE, because any of
205 ;; the ways that we might fail to find a defaulted file are reasons
206 ;; not to load it, but not worth exposing to the user who didn't
207 ;; expicitly ask us to load a file with a made-up name (e.g., the
208 ;; defaulted filename might exceed filename length limits).
209 (defun probe-load-defaults (pathname)
210 (destructuring-bind (defaulted-source-pathname
211 defaulted-source-truename
212 defaulted-fasl-pathname
213 defaulted-fasl-truename)
214 (loop for type in (list *load-source-default-type*
216 as probe-pathname = (make-pathname :type type
218 collect probe-pathname
219 collect (handler-case (probe-file probe-pathname)
220 (file-error () nil)))
221 (cond ((and defaulted-fasl-truename
222 defaulted-source-truename
223 (> (resignal-race-condition
224 (file-write-date defaulted-source-truename))
225 (resignal-race-condition
226 (file-write-date defaulted-fasl-truename))))
228 (error "The object file ~A is~@
229 older than the presumed source:~% ~A."
230 defaulted-fasl-truename
231 defaulted-source-truename)
232 (source () :report "load source file"
233 defaulted-source-pathname)
234 (object () :report "load object file"
235 defaulted-fasl-pathname)))
236 (defaulted-fasl-truename defaulted-fasl-pathname)
237 (defaulted-source-truename defaulted-source-pathname))))
239 ;;; Load a code object. BOX-NUM objects are popped off the stack for
240 ;;; the boxed storage section, then SIZE bytes of code are read in.
242 (defun load-code (box-num code-length)
243 (declare (fixnum box-num code-length))
245 (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
246 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
247 (declare (type index index))
248 (setf (%code-debug-info code) (pop-stack))
251 (setf (code-header-ref code (decf index)) (pop-stack)))
252 (sb!sys:without-gcing
253 (read-n-bytes *fasl-input-stream*
254 (code-instructions code)
259 ;;; Moving native code during a GC or purify is not so trivial on the
262 ;;; Our strategy for allowing the loading of x86 native code into the
263 ;;; dynamic heap requires that the addresses of fixups be saved for
264 ;;; all these code objects. After a purify these fixups can be
265 ;;; dropped. In CMU CL, this policy was enabled with
266 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
268 (defun load-code (box-num code-length)
269 (declare (fixnum box-num code-length))
271 (let ((stuff (list (pop-stack))))
274 (push (pop-stack) stuff))
275 (let* ((dbi (car (last stuff))) ; debug-info
276 (tto (first stuff))) ; trace-table-offset
278 (setq stuff (nreverse stuff))
280 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
281 (when *load-code-verbose*
282 (format t "stuff: ~S~%" stuff)
285 (sb!c::compiled-debug-info-p dbi)
286 (sb!c::debug-info-p dbi)
287 (sb!c::compiled-debug-info-name dbi)
289 (format t " loading to the dynamic space~%"))
291 (let ((code (%primitive sb!c:allocate-code-object
294 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
295 (declare (type index index))
296 (when *load-code-verbose*
299 (sb!kernel::get-lisp-obj-address code)))
300 (setf (%code-debug-info code) (pop stuff))
303 (setf (code-header-ref code (decf index)) (pop stuff)))
304 (sb!sys:without-gcing
305 (read-n-bytes *fasl-input-stream*
306 (code-instructions code)
313 ;;; how we learn about assembler routines at startup
314 (defvar *!initial-assembler-routines*)
316 (defun !loader-cold-init ()
317 (/show0 "/!loader-cold-init")
318 (dolist (routine *!initial-assembler-routines*)
319 (setf (gethash (car routine) *assembler-routines*) (cdr routine))))