1.0.21.14: fix CHECK-FASL-HEADER buglet
[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 stream.  (Note that load-as-fasl is in another file.)
31 (defun load-as-source (stream verbose print)
32   (maybe-announce-load stream verbose)
33   (macrolet ((do-sexprs ((sexpr stream) &body body)
34                (aver (symbolp sexpr))
35                (with-unique-names (source-info)
36                  (once-only ((stream stream))
37                    `(if (handler-case (pathname stream)
38                           (error () nil))
39                         (let ((,source-info (sb!c::make-file-source-info
40                                             (pathname ,stream)
41                                             (stream-external-format ,stream))))
42                           (setf (sb!c::source-info-stream ,source-info) ,stream)
43                           (sb!c::do-forms-from-info ((,sexpr) ,source-info)
44                             ,@body))
45                         (do ((,sexpr (read ,stream nil *eof-object*)
46                                      (read ,stream nil *eof-object*)))
47                             ((eq ,sexpr *eof-object*))
48                           ,@body))))))
49     (do-sexprs (sexpr stream)
50       (if print
51           (let ((results (multiple-value-list (eval sexpr))))
52             (load-fresh-line)
53             (format t "~{~S~^, ~}~%" results))
54           (eval sexpr)))
55     t))
56 \f
57 ;;;; LOAD itself
58
59 (define-condition fasl-header-missing (invalid-fasl)
60   ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
61   (:report
62    (lambda (condition stream)
63      (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
64                      Expected ~S, but got ~S.~:@>"
65              (invalid-fasl-stream condition)
66              (invalid-fasl-expected condition)
67              (invalid-fasl-fhsss condition)))))
68
69
70 ;;; The following comment preceded the pre 1.0.12.36 definition of
71 ;;; LOAD; it may no longer be accurate:
72
73 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
74 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
75 ;; that CMU CL does not correctly record source file information when
76 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
77 ;; and fix it if so.
78
79 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
80              (if-does-not-exist t) (external-format :default))
81   #!+sb-doc
82   "Load the file given by FILESPEC into the Lisp environment, returning
83    T on success."
84   (flet ((load-stream (stream)
85            (let* (;; Bindings required by ANSI.
86                   (*readtable* *readtable*)
87                   (*package* (sane-package))
88                   ;; FIXME: we should probably document the circumstances
89                   ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
90                   ;; pathnames during LOAD.  ANSI makes no exceptions here.
91                   (*load-pathname* (handler-case (pathname stream)
92                                      ;; FIXME: it should probably be a type
93                                      ;; error to try to get a pathname for a
94                                      ;; stream that doesn't have one, but I
95                                      ;; don't know if we guarantee that.
96                                      (error () nil)))
97                   (*load-truename* (when *load-pathname*
98                                      (handler-case (truename stream)
99                                        (file-error () nil))))
100                   ;; Bindings used internally.
101                   (*load-depth* (1+ *load-depth*))
102                   ;; KLUDGE: I can't find in the ANSI spec where it says
103                   ;; that DECLAIM/PROCLAIM of optimization policy should
104                   ;; have file scope. CMU CL did this, and it seems
105                   ;; reasonable, but it might not be right; after all,
106                   ;; things like (PROCLAIM '(TYPE ..)) don't have file
107                   ;; scope, and I can't find anything under PROCLAIM or
108                   ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
109                   ;; behavior. Hmm. -- WHN 2001-04-06
110                   (sb!c::*policy* sb!c::*policy*))
111              (return-from load
112                (if (equal (stream-element-type stream) '(unsigned-byte 8))
113                    (load-as-fasl stream verbose print)
114                    (load-as-source stream verbose print))))))
115     (when (streamp pathspec)
116       (return-from load (load-stream pathspec)))
117     (let ((pathname (pathname pathspec)))
118       (with-open-stream
119           (stream (or (open pathspec :element-type '(unsigned-byte 8)
120                             :if-does-not-exist nil)
121                       (when (null (pathname-type pathspec))
122                         (let ((defaulted-pathname
123                                (probe-load-defaults pathspec)))
124                           (if defaulted-pathname
125                               (progn (setq pathname defaulted-pathname)
126                                      (open pathname
127                                            :if-does-not-exist
128                                            (if if-does-not-exist :error nil)
129                                            :element-type '(unsigned-byte 8))))))
130                       (if if-does-not-exist
131                           (error 'simple-file-error
132                                  :pathname pathspec
133                                  :format-control
134                                  "~@<Couldn't load ~S: file does not exist.~@:>"
135                                  :format-arguments (list pathspec)))))
136         (unless stream
137           (return-from load nil))
138
139         (let* ((header-line (make-array
140                              (length *fasl-header-string-start-string*)
141                              :element-type '(unsigned-byte 8))))
142           (read-sequence header-line stream)
143           (if (mismatch header-line *fasl-header-string-start-string*
144                         :test #'(lambda (code char) (= code (char-code char))))
145               (let ((truename (probe-file stream)))
146                 (when (and truename
147                            (string= (pathname-type truename) *fasl-file-type*))
148                   (error 'fasl-header-missing
149                          :stream (namestring truename)
150                          :fhsss header-line
151                          :expected *fasl-header-string-start-string*)))
152               (progn
153                 (file-position stream :start)
154                 (return-from load
155                   (load-stream stream))))))
156       (with-open-file (stream pathname :external-format external-format)
157         (load-stream stream)))))
158
159 ;; This implements the defaulting SBCL seems to have inherited from
160 ;; CMU.  This routine does not try to perform any loading; all it does
161 ;; is return the pathname (not the truename) of a file to be loaded,
162 ;; or NIL if no such file can be found.  This routine is supposed to
163 ;; signal an error if a fasl's timestamp is older than its source
164 ;; file, but we protect against errors in PROBE-FILE, because any of
165 ;; the ways that we might fail to find a defaulted file are reasons
166 ;; not to load it, but not worth exposing to the user who didn't
167 ;; expicitly ask us to load a file with a made-up name (e.g., the
168 ;; defaulted filename might exceed filename length limits).
169 (defun probe-load-defaults (pathname)
170   (destructuring-bind (defaulted-source-pathname
171                        defaulted-source-truename
172                        defaulted-fasl-pathname
173                        defaulted-fasl-truename)
174       (loop for type in (list *load-source-default-type*
175                               *fasl-file-type*)
176             as probe-pathname = (make-pathname :type type
177                                                :defaults pathname)
178             collect probe-pathname
179             collect (handler-case (probe-file probe-pathname)
180                       (file-error () nil)))
181     (cond ((and defaulted-fasl-truename
182                 defaulted-source-truename
183                 (> (file-write-date defaulted-source-truename)
184                    (file-write-date defaulted-fasl-truename)))
185            (restart-case
186                (error "The object file ~A is~@
187                        older than the presumed source:~%  ~A."
188                       defaulted-fasl-truename
189                       defaulted-source-truename)
190              (source () :report "load source file"
191                      defaulted-source-pathname)
192              (object () :report "load object file"
193                      defaulted-fasl-pathname)))
194           (defaulted-fasl-truename defaulted-fasl-pathname)
195           (defaulted-source-truename defaulted-source-pathname))))
196 \f
197 ;;; Load a code object. BOX-NUM objects are popped off the stack for
198 ;;; the boxed storage section, then SIZE bytes of code are read in.
199 #!-x86
200 (defun load-code (box-num code-length)
201   (declare (fixnum box-num code-length))
202   (with-fop-stack t
203     (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
204           (index (+ sb!vm:code-trace-table-offset-slot box-num)))
205       (declare (type index index))
206       (setf (%code-debug-info code) (pop-stack))
207       (dotimes (i box-num)
208         (declare (fixnum i))
209         (setf (code-header-ref code (decf index)) (pop-stack)))
210       (sb!sys:without-gcing
211         (read-n-bytes *fasl-input-stream*
212                       (code-instructions code)
213                       0
214                       code-length))
215       code)))
216
217 ;;; Moving native code during a GC or purify is not so trivial on the
218 ;;; x86 port.
219 ;;;
220 ;;; Our strategy for allowing the loading of x86 native code into the
221 ;;; dynamic heap requires that the addresses of fixups be saved for
222 ;;; all these code objects. After a purify these fixups can be
223 ;;; dropped. In CMU CL, this policy was enabled with
224 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
225 #!+x86
226 (defun load-code (box-num code-length)
227   (declare (fixnum box-num code-length))
228   (with-fop-stack t
229     (let ((stuff (list (pop-stack))))
230       (dotimes (i box-num)
231         (declare (fixnum i))
232         (push (pop-stack) stuff))
233       (let* ((dbi (car (last stuff)))   ; debug-info
234              (tto (first stuff)))       ; trace-table-offset
235
236         (setq stuff (nreverse stuff))
237
238         ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
239         (when *load-code-verbose*
240               (format t "stuff: ~S~%" stuff)
241               (format t
242                       "   : ~S ~S ~S ~S~%"
243                       (sb!c::compiled-debug-info-p dbi)
244                       (sb!c::debug-info-p dbi)
245                       (sb!c::compiled-debug-info-name dbi)
246                       tto)
247               (format t "   loading to the dynamic space~%"))
248
249         (let ((code (%primitive sb!c:allocate-code-object
250                                 box-num
251                                 code-length))
252               (index (+ sb!vm:code-trace-table-offset-slot box-num)))
253           (declare (type index index))
254           (when *load-code-verbose*
255             (format t
256                     "  obj addr=~X~%"
257                     (sb!kernel::get-lisp-obj-address code)))
258           (setf (%code-debug-info code) (pop stuff))
259           (dotimes (i box-num)
260             (declare (fixnum i))
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)
265                          0
266                          code-length))
267           code)))))
268 \f
269 ;;;; linkage fixups
270
271 ;;; how we learn about assembler routines at startup
272 (defvar *!initial-assembler-routines*)
273
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))))