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 stream. (Note that load-as-fasl is in another file.)
31 (defun load-as-source (stream &key verbose print (context "loading"))
32 (maybe-announce-load stream verbose)
33 (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
34 (native (when pathname (native-namestring pathname))))
35 (with-simple-restart (abort "Abort ~A file ~S." context native)
36 (flet ((eval-form (form index)
37 (with-simple-restart (continue "Ignore error and continue ~A file ~S."
40 (with-simple-restart (retry "Retry EVAL of current toplevel form.")
42 (let ((results (multiple-value-list (eval-tlf form index))))
44 (format t "~{~S~^, ~}~%" results))
45 (eval-tlf form index)))
48 (let* ((info (sb!c::make-file-source-info
49 pathname (stream-external-format stream)))
50 (sb!c::*source-info* info))
51 (setf (sb!c::source-info-stream info) stream)
52 (sb!c::do-forms-from-info ((form current-index) info)
53 (sb!c::with-source-paths
54 (sb!c::find-source-paths form current-index)
55 (eval-form form current-index))))
56 (let ((sb!c::*source-info* nil))
57 (do ((form (read stream nil *eof-object*)
58 (read stream nil *eof-object*)))
59 ((eq form *eof-object*))
60 (sb!c::with-source-paths
61 (eval-form form nil))))))))
66 (define-condition fasl-header-missing (invalid-fasl)
67 ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
69 (lambda (condition stream)
70 (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
71 Expected ~S, but got ~S.~:@>"
72 (invalid-fasl-stream condition)
73 (invalid-fasl-expected condition)
74 (invalid-fasl-fhsss condition)))))
77 ;;; The following comment preceded the pre 1.0.12.36 definition of
78 ;;; LOAD; it may no longer be accurate:
80 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
81 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
82 ;; that CMU CL does not correctly record source file information when
83 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
86 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
87 (if-does-not-exist t) (external-format :default))
89 "Load the file given by FILESPEC into the Lisp environment, returning
91 (flet ((load-stream (stream faslp)
92 (let* (;; Bindings required by ANSI.
93 (*readtable* *readtable*)
94 (*package* (sane-package))
95 ;; FIXME: we should probably document the circumstances
96 ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
97 ;; pathnames during LOAD. ANSI makes no exceptions here.
98 (*load-pathname* (handler-case (pathname stream)
99 ;; FIXME: it should probably be a type
100 ;; error to try to get a pathname for a
101 ;; stream that doesn't have one, but I
102 ;; don't know if we guarantee that.
104 (*load-truename* (when *load-pathname*
105 (handler-case (truename stream)
106 (file-error () nil))))
107 ;; Bindings used internally.
108 (*load-depth* (1+ *load-depth*))
109 ;; KLUDGE: I can't find in the ANSI spec where it says
110 ;; that DECLAIM/PROCLAIM of optimization policy should
111 ;; have file scope. CMU CL did this, and it seems
112 ;; reasonable, but it might not be right; after all,
113 ;; things like (PROCLAIM '(TYPE ..)) don't have file
114 ;; scope, and I can't find anything under PROCLAIM or
115 ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
116 ;; behavior. Hmm. -- WHN 2001-04-06
117 (sb!c::*policy* sb!c::*policy*))
120 (load-as-fasl stream verbose print)
121 (sb!c:with-compiler-error-resignalling
122 (load-as-source stream :verbose verbose
125 (when (streamp pathspec)
126 (return-from load (load-stream pathspec (fasl-header-p pathspec))))
127 (let ((pathname (pathname pathspec)))
128 ;; Case 2: Open as binary, try to process as a fasl.
130 (stream (or (open pathspec :element-type '(unsigned-byte 8)
131 :if-does-not-exist nil)
132 (when (null (pathname-type pathspec))
133 (let ((defaulted-pathname
134 (probe-load-defaults pathspec)))
135 (if defaulted-pathname
136 (progn (setq pathname defaulted-pathname)
139 (if if-does-not-exist :error nil)
140 :element-type '(unsigned-byte 8))))))
141 (if if-does-not-exist
142 (error 'simple-file-error
145 "~@<Couldn't load ~S: file does not exist.~@:>"
146 :format-arguments (list pathspec)))))
148 (return-from load nil))
149 (let* ((real (probe-file stream))
151 (and real (string-equal (pathname-type real) *fasl-file-type*))))
152 ;; Don't allow empty .fasls, and assume other empty files
154 (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
155 (fasl-header-p stream :errorp should-be-fasl-p))
156 (return-from load (load-stream stream t)))))
157 ;; Case 3: Open using the gived external format, process as source.
158 (with-open-file (stream pathname :external-format external-format)
159 (load-stream stream nil)))))
161 ;; This implements the defaulting SBCL seems to have inherited from
162 ;; CMU. This routine does not try to perform any loading; all it does
163 ;; is return the pathname (not the truename) of a file to be loaded,
164 ;; or NIL if no such file can be found. This routine is supposed to
165 ;; signal an error if a fasl's timestamp is older than its source
166 ;; file, but we protect against errors in PROBE-FILE, because any of
167 ;; the ways that we might fail to find a defaulted file are reasons
168 ;; not to load it, but not worth exposing to the user who didn't
169 ;; expicitly ask us to load a file with a made-up name (e.g., the
170 ;; defaulted filename might exceed filename length limits).
171 (defun probe-load-defaults (pathname)
172 (destructuring-bind (defaulted-source-pathname
173 defaulted-source-truename
174 defaulted-fasl-pathname
175 defaulted-fasl-truename)
176 (loop for type in (list *load-source-default-type*
178 as probe-pathname = (make-pathname :type type
180 collect probe-pathname
181 collect (handler-case (probe-file probe-pathname)
182 (file-error () nil)))
183 (cond ((and defaulted-fasl-truename
184 defaulted-source-truename
185 (> (file-write-date defaulted-source-truename)
186 (file-write-date defaulted-fasl-truename)))
188 (error "The object file ~A is~@
189 older than the presumed source:~% ~A."
190 defaulted-fasl-truename
191 defaulted-source-truename)
192 (source () :report "load source file"
193 defaulted-source-pathname)
194 (object () :report "load object file"
195 defaulted-fasl-pathname)))
196 (defaulted-fasl-truename defaulted-fasl-pathname)
197 (defaulted-source-truename defaulted-source-pathname))))
199 ;;; Load a code object. BOX-NUM objects are popped off the stack for
200 ;;; the boxed storage section, then SIZE bytes of code are read in.
202 (defun load-code (box-num code-length)
203 (declare (fixnum box-num code-length))
205 (let ((code (sb!c:allocate-code-object box-num code-length))
206 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
207 (declare (type index index))
208 (setf (%code-debug-info code) (pop-stack))
211 (setf (code-header-ref code (decf index)) (pop-stack)))
212 (sb!sys:without-gcing
213 (read-n-bytes *fasl-input-stream*
214 (code-instructions code)
219 ;;; Moving native code during a GC or purify is not so trivial on the
222 ;;; Our strategy for allowing the loading of x86 native code into the
223 ;;; dynamic heap requires that the addresses of fixups be saved for
224 ;;; all these code objects. After a purify these fixups can be
225 ;;; dropped. In CMU CL, this policy was enabled with
226 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
228 (defun load-code (box-num code-length)
229 (declare (fixnum box-num code-length))
231 (let ((stuff (list (pop-stack))))
234 (push (pop-stack) stuff))
235 (let* ((dbi (car (last stuff))) ; debug-info
236 (tto (first stuff))) ; trace-table-offset
238 (setq stuff (nreverse stuff))
240 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
241 (when *load-code-verbose*
242 (format t "stuff: ~S~%" stuff)
245 (sb!c::compiled-debug-info-p dbi)
246 (sb!c::debug-info-p dbi)
247 (sb!c::compiled-debug-info-name dbi)
249 (format t " loading to the dynamic space~%"))
251 (let ((code (sb!c:allocate-code-object box-num code-length))
252 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
253 (declare (type index index))
254 (when *load-code-verbose*
257 (sb!kernel::get-lisp-obj-address code)))
258 (setf (%code-debug-info code) (pop stuff))
261 (setf (code-header-ref code (decf index)) (pop stuff)))
262 (sb!sys:without-gcing
263 (read-n-bytes *fasl-input-stream*
264 (code-instructions code)
271 ;;; how we learn about assembler routines at startup
272 (defvar *!initial-assembler-routines*)
274 (defun !loader-cold-init ()
275 (/show0 "/!loader-cold-init")
276 (dolist (routine *!initial-assembler-routines*)
277 (setf (gethash (car routine) *assembler-routines*) (cdr routine))))