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