0.7.13.7:
[sbcl.git] / src / code / target-load.lisp
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")
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
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.
13
14 (in-package "SB!FASL")
15
16 (defvar *load-source-default-type* "lisp"
17   #!+sb-doc
18   "The source file types which LOAD looks for by default.")
19
20 (declaim (type (or pathname null) *load-truename* *load-pathname*))
21 (defvar *load-truename* nil
22   #!+sb-doc
23   "the TRUENAME of the file that LOAD is currently loading")
24 (defvar *load-pathname* nil
25   #!+sb-doc
26   "the defaulted pathname that LOAD is currently loading")
27 \f
28 ;;;; LOAD-AS-SOURCE
29
30 ;;; Load a text file.
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*)
36        t)
37     (if print
38         (let ((results (multiple-value-list (eval sexpr))))
39           (load-fresh-line)
40           (format t "~{~S~^, ~}~%" results))
41       (eval sexpr))))
42 \f
43 ;;;; LOAD itself
44
45 ;;; a helper function for LOAD: Load the stuff in a file when we have
46 ;;; the name.
47 (defun internal-load (pathname truename if-does-not-exist verbose print
48                       &optional contents)
49   (declare (type (member nil :error) if-does-not-exist))
50   (unless truename
51     (if if-does-not-exist
52         (error 'simple-file-error
53                :pathname pathname
54                :format-control "~S does not exist."
55                :format-arguments (list (namestring pathname)))
56         (return-from internal-load nil)))
57
58   (let ((*load-truename* truename)
59         (*load-pathname* pathname))
60     (case contents
61       (:source
62        (with-open-file (stream truename
63                                :direction :input
64                                :if-does-not-exist if-does-not-exist)
65          (load-as-source stream verbose print)))
66       (:binary
67        (with-open-file (stream truename
68                                :direction :input
69                                :if-does-not-exist if-does-not-exist
70                                :element-type '(unsigned-byte 8))
71          (load-as-fasl stream verbose print)))
72       (t
73        (let ((first-line (with-open-file (stream truename :direction :input)
74                            (read-line stream nil)))
75              (fhsss *fasl-header-string-start-string*))
76          (cond
77           ((and first-line
78                 (>= (length (the simple-string first-line))
79                     (length fhsss))
80                 (string= first-line fhsss :end1 (length fhsss)))
81            (internal-load pathname truename if-does-not-exist verbose print
82                           :binary))
83           (t
84            (when (string= (pathname-type truename) *fasl-file-type*)
85              (error "File has a fasl file type, but no fasl file header:~%  ~S"
86                     (namestring truename)))
87            (internal-load pathname truename if-does-not-exist verbose print
88                           :source))))))))
89
90 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
91 ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
92 ;;; or (VALUES PATHNAME NIL) if the file doesn't exist.
93 ;;;
94 ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a
95 ;;; single type. By avoiding CMU CL's generality here, we avoid having
96 ;;; to worry about some annoying ambiguities. (E.g. what if the
97 ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and
98 ;;; "foo.cl" exist?)
99 (defun try-default-type (pathname type)
100   (let ((pn (translate-logical-pathname (make-pathname :type type :defaults pathname))))
101     (values pn (probe-file pn))))
102
103 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
104 ;;; the file does not exist.
105 (defun internal-load-default-type (pathname if-does-not-exist verbose print)
106   (declare (type (member nil :error) if-does-not-exist))
107   (multiple-value-bind (src-pn src-tn)
108       (try-default-type pathname *load-source-default-type*)
109     (multiple-value-bind (obj-pn obj-tn)
110         (try-default-type pathname *fasl-file-type*)
111       (cond
112        ((and obj-tn
113              src-tn
114              (> (file-write-date src-tn) (file-write-date obj-tn)))
115         (restart-case
116          (error "The object file ~A is~@
117                 older than the presumed source:~%  ~A."
118                 (namestring obj-tn)
119                 (namestring src-tn))
120          ;; FIXME: In CMU CL one of these was a CONTINUE case.
121          ;; There's not one now. I don't remember how restart-case
122          ;; works very well, make sure that it doesn't do anything
123          ;; weird when we don't specify the CONTINUE case.
124          (source () :report "load source file"
125            (internal-load src-pn src-tn if-does-not-exist verbose print
126                           :source))
127          (object () :report "load object file"
128             (internal-load src-pn obj-tn if-does-not-exist verbose print
129                            :binary))))
130        (obj-tn
131         (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
132        (src-pn
133         (internal-load src-pn src-tn if-does-not-exist verbose print :source))
134        (t
135         (internal-load pathname nil if-does-not-exist verbose print nil))))))
136
137 ;;; This function mainly sets up special bindings and then calls
138 ;;; sub-functions. We conditionally bind the switches with PROGV so
139 ;;; that people can set them in their init files and have the values
140 ;;; take effect. If the compiler is loaded, we make the
141 ;;; compiler-policy local to LOAD by binding it to itself.
142 ;;;
143 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
144 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
145 ;;; CL does not correctly record source file information when LOADing a
146 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
147 (defun load (filespec
148              &key
149              (verbose *load-verbose*)
150              (print *load-print*)
151              (if-does-not-exist t)
152              (external-format :default))
153   #!+sb-doc
154   "Load the file given by FILESPEC into the Lisp environment, returning
155    T on success."
156   (unless (eq external-format :default)
157     (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
158
159   (let ((*load-depth* (1+ *load-depth*))
160         ;; KLUDGE: I can't find in the ANSI spec where it says that
161         ;; DECLAIM/PROCLAIM of optimization policy should have file
162         ;; scope. CMU CL did this, and it seems reasonable, but it
163         ;; might not be right; after all, things like (PROCLAIM '(TYPE
164         ;; ..)) don't have file scope, and I can't find anything under
165         ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which
166         ;; justifies this behavior. Hmm. -- WHN 2001-04-06
167         (sb!c::*policy* sb!c::*policy*)
168         ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and
169         ;; *PACKAGE* to the values they held before loading the file."
170         (*package* (sane-package))
171         (*readtable* *readtable*)
172         ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST
173         ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to
174         ;; accept a generalized boolean argument value for this
175         ;; externally-visible function, but the internal functions
176         ;; still use the old convention.
177         (internal-if-does-not-exist (if if-does-not-exist :error nil)))
178     ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL
179     ;; gets function return type checking right, we can achieve a
180     ;; similar effect better by adding FTYPE declarations.
181     (values
182      (if (streamp filespec)
183          (if (or (equal (stream-element-type filespec)
184                         '(unsigned-byte 8)))
185              (load-as-fasl filespec verbose print)
186              (load-as-source filespec verbose print))
187          (let* ((pathname (pathname filespec))
188                 (physical-pathname (translate-logical-pathname pathname))
189                 (probed-file (probe-file physical-pathname)))
190            (if (or probed-file
191                    (pathname-type physical-pathname))
192                (internal-load physical-pathname
193                               probed-file
194                               internal-if-does-not-exist
195                               verbose
196                               print)
197                (internal-load-default-type pathname
198                                            internal-if-does-not-exist
199                                            verbose
200                                            print)))))))
201 \f
202 ;;; Load a code object. BOX-NUM objects are popped off the stack for
203 ;;; the boxed storage section, then SIZE bytes of code are read in.
204 #!-x86
205 (defun load-code (box-num code-length)
206   (declare (fixnum box-num code-length))
207   (with-fop-stack t
208     (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
209           (index (+ sb!vm:code-trace-table-offset-slot box-num)))
210       (declare (type index index))
211       (setf (%code-debug-info code) (pop-stack))
212       (dotimes (i box-num)
213         (declare (fixnum i))
214         (setf (code-header-ref code (decf index)) (pop-stack)))
215       (sb!sys:without-gcing
216         (read-n-bytes *fasl-input-stream*
217                       (code-instructions code)
218                       0
219                       code-length))
220       code)))
221
222 ;;; Moving native code during a GC or purify is not so trivial on the
223 ;;; x86 port.
224 ;;;
225 ;;; Our strategy for allowing the loading of x86 native code into the
226 ;;; dynamic heap requires that the addresses of fixups be saved for
227 ;;; all these code objects. After a purify these fixups can be
228 ;;; dropped. In CMU CL, this policy was enabled with
229 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
230 #!+x86
231 (defun load-code (box-num code-length)
232   (declare (fixnum box-num code-length))
233   (with-fop-stack t
234     (let ((stuff (list (pop-stack))))
235       (dotimes (i box-num)
236         (declare (fixnum i))
237         (push (pop-stack) stuff))
238       (let* ((dbi (car (last stuff)))   ; debug-info
239              (tto (first stuff))        ; trace-table-offset
240              ;; Old CMU CL code had maybe-we-shouldn't-load-to-dyn-space
241              ;; pussyfooting around here, apparently dating back to the
242              ;; stone age of the X86 port, but in SBCL we always load
243              ;; to dynamic space. FIXME: So now this "variable" could go
244              ;; away entirely.
245              (load-to-dynamic-space t))
246
247         (setq stuff (nreverse stuff))
248
249         ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
250         (when *load-code-verbose*
251               (format t "stuff: ~S~%" stuff)
252               (format t
253                       "   : ~S ~S ~S ~S~%"
254                       (sb!c::compiled-debug-info-p dbi)
255                       (sb!c::debug-info-p dbi)
256                       (sb!c::compiled-debug-info-name dbi)
257                       tto)
258               (if load-to-dynamic-space
259                   (format t "   loading to the dynamic space~%")
260                   (format t "   loading to the static space~%")))
261
262         (let ((code
263                (if load-to-dynamic-space
264                    (%primitive sb!c:allocate-dynamic-code-object
265                                box-num
266                                code-length)
267                    (%primitive sb!c:allocate-code-object
268                                box-num
269                                code-length)))
270               (index (+ sb!vm:code-trace-table-offset-slot box-num)))
271           (declare (type index index))
272           (when *load-code-verbose*
273             (format t
274                     "  obj addr=~X~%"
275                     (sb!kernel::get-lisp-obj-address code)))
276           (setf (%code-debug-info code) (pop stuff))
277           (dotimes (i box-num)
278             (declare (fixnum i))
279             (setf (code-header-ref code (decf index)) (pop stuff)))
280           (sb!sys:without-gcing
281            (read-n-bytes *fasl-input-stream*
282                          (code-instructions code)
283                          0
284                          code-length))
285           code)))))
286 \f
287 ;;;; linkage fixups
288
289 ;;; how we learn about assembler routines and foreign symbols at startup
290 (defvar *!initial-assembler-routines*)
291 (defvar *!initial-foreign-symbols*)
292 (defun !loader-cold-init ()
293   (dolist (routine *!initial-assembler-routines*)
294     (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
295   (dolist (symbol *!initial-foreign-symbols*)
296     (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
297
298 (declaim (ftype (function (string) sb!vm:word)
299                 foreign-symbol-address-as-integer))
300
301
302 ;;; SB!SYS:GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS is in foreign.lisp, on
303 ;;; platforms that have dynamic loading
304 (defun foreign-symbol-address-as-integer (foreign-symbol)
305   (or (find-foreign-symbol-in-table  foreign-symbol *static-foreign-symbols*)
306       (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
307       (error "unknown foreign symbol: ~S" foreign-symbol)))
308
309 (defun foreign-symbol-address (symbol)
310   (int-sap (foreign-symbol-address-as-integer
311             (sb!vm:extern-alien-name symbol))))