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