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
58 ;;; FIXME: with the addition of the EXTERNAL-FORMAT argument, this
59 ;;; interface has become truly sucky.
60 (defun internal-load (pathname truename if-does-not-exist verbose print
61 &optional contents external-format
)
62 (declare (type (member nil
:error
) if-does-not-exist
))
65 (error 'simple-file-error
67 :format-control
"~S does not exist."
68 :format-arguments
(list (namestring pathname
)))
69 (return-from internal-load nil
)))
71 (let ((*load-truename
* truename
)
72 (*load-pathname
* (merge-pathnames pathname
)))
75 (with-open-file (stream truename
77 :if-does-not-exist if-does-not-exist
78 :external-format external-format
)
79 (load-as-source stream verbose print
)))
81 (with-open-file (stream truename
83 :if-does-not-exist if-does-not-exist
84 :element-type
'(unsigned-byte 8))
85 (load-as-fasl stream verbose print
)))
87 (let* ((fhsss *fasl-header-string-start-string
*)
88 (first-line (make-array (length fhsss
)
89 :element-type
'(unsigned-byte 8)))
91 (with-open-file (stream truename
93 :element-type
'(unsigned-byte 8))
94 (read-sequence first-line stream
))))
96 ((and (= read-length
(length fhsss
))
99 (when (/= (char-code (aref fhsss i
)) (aref first-line i
))
101 (internal-load pathname truename if-does-not-exist verbose print
104 (when (string= (pathname-type truename
) *fasl-file-type
*)
105 (error 'fasl-header-missing
106 :stream
(namestring truename
)
109 (internal-load pathname truename if-does-not-exist verbose print
110 :source external-format
))))))))
112 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
113 ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
114 ;;; or (VALUES PATHNAME NIL) if the file doesn't exist.
116 ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a
117 ;;; single type. By avoiding CMU CL's generality here, we avoid having
118 ;;; to worry about some annoying ambiguities. (E.g. what if the
119 ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and
121 (defun try-default-type (pathname type
)
122 (let ((pn (translate-logical-pathname (make-pathname :type type
:defaults pathname
))))
123 (values pn
(probe-file pn
))))
125 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
126 ;;; the file does not exist.
127 (defun internal-load-default-type
128 (pathname if-does-not-exist verbose print external-format
)
129 (declare (type (member nil
:error
) if-does-not-exist
))
130 (multiple-value-bind (src-pn src-tn
)
131 (try-default-type pathname
*load-source-default-type
*)
132 (multiple-value-bind (obj-pn obj-tn
)
133 (try-default-type pathname
*fasl-file-type
*)
137 (> (file-write-date src-tn
) (file-write-date obj-tn
)))
139 (error "The object file ~A is~@
140 older than the presumed source:~% ~A."
143 (source () :report
"load source file"
144 (internal-load src-pn src-tn if-does-not-exist verbose print
145 :source external-format
))
146 (object () :report
"load object file"
147 (internal-load src-pn obj-tn if-does-not-exist verbose print
150 (internal-load obj-pn obj-tn if-does-not-exist verbose print
:binary
))
152 (internal-load src-pn src-tn if-does-not-exist
153 verbose print
:source external-format
))
155 (internal-load pathname nil if-does-not-exist
156 verbose print nil external-format
))))))
158 ;;; This function mainly sets up special bindings and then calls
159 ;;; sub-functions. We conditionally bind the switches with PROGV so
160 ;;; that people can set them in their init files and have the values
161 ;;; take effect. If the compiler is loaded, we make the
162 ;;; compiler-policy local to LOAD by binding it to itself.
164 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
165 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
166 ;;; CL does not correctly record source file information when LOADing a
167 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
168 (defun load (filespec
170 (verbose *load-verbose
*)
172 (if-does-not-exist t
)
173 (external-format :default
))
175 "Load the file given by FILESPEC into the Lisp environment, returning
177 (let ((*load-depth
* (1+ *load-depth
*))
178 ;; KLUDGE: I can't find in the ANSI spec where it says that
179 ;; DECLAIM/PROCLAIM of optimization policy should have file
180 ;; scope. CMU CL did this, and it seems reasonable, but it
181 ;; might not be right; after all, things like (PROCLAIM '(TYPE
182 ;; ..)) don't have file scope, and I can't find anything under
183 ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which
184 ;; justifies this behavior. Hmm. -- WHN 2001-04-06
185 (sb!c
::*policy
* sb
!c
::*policy
*)
186 ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and
187 ;; *PACKAGE* to the values they held before loading the file."
188 (*package
* (sane-package))
189 (*readtable
* *readtable
*)
190 ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST
191 ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to
192 ;; accept a generalized boolean argument value for this
193 ;; externally-visible function, but the internal functions
194 ;; still use the old convention.
195 (internal-if-does-not-exist (if if-does-not-exist
:error nil
)))
196 ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL
197 ;; gets function return type checking right, we can achieve a
198 ;; similar effect better by adding FTYPE declarations.
200 (if (streamp filespec
)
201 (if (or (equal (stream-element-type filespec
)
203 (load-as-fasl filespec verbose print
)
204 (load-as-source filespec verbose print
))
205 (let* ((pathname (pathname filespec
))
206 (physical-pathname (translate-logical-pathname pathname
))
207 (probed-file (probe-file physical-pathname
)))
209 (pathname-type physical-pathname
))
211 physical-pathname probed-file internal-if-does-not-exist
212 verbose print nil external-format
)
213 (internal-load-default-type
214 pathname internal-if-does-not-exist
215 verbose print external-format
)))))))
217 ;;; Load a code object. BOX-NUM objects are popped off the stack for
218 ;;; the boxed storage section, then SIZE bytes of code are read in.
220 (defun load-code (box-num code-length
)
221 (declare (fixnum box-num code-length
))
223 (let ((code (%primitive sb
!c
:allocate-code-object box-num code-length
))
224 (index (+ sb
!vm
:code-trace-table-offset-slot box-num
)))
225 (declare (type index index
))
226 (setf (%code-debug-info code
) (pop-stack))
229 (setf (code-header-ref code
(decf index
)) (pop-stack)))
230 (sb!sys
:without-gcing
231 (read-n-bytes *fasl-input-stream
*
232 (code-instructions code
)
237 ;;; Moving native code during a GC or purify is not so trivial on the
240 ;;; Our strategy for allowing the loading of x86 native code into the
241 ;;; dynamic heap requires that the addresses of fixups be saved for
242 ;;; all these code objects. After a purify these fixups can be
243 ;;; dropped. In CMU CL, this policy was enabled with
244 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
246 (defun load-code (box-num code-length
)
247 (declare (fixnum box-num code-length
))
249 (let ((stuff (list (pop-stack))))
252 (push (pop-stack) stuff
))
253 (let* ((dbi (car (last stuff
))) ; debug-info
254 (tto (first stuff
))) ; trace-table-offset
256 (setq stuff
(nreverse stuff
))
258 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
259 (when *load-code-verbose
*
260 (format t
"stuff: ~S~%" stuff
)
263 (sb!c
::compiled-debug-info-p dbi
)
264 (sb!c
::debug-info-p dbi
)
265 (sb!c
::compiled-debug-info-name dbi
)
267 (format t
" loading to the dynamic space~%"))
269 (let ((code (%primitive sb
!c
:allocate-code-object
272 (index (+ sb
!vm
:code-trace-table-offset-slot box-num
)))
273 (declare (type index index
))
274 (when *load-code-verbose
*
277 (sb!kernel
::get-lisp-obj-address code
)))
278 (setf (%code-debug-info code
) (pop stuff
))
281 (setf (code-header-ref code
(decf index
)) (pop stuff
)))
282 (sb!sys
:without-gcing
283 (read-n-bytes *fasl-input-stream
*
284 (code-instructions code
)
291 ;;; how we learn about assembler routines at startup
292 (defvar *!initial-assembler-routines
*)
294 (defun !loader-cold-init
()
295 (/show0
"/!loader-cold-init")
296 (dolist (routine *!initial-assembler-routines
*)
297 (setf (gethash (car routine
) *assembler-routines
*) (cdr routine
))))