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