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