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")
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 ;;; a helper function for LOAD: Load the stuff in a file when we have
57 (defun internal-load (pathname truename if-does-not-exist verbose print
59 (declare (type (member nil :error) if-does-not-exist))
62 (error 'simple-file-error
64 :format-control "~S does not exist."
65 :format-arguments (list (namestring pathname)))
66 (return-from internal-load nil)))
68 (let ((*load-truename* truename)
69 (*load-pathname* pathname))
72 (with-open-file (stream truename
74 :if-does-not-exist if-does-not-exist)
75 (load-as-source stream verbose print)))
77 (with-open-file (stream truename
79 :if-does-not-exist if-does-not-exist
80 :element-type '(unsigned-byte 8))
81 (load-as-fasl stream verbose print)))
83 (let* ((fhsss *fasl-header-string-start-string*)
84 (first-line (make-array (length fhsss)
85 :element-type '(unsigned-byte 8)))
87 (with-open-file (stream truename
89 :element-type '(unsigned-byte 8))
90 (read-sequence first-line stream))))
92 ((and (= read-length (length fhsss))
95 (when (/= (char-code (aref fhsss i)) (aref first-line i))
97 (internal-load pathname truename if-does-not-exist verbose print
100 (when (string= (pathname-type truename) *fasl-file-type*)
101 (error 'fasl-header-missing
102 :stream (namestring truename)
105 (internal-load pathname truename if-does-not-exist verbose print
108 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
109 ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
110 ;;; or (VALUES PATHNAME NIL) if the file doesn't exist.
112 ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a
113 ;;; single type. By avoiding CMU CL's generality here, we avoid having
114 ;;; to worry about some annoying ambiguities. (E.g. what if the
115 ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and
117 (defun try-default-type (pathname type)
118 (let ((pn (translate-logical-pathname (make-pathname :type type :defaults pathname))))
119 (values pn (probe-file pn))))
121 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
122 ;;; the file does not exist.
123 (defun internal-load-default-type (pathname if-does-not-exist verbose print)
124 (declare (type (member nil :error) if-does-not-exist))
125 (multiple-value-bind (src-pn src-tn)
126 (try-default-type pathname *load-source-default-type*)
127 (multiple-value-bind (obj-pn obj-tn)
128 (try-default-type pathname *fasl-file-type*)
132 (> (file-write-date src-tn) (file-write-date obj-tn)))
134 (error "The object file ~A is~@
135 older than the presumed source:~% ~A."
138 ;; FIXME: In CMU CL one of these was a CONTINUE case.
139 ;; There's not one now. I don't remember how restart-case
140 ;; works very well, make sure that it doesn't do anything
141 ;; weird when we don't specify the CONTINUE case.
142 (source () :report "load source file"
143 (internal-load src-pn src-tn if-does-not-exist verbose print
145 (object () :report "load object file"
146 (internal-load src-pn obj-tn if-does-not-exist verbose print
149 (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
151 (internal-load src-pn src-tn if-does-not-exist verbose print :source))
153 (internal-load pathname nil if-does-not-exist verbose print nil))))))
155 ;;; This function mainly sets up special bindings and then calls
156 ;;; sub-functions. We conditionally bind the switches with PROGV so
157 ;;; that people can set them in their init files and have the values
158 ;;; take effect. If the compiler is loaded, we make the
159 ;;; compiler-policy local to LOAD by binding it to itself.
161 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
162 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
163 ;;; CL does not correctly record source file information when LOADing a
164 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
165 (defun load (filespec
167 (verbose *load-verbose*)
169 (if-does-not-exist t)
170 (external-format :default))
172 "Load the file given by FILESPEC into the Lisp environment, returning
174 (declare (ignore external-format))
175 (let ((*load-depth* (1+ *load-depth*))
176 ;; KLUDGE: I can't find in the ANSI spec where it says that
177 ;; DECLAIM/PROCLAIM of optimization policy should have file
178 ;; scope. CMU CL did this, and it seems reasonable, but it
179 ;; might not be right; after all, things like (PROCLAIM '(TYPE
180 ;; ..)) don't have file scope, and I can't find anything under
181 ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which
182 ;; justifies this behavior. Hmm. -- WHN 2001-04-06
183 (sb!c::*policy* sb!c::*policy*)
184 ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and
185 ;; *PACKAGE* to the values they held before loading the file."
186 (*package* (sane-package))
187 (*readtable* *readtable*)
188 ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST
189 ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to
190 ;; accept a generalized boolean argument value for this
191 ;; externally-visible function, but the internal functions
192 ;; still use the old convention.
193 (internal-if-does-not-exist (if if-does-not-exist :error nil)))
194 ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL
195 ;; gets function return type checking right, we can achieve a
196 ;; similar effect better by adding FTYPE declarations.
198 (if (streamp filespec)
199 (if (or (equal (stream-element-type filespec)
201 (load-as-fasl filespec verbose print)
202 (load-as-source filespec verbose print))
203 (let* ((pathname (pathname filespec))
204 (physical-pathname (translate-logical-pathname pathname))
205 (probed-file (probe-file physical-pathname)))
207 (pathname-type physical-pathname))
208 (internal-load physical-pathname
210 internal-if-does-not-exist
213 (internal-load-default-type pathname
214 internal-if-does-not-exist
218 ;;; Load a code object. BOX-NUM objects are popped off the stack for
219 ;;; the boxed storage section, then SIZE bytes of code are read in.
221 (defun load-code (box-num code-length)
222 (declare (fixnum box-num code-length))
224 (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
225 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
226 (declare (type index index))
227 (setf (%code-debug-info code) (pop-stack))
230 (setf (code-header-ref code (decf index)) (pop-stack)))
231 (sb!sys:without-gcing
232 (read-n-bytes *fasl-input-stream*
233 (code-instructions code)
238 ;;; Moving native code during a GC or purify is not so trivial on the
241 ;;; Our strategy for allowing the loading of x86 native code into the
242 ;;; dynamic heap requires that the addresses of fixups be saved for
243 ;;; all these code objects. After a purify these fixups can be
244 ;;; dropped. In CMU CL, this policy was enabled with
245 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
247 (defun load-code (box-num code-length)
248 (declare (fixnum box-num code-length))
250 (let ((stuff (list (pop-stack))))
253 (push (pop-stack) stuff))
254 (let* ((dbi (car (last stuff))) ; debug-info
255 (tto (first stuff))) ; trace-table-offset
257 (setq stuff (nreverse stuff))
259 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
260 (when *load-code-verbose*
261 (format t "stuff: ~S~%" stuff)
264 (sb!c::compiled-debug-info-p dbi)
265 (sb!c::debug-info-p dbi)
266 (sb!c::compiled-debug-info-name dbi)
268 (format t " loading to the dynamic space~%"))
270 (let ((code (%primitive sb!c:allocate-code-object
273 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
274 (declare (type index index))
275 (when *load-code-verbose*
278 (sb!kernel::get-lisp-obj-address code)))
279 (setf (%code-debug-info code) (pop stuff))
282 (setf (code-header-ref code (decf index)) (pop stuff)))
283 (sb!sys:without-gcing
284 (read-n-bytes *fasl-input-stream*
285 (code-instructions code)
292 ;;; how we learn about assembler routines at startup
293 (defvar *!initial-assembler-routines*)
295 (defun !loader-cold-init ()
296 (/show0 "/!loader-cold-init")
297 (dolist (routine *!initial-assembler-routines*)
298 (setf (gethash (car routine) *assembler-routines*) (cdr routine))))