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")
19 (defvar *load-source-types* '("lisp" "l" "cl" "lsp")
21 "The source file types which LOAD recognizes.")
23 (defvar *load-object-types*
24 '(#.sb!c:*backend-fasl-file-type*
25 #.(sb!c:backend-byte-fasl-file-type)
28 "A list of the object file types recognized by LOAD.")
30 (declaim (list *load-source-types* *load-object-types*))
32 (defvar *load-truename* nil
34 "the TRUENAME of the file that LOAD is currently loading")
36 (defvar *load-pathname* nil
38 "the defaulted pathname that LOAD is currently loading")
40 (declaim (type (or pathname null) *load-truename* *load-pathname*))
44 ;;; something not EQ to anything read from a file
45 ;;; FIXME: shouldn't be DEFCONSTANT; and maybe make a shared EOF cookie in
46 ;;; SB-INT:*EOF-VALUE*?
47 (defconstant load-eof-value '(()))
50 (defun sloload (stream verbose print)
51 (do-load-verbose stream verbose)
52 (do ((sexpr (read stream nil load-eof-value)
53 (read stream nil load-eof-value)))
54 ((eq sexpr load-eof-value)
57 (let ((results (multiple-value-list (eval sexpr))))
59 (format t "~{~S~^, ~}~%" results))
64 ;;; a helper function for LOAD: Load the stuff in a file when we have the name.
65 (defun internal-load (pathname truename if-does-not-exist verbose print
67 (declare (type (member nil :error) if-does-not-exist))
70 (error 'simple-file-error
72 :format-control "~S does not exist."
73 :format-arguments (list (namestring pathname)))
74 (return-from internal-load nil)))
76 (let ((*load-truename* truename)
77 (*load-pathname* pathname))
80 (with-open-file (stream truename
82 :if-does-not-exist if-does-not-exist)
83 (sloload stream verbose print)))
85 (with-open-file (stream truename
87 :if-does-not-exist if-does-not-exist
88 :element-type '(unsigned-byte 8))
89 (fasload stream verbose print)))
91 (let ((first-line (with-open-file (stream truename :direction :input)
92 (read-line stream nil)))
93 (fhs sb!c:*fasl-header-string-start-string*))
96 (>= (length (the simple-string first-line))
98 (string= first-line fhs :end1 (length fhs)))
99 (internal-load pathname truename if-does-not-exist verbose print
102 (when (member (pathname-type truename)
105 (error "File has a fasl file type, but no fasl file header:~% ~S"
106 (namestring truename)))
107 (internal-load pathname truename if-does-not-exist verbose print
110 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE
111 (defun try-default-types (pathname types lp-type)
112 ;; Modified 18-Jan-97/pw for logical-pathname support.
114 ;; FIXME: How does logical-pathname support interact with
115 ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES*?
116 (flet ((frob (pathname type)
117 (let* ((pn (make-pathname :type type :defaults pathname))
118 (tn (probe-file pn)))
120 (if (typep pathname 'logical-pathname)
121 (frob pathname lp-type)
122 (dolist (type types (values nil nil))
123 (multiple-value-bind (pn tn) (frob pathname type)
125 (return (values pn tn))))))))
127 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where the file
129 (defun internal-load-default-type (pathname if-does-not-exist verbose print)
130 (declare (type (member nil :error) if-does-not-exist))
131 ;; FIXME: How do the fixed "LISP" and "FASL" types interact with the
132 ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES* values?
133 (multiple-value-bind (src-pn src-tn)
134 (try-default-types pathname *load-source-types* "LISP")
135 (multiple-value-bind (obj-pn obj-tn)
136 (try-default-types pathname *load-object-types* "FASL")
140 (> (file-write-date src-tn) (file-write-date obj-tn)))
142 (error "The object file ~A is~@
143 older than the presumed source:~% ~A."
146 ;; FIXME: In CMU CL one of these was a CONTINUE case.
147 ;; There's not one now. I don't remember how restart-case
148 ;; works very well, make sure that it doesn't do anything
149 ;; weird when we don't specify the CONTINUE case.
150 (source () :report "load source file"
151 (internal-load src-pn src-tn if-does-not-exist verbose print
153 (object () :report "load object file"
154 (internal-load src-pn obj-tn if-does-not-exist verbose print
157 (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
159 (internal-load src-pn src-tn if-does-not-exist verbose print :source))
161 (internal-load pathname nil if-does-not-exist verbose print nil))))))
163 ;;; This function mainly sets up special bindings and then calls sub-functions.
164 ;;; We conditionally bind the switches with PROGV so that people can set them
165 ;;; in their init files and have the values take effect. If the compiler is
166 ;;; loaded, we make the compiler-policy local to LOAD by binding it to itself.
168 ;;; FIXME: ANSI specifies an EXTERNAL-FORMAT keyword argument.
170 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
171 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
172 ;;; CL does not correctly record source file information when LOADing a
173 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
174 (defun load (filespec
176 (verbose *load-verbose*)
178 (if-does-not-exist t))
180 "Loads the file given by FILESPEC into the Lisp environment, returning
181 T on success. These options are defined:
184 What should we do if the file can't be located? If true (the
185 default), signal an error. If NIL, simply return NIL.
188 If true, print a line describing each file loaded. The default
192 If true, print information about loaded values. When loading the
193 source, the result of evaluating each top-level form is printed.
194 The default is *LOAD-PRINT*."
196 (let ((sb!c::*default-cookie* sb!c::*default-cookie*)
197 (sb!c::*default-interface-cookie* sb!c::*default-interface-cookie*)
198 (*package* *package*)
199 (*readtable* *readtable*)
200 (*load-depth* (1+ *load-depth*))
201 ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST argument of
202 ;; (MEMBER :ERROR NIL) type. ANSI constrains us to accept a generalized
203 ;; boolean argument value for this externally-visible function, but the
204 ;; internal functions still use the old convention.
205 (internal-if-does-not-exist (if if-does-not-exist :error nil)))
206 ;; FIXME: This VALUES wrapper is inherited from CMU CL.
207 ;; Once SBCL gets function return type checking right, we can
208 ;; achieve a similar effect better by adding FTYPE declarations.
210 (if (streamp filespec)
211 (if (or (equal (stream-element-type filespec)
213 (fasload filespec verbose print)
214 (sloload filespec verbose print))
215 (let ((pn (merge-pathnames (pathname filespec)
216 *default-pathname-defaults*)))
217 (if (wild-pathname-p pn)
218 (let ((files (directory pn)))
221 (error 'file-error :pathname filespec))
222 (dolist (file files t)
225 internal-if-does-not-exist
228 (let ((tn (probe-file pn)))
229 (if (or tn (pathname-type pn))
232 internal-if-does-not-exist
235 (internal-load-default-type
237 internal-if-does-not-exist
241 ;;; Load a code object. BOX-NUM objects are popped off the stack for
242 ;;; the boxed storage section, then SIZE bytes of code are read in.
244 (defun load-code (box-num code-length)
245 (declare (fixnum box-num code-length))
247 (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
248 (index (+ #!-gengc sb!vm:code-trace-table-offset-slot
249 #!+gengc sb!vm:code-debug-info-slot
251 (declare (type index index))
252 #!-gengc (setf (%code-debug-info code) (pop-stack))
255 (setf (code-header-ref code (decf index)) (pop-stack)))
256 (sb!sys:without-gcing
257 (read-n-bytes *fasl-file*
258 (code-instructions code)
261 #!+gengc (* code-length sb!vm:word-bytes)))
265 (defun load-code (box-num code-length)
266 (declare (fixnum box-num code-length))
268 (let ((stuff (list (pop-stack))))
271 (push (pop-stack) stuff))
272 (let* ((dbi (car (last stuff))) ; debug-info
273 (tto (first stuff)) ; trace-table-offset
274 (load-to-dynamic-space
275 (or *enable-dynamic-space-code*
276 ;; definitely byte-compiled code?
277 (and *load-byte-compiled-code-to-dynamic-space*
278 (sb!c::debug-info-p dbi)
279 (not (sb!c::compiled-debug-info-p dbi)))
280 ;; or a x86 top level form?
281 (and *load-x86-tlf-to-dynamic-space*
282 (sb!c::compiled-debug-info-p dbi)
283 (string= (sb!c::compiled-debug-info-name dbi)
284 "top-level form")))) )
286 (setq stuff (nreverse stuff))
288 ;; Check that tto is always a list for byte-compiled
289 ;; code. Could be used an alternate check.
290 (when (and (typep tto 'list)
291 (not (and (sb!c::debug-info-p dbi)
292 (not (sb!c::compiled-debug-info-p dbi)))))
293 ;; FIXME: What is this for?
294 (format t "* tto list on non-bc code: ~S~% ~S ~S~%"
297 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
298 (when *load-code-verbose*
299 (format t "stuff: ~S~%" stuff)
302 (sb!c::compiled-debug-info-p dbi)
303 (sb!c::debug-info-p dbi)
304 (sb!c::compiled-debug-info-name dbi)
306 (if load-to-dynamic-space
307 (format t " loading to the dynamic space~%")
308 (format t " loading to the static space~%")))
311 (if load-to-dynamic-space
312 (%primitive sb!c:allocate-dynamic-code-object
315 (%primitive sb!c:allocate-code-object
318 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
319 (declare (type index index))
320 (when *load-code-verbose*
323 (sb!kernel::get-lisp-obj-address code)))
324 (setf (%code-debug-info code) (pop stuff))
327 (setf (code-header-ref code (decf index)) (pop stuff)))
328 (sb!sys:without-gcing
329 (read-n-bytes *fasl-file* (code-instructions code) 0 code-length))
334 ;;; how we learn about assembler routines and foreign symbols at startup
335 (defvar *!initial-assembler-routines*)
336 (defvar *!initial-foreign-symbols*)
337 (defun !loader-cold-init ()
338 (dolist (routine *!initial-assembler-routines*)
339 (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
340 (dolist (symbol *!initial-foreign-symbols*)
341 (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
343 (declaim (ftype (function (string) sb!vm:word) foreign-symbol-address-as-integer))
344 (defun foreign-symbol-address-as-integer (foreign-symbol)
345 (or (gethash foreign-symbol *static-foreign-symbols*)
346 (gethash (concatenate 'simple-string
347 #!+linux "ldso_stub__"
349 #!+freebsd "ldso_stub__"
351 *static-foreign-symbols*)
352 (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
353 (error "unknown foreign symbol: ~S" foreign-symbol)))
355 (defun foreign-symbol-address (symbol)
356 (int-sap (foreign-symbol-address-as-integer (sb!vm:extern-alien-name symbol))))