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!IMPL")
16 (defvar *load-source-default-type* "lisp"
18 "The source file types which LOAD looks for by default.")
20 (defvar *load-truename* nil
22 "the TRUENAME of the file that LOAD is currently loading")
24 (defvar *load-pathname* nil
26 "the defaulted pathname that LOAD is currently loading")
28 (declaim (type (or pathname null) *load-truename* *load-pathname*))
33 (defun load-as-source (stream verbose print)
34 (do-load-verbose stream verbose)
35 (do ((sexpr (read stream nil *eof-object*)
36 (read stream nil *eof-object*)))
37 ((eq sexpr *eof-object*)
40 (let ((results (multiple-value-list (eval sexpr))))
42 (format t "~{~S~^, ~}~%" results))
47 ;;; a helper function for LOAD: Load the stuff in a file when we have the name.
48 (defun internal-load (pathname truename if-does-not-exist verbose print
50 (declare (type (member nil :error) if-does-not-exist))
53 (error 'simple-file-error
55 :format-control "~S does not exist."
56 :format-arguments (list (namestring pathname)))
57 (return-from internal-load nil)))
59 (let ((*load-truename* truename)
60 (*load-pathname* pathname))
63 (with-open-file (stream truename
65 :if-does-not-exist if-does-not-exist)
66 (load-as-source stream verbose print)))
68 (with-open-file (stream truename
70 :if-does-not-exist if-does-not-exist
71 :element-type '(unsigned-byte 8))
72 (load-as-fasl stream verbose print)))
74 (let ((first-line (with-open-file (stream truename :direction :input)
75 (read-line stream nil)))
76 (fhs sb!c:*fasl-header-string-start-string*))
79 (>= (length (the simple-string first-line))
81 (string= first-line fhs :end1 (length fhs)))
82 (internal-load pathname truename if-does-not-exist verbose print
85 (when (string= (pathname-type truename)
86 sb!c:*backend-fasl-file-type*)
87 (error "File has a fasl file type, but no fasl file header:~% ~S"
88 (namestring truename)))
89 (internal-load pathname truename if-does-not-exist verbose print
92 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
93 ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
94 ;;; or (VALUES PATHNAME NIL) if the file doesn't exist.
96 ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a
97 ;;; single type. By avoiding CMU CL's generality here, we avoid having
98 ;;; to worry about some annoying ambiguities. (E.g. what if the
99 ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and
101 (defun try-default-type (pathname type)
102 (let ((pn (make-pathname :type type :defaults pathname)))
103 (values pn (probe-file pn))))
105 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
106 ;;; the file does not exist.
107 (defun internal-load-default-type (pathname if-does-not-exist verbose print)
108 (declare (type (member nil :error) if-does-not-exist))
109 (multiple-value-bind (src-pn src-tn)
110 (try-default-type pathname *load-source-default-type*)
111 (multiple-value-bind (obj-pn obj-tn)
112 (try-default-type pathname sb!c:*backend-fasl-file-type*)
116 (> (file-write-date src-tn) (file-write-date obj-tn)))
118 (error "The object file ~A is~@
119 older than the presumed source:~% ~A."
122 ;; FIXME: In CMU CL one of these was a CONTINUE case.
123 ;; There's not one now. I don't remember how restart-case
124 ;; works very well, make sure that it doesn't do anything
125 ;; weird when we don't specify the CONTINUE case.
126 (source () :report "load source file"
127 (internal-load src-pn src-tn if-does-not-exist verbose print
129 (object () :report "load object file"
130 (internal-load src-pn obj-tn if-does-not-exist verbose print
133 (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
135 (internal-load src-pn src-tn if-does-not-exist verbose print :source))
137 (internal-load pathname nil if-does-not-exist verbose print nil))))))
139 ;;; This function mainly sets up special bindings and then calls
140 ;;; sub-functions. We conditionally bind the switches with PROGV so
141 ;;; that people can set them in their init files and have the values
142 ;;; take effect. If the compiler is loaded, we make the
143 ;;; compiler-policy local to LOAD by binding it to itself.
145 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
146 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
147 ;;; CL does not correctly record source file information when LOADing a
148 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
149 (defun load (filespec
151 (verbose *load-verbose*)
153 (if-does-not-exist t)
154 (external-format :default))
156 "Load the file given by FILESPEC into the Lisp environment, returning
158 (unless (eq external-format :default)
159 (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
161 (let ((*load-depth* (1+ *load-depth*))
162 ;; KLUDGE: I can't find in the ANSI spec where it says that
163 ;; DECLAIM/PROCLAIM of optimization policy should have file
164 ;; scope. CMU CL did this, and it seems reasonable, but it
165 ;; might not be right; after all, things like (PROCLAIM '(TYPE
166 ;; ..)) don't have file scope, and I can't find anything under
167 ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which
168 ;; justifies this behavior. Hmm. -- WHN 2001-04-06
169 (sb!c::*policy* sb!c::*policy*)
170 ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and
171 ;; *PACKAGE* to the values they held before loading the file."
172 (*package* (sane-package))
173 (*readtable* *readtable*)
174 ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST
175 ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to
176 ;; accept a generalized boolean argument value for this
177 ;; externally-visible function, but the internal functions
178 ;; still use the old convention.
179 (internal-if-does-not-exist (if if-does-not-exist :error nil)))
180 ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL
181 ;; gets function return type checking right, we can achieve a
182 ;; similar effect better by adding FTYPE declarations.
184 (if (streamp filespec)
185 (if (or (equal (stream-element-type filespec)
187 (load-as-fasl filespec verbose print)
188 (load-as-source filespec verbose print))
189 (let (;; FIXME: MERGE-PATHNAMES doesn't work here for
190 ;; FILESPEC="TEST:Load-Test" and
191 ;; (LOGICAL-PATHNAME-TRANSLATIONS "TEST")
192 ;; = (("**;*.*.*" "/foo/bar/**/*.*")).
193 ;; Physicalizing the pathname before merging
194 ;; is a workaround, but the ANSI spec talks about
195 ;; MERGE-PATHNAMES accepting (and returning)
196 ;; logical pathnames, so a true fix would probably
197 ;; include fixing MERGE-PATHNAMES, then probably
198 ;; revisiting this code.
199 (ppn (physicalize-pathname (pathname filespec))))
200 (if (wild-pathname-p ppn)
201 (let ((files (directory ppn)))
204 (error 'file-error :pathname filespec))
205 (dolist (file files t)
208 internal-if-does-not-exist
211 (let ((tn (probe-file ppn)))
212 (if (or tn (pathname-type ppn))
215 internal-if-does-not-exist
218 (internal-load-default-type
220 internal-if-does-not-exist
224 ;;; Load a code object. BOX-NUM objects are popped off the stack for
225 ;;; the boxed storage section, then SIZE bytes of code are read in.
227 (defun load-code (box-num code-length)
228 (declare (fixnum box-num code-length))
230 (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
231 (index (+ #!-gengc sb!vm:code-trace-table-offset-slot
232 #!+gengc sb!vm:code-debug-info-slot
234 (declare (type index index))
235 #!-gengc (setf (%code-debug-info code) (pop-stack))
238 (setf (code-header-ref code (decf index)) (pop-stack)))
239 (sb!sys:without-gcing
240 (read-n-bytes *fasl-file*
241 (code-instructions code)
244 #!+gengc (* code-length sb!vm:word-bytes)))
248 (defun load-code (box-num code-length)
249 (declare (fixnum box-num code-length))
251 (let ((stuff (list (pop-stack))))
254 (push (pop-stack) stuff))
255 (let* ((dbi (car (last stuff))) ; debug-info
256 (tto (first stuff)) ; trace-table-offset
257 (load-to-dynamic-space
258 (or *enable-dynamic-space-code*
259 ;; definitely byte-compiled code?
260 (and *load-byte-compiled-code-to-dynamic-space*
261 (sb!c::debug-info-p dbi)
262 (not (sb!c::compiled-debug-info-p dbi)))
263 ;; or a x86 top level form?
264 (and *load-x86-tlf-to-dynamic-space*
265 (sb!c::compiled-debug-info-p dbi)
266 (string= (sb!c::compiled-debug-info-name dbi)
267 "top-level form")))) )
269 (setq stuff (nreverse stuff))
271 ;; Check that tto is always a list for byte-compiled
272 ;; code. Could be used an alternate check.
273 (when (and (typep tto 'list)
274 (not (and (sb!c::debug-info-p dbi)
275 (not (sb!c::compiled-debug-info-p dbi)))))
276 ;; FIXME: What is this for?
277 (format t "* tto list on non-bc code: ~S~% ~S ~S~%"
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 (if load-to-dynamic-space
290 (format t " loading to the dynamic space~%")
291 (format t " loading to the static space~%")))
294 (if load-to-dynamic-space
295 (%primitive sb!c:allocate-dynamic-code-object
298 (%primitive sb!c:allocate-code-object
301 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
302 (declare (type index index))
303 (when *load-code-verbose*
306 (sb!kernel::get-lisp-obj-address code)))
307 (setf (%code-debug-info code) (pop stuff))
310 (setf (code-header-ref code (decf index)) (pop stuff)))
311 (sb!sys:without-gcing
312 (read-n-bytes *fasl-file* (code-instructions code) 0 code-length))
317 ;;; how we learn about assembler routines and foreign symbols at startup
318 (defvar *!initial-assembler-routines*)
319 (defvar *!initial-foreign-symbols*)
320 (defun !loader-cold-init ()
321 (dolist (routine *!initial-assembler-routines*)
322 (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
323 (dolist (symbol *!initial-foreign-symbols*)
324 (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
326 (declaim (ftype (function (string) sb!vm:word)
327 foreign-symbol-address-as-integer))
328 (defun foreign-symbol-address-as-integer (foreign-symbol)
329 (or (gethash foreign-symbol *static-foreign-symbols*)
330 (gethash (concatenate 'simple-string
331 #!+linux "ldso_stub__"
333 #!+freebsd "ldso_stub__"
335 *static-foreign-symbols*)
336 (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
337 (error "unknown foreign symbol: ~S" foreign-symbol)))
339 (defun foreign-symbol-address (symbol)
340 (int-sap (foreign-symbol-address-as-integer
341 (sb!vm:extern-alien-name symbol))))