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.  (Note that load-as-fasl is in another 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 ;; Pretty well any way of doing LOAD will expose race conditions: for
  56 ;; example, a file might get deleted or renamed after we open it but
  57 ;; before we find its truename.  It seems useful to say that
  58 ;; detectible ways the file system can fail to be static are good
  59 ;; enough reason to stop loading, but to stop in a way that
  60 ;; distinguishes errors that occur mid-way through LOAD from the
  61 ;; initial failure to OPEN the file, so that handlers can try do
  62 ;; defaulting only when the file didn't exist at the start of LOAD,
  63 ;; while allowing race conditions to get through.
  64 (define-condition load-race-condition (error)
  65   ((pathname :reader load-race-condition-pathname :initarg :pathname))
  66   (:report (lambda (condition stream)
  67              (format stream "~@<File ~S was deleted or renamed during LOAD.~:>"
  68                      (load-race-condition-pathname condition)))))
  69
  70 (defmacro resignal-race-condition (&body body)
  71   `(handler-case (progn ,@body)
  72      (file-error (error)
  73        (error 'load-race-condition :pathname (file-error-pathname error)))))
  74
  75 ;;; The following comment preceded the pre 1.0.12.36 definition of
  76 ;;; LOAD; it may no longer be accurate:
  77
  78 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
  79 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
  80 ;; that CMU CL does not correctly record source file information when
  81 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
  82 ;; and fix it if so.
  83
  84 ;;; This is our real LOAD.  The LOAD below is just a wrapper that does
  85 ;;; some defaulting in case the user asks us to load a file that
  86 ;;; doesn't exist at the time we start.
  87 (defun %load (pathspec &key (verbose *load-verbose*) (print *load-print*)
  88               (if-does-not-exist t) (external-format :default))
  89   (when (streamp pathspec)
  90     (let* ( ;; Bindings required by ANSI.
  91            (*readtable* *readtable*)
  92            (*package* (sane-package))
  93            ;; FIXME: we should probably document the circumstances
  94            ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
  95            ;; pathnames during LOAD.  ANSI makes no exceptions here.
  96            (*load-pathname* (handler-case (pathname pathspec)
  97                               ;; FIXME: it should probably be a type
  98                               ;; error to try to get a pathname for a
  99                               ;; stream that doesn't have one, but I
 100                               ;; don't know if we guarantee that.
 101                               (error () nil)))
 102            (*load-truename* (when *load-pathname*
 103                               (handler-case (truename *load-pathname*)
 104                                 (file-error () nil))))
 105            ;; Bindings used internally.
 106            (*load-depth* (1+ *load-depth*))
 107            ;; KLUDGE: I can't find in the ANSI spec where it says
 108            ;; that DECLAIM/PROCLAIM of optimization policy should
 109            ;; have file scope. CMU CL did this, and it seems
 110            ;; reasonable, but it might not be right; after all,
 111            ;; things like (PROCLAIM '(TYPE ..)) don't have file
 112            ;; scope, and I can't find anything under PROCLAIM or
 113            ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
 114            ;; behavior. Hmm. -- WHN 2001-04-06
 115            (sb!c::*policy* sb!c::*policy*))
 116       (return-from %load
 117         (if (equal (stream-element-type pathspec) '(unsigned-byte 8))
 118             (load-as-fasl pathspec verbose print)
 119             (load-as-source pathspec verbose print)))))
 120   ;; If we're here, PATHSPEC isn't a stream, so must be some other
 121   ;; kind of pathname designator.
 122   (with-open-file (stream pathspec
 123                           :element-type '(unsigned-byte 8)
 124                           :if-does-not-exist
 125                           (if if-does-not-exist :error nil))
 126     (unless stream
 127       (return-from %load nil))
 128     (let* ((header-line (make-array
 129                          (length *fasl-header-string-start-string*)
 130                          :element-type '(unsigned-byte 8))))
 131       (read-sequence header-line stream)
 132       (if (mismatch header-line *fasl-header-string-start-string*
 133                     :test #'(lambda (code char) (= code (char-code char))))
 134           (let ((truename (resignal-race-condition (probe-file stream))))
 135             (when (and truename
 136                        (string= (pathname-type truename) *fasl-file-type*))
 137               (error 'fasl-header-missing
 138                      :stream (namestring truename)
 139                      :fhsss header-line
 140                      :expected *fasl-header-string-start-string*)))
 141           (progn
 142             (file-position stream :start)
 143             (return-from %load
 144               (%load stream :verbose verbose :print print))))))
 145   ;; Because we're just opening for input, we don't need
 146   ;; WITH-OPEN-FILE's abort handling semantics, and we want to say
 147   ;; it's an error for PATHSPEC to have existed before but not now, so
 148   ;; WITH-OPEN-STREAM it is.
 149   (with-open-stream (stream (resignal-race-condition
 150                               (open pathspec
 151                                     :external-format external-format)))
 152     (%load stream :verbose verbose :print print)))
 153
 154 ;; Given a simple %LOAD like the above, one can implement any
 155 ;; particular defaulting strategy with a wrapper like this one:
 156 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
 157             (if-does-not-exist :error) (external-format :default))
 158   #!+sb-doc
 159   "Load the file given by FILESPEC into the Lisp environment, returning
 160    T on success."
 161   (handler-bind ((file-error
 162                   #'(lambda (error)
 163                       ;; This handler will run if %LOAD failed to OPEN
 164                       ;; the file to look for a fasl header.
 165                       (let ((pathname (file-error-pathname error)))
 166                         ;; As PROBE-FILE returned NIL, the file
 167                         ;; doesn't exist.  If the filename we tried to
 168                         ;; open lacked a type, try loading a filename
 169                         ;; determined by our defaulting.
 170                         (when (null (handler-case (probe-file pathname)
 171                                       (file-error (error) error)))
 172                           (when (null (pathname-type pathname))
 173                             (let ((default (probe-load-defaults pathname)))
 174                               (when default
 175                                 (return-from load
 176                                   (resignal-race-condition
 177                                     (%load default
 178                                            :verbose verbose
 179                                            :print print
 180                                            :external-format
 181                                            external-format
 182                                            :if-does-not-exist
 183                                            if-does-not-exist))))))))
 184                       ;; If we're here, one of three things happened:
 185                       ;; (1) %LOAD errored and PROBE-FILE succeeded,
 186                       ;; in which case the file must be a bad symlink,
 187                       ;; unreadable, or it was created between %LOAD
 188                       ;; and PROBE-FILE; (2) %LOAD errored and
 189                       ;; PROBE-FILE errored, and so things are amiss
 190                       ;; in the file system (albeit possibly
 191                       ;; differently now than when OPEN errored); (3)
 192                       ;; our defaulting did not find a file.  In any
 193                       ;; of these cases, decline to handle the
 194                       ;; original error or return NIL, depending on
 195                       ;; IF-DOES-NOT-EXIST.
 196                       (if if-does-not-exist
 197                           nil
 198                           (return-from load nil)))))
 199     (%load pathspec :verbose verbose :print print
 200            :external-format external-format)))
 201
 202 ;; This implements the defaulting SBCL seems to have inherited from
 203 ;; CMU.  This routine does not try to perform any loading; all it does
 204 ;; is return the pathname (not the truename) of a file to be loaded,
 205 ;; or NIL if no such file can be found.  This routine is supposed to
 206 ;; signal an error if a fasl's timestamp is older than its source
 207 ;; file, but we protect against errors in PROBE-FILE, because any of
 208 ;; the ways that we might fail to find a defaulted file are reasons
 209 ;; not to load it, but not worth exposing to the user who didn't
 210 ;; expicitly ask us to load a file with a made-up name (e.g., the
 211 ;; defaulted filename might exceed filename length limits).
 212 (defun probe-load-defaults (pathname)
 213   (destructuring-bind (defaulted-source-pathname
 214                        defaulted-source-truename
 215                        defaulted-fasl-pathname
 216                        defaulted-fasl-truename)
 217       (loop for type in (list *load-source-default-type*
 218                               *fasl-file-type*)
 219             as probe-pathname = (make-pathname :type type
 220                                                :defaults pathname)
 221             collect probe-pathname
 222             collect (handler-case (probe-file probe-pathname)
 223                       (file-error () nil)))
 224     (cond ((and defaulted-fasl-truename
 225                 defaulted-source-truename
 226                 (> (resignal-race-condition
 227                      (file-write-date defaulted-source-truename))
 228                    (resignal-race-condition
 229                      (file-write-date defaulted-fasl-truename))))
 230            (restart-case
 231                (error "The object file ~A is~@
 232                        older than the presumed source:~%  ~A."
 233                       defaulted-fasl-truename
 234                       defaulted-source-truename)
 235              (source () :report "load source file"
 236                      defaulted-source-pathname)
 237              (object () :report "load object file"
 238                      defaulted-fasl-pathname)))
 239           (defaulted-fasl-truename defaulted-fasl-pathname)
 240           (defaulted-source-truename defaulted-source-pathname))))
 241 \f
 242 ;;; Load a code object. BOX-NUM objects are popped off the stack for
 243 ;;; the boxed storage section, then SIZE bytes of code are read in.
 244 #!-x86
 245 (defun load-code (box-num code-length)
 246   (declare (fixnum box-num code-length))
 247   (with-fop-stack t
 248     (let ((code (%primitive 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       (setf (%code-debug-info code) (pop-stack))
 252       (dotimes (i box-num)
 253         (declare (fixnum i))
 254         (setf (code-header-ref code (decf index)) (pop-stack)))
 255       (sb!sys:without-gcing
 256         (read-n-bytes *fasl-input-stream*
 257                       (code-instructions code)
 258                       0
 259                       code-length))
 260       code)))
 261
 262 ;;; Moving native code during a GC or purify is not so trivial on the
 263 ;;; x86 port.
 264 ;;;
 265 ;;; Our strategy for allowing the loading of x86 native code into the
 266 ;;; dynamic heap requires that the addresses of fixups be saved for
 267 ;;; all these code objects. After a purify these fixups can be
 268 ;;; dropped. In CMU CL, this policy was enabled with
 269 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
 270 #!+x86
 271 (defun load-code (box-num code-length)
 272   (declare (fixnum box-num code-length))
 273   (with-fop-stack t
 274     (let ((stuff (list (pop-stack))))
 275       (dotimes (i box-num)
 276         (declare (fixnum i))
 277         (push (pop-stack) stuff))
 278       (let* ((dbi (car (last stuff)))   ; debug-info
 279              (tto (first stuff)))       ; trace-table-offset
 280
 281         (setq stuff (nreverse stuff))
 282
 283         ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
 284         (when *load-code-verbose*
 285               (format t "stuff: ~S~%" stuff)
 286               (format t
 287                       "   : ~S ~S ~S ~S~%"
 288                       (sb!c::compiled-debug-info-p dbi)
 289                       (sb!c::debug-info-p dbi)
 290                       (sb!c::compiled-debug-info-name dbi)
 291                       tto)
 292               (format t "   loading to the dynamic space~%"))
 293
 294         (let ((code (%primitive sb!c:allocate-code-object
 295                                 box-num
 296                                 code-length))
 297               (index (+ sb!vm:code-trace-table-offset-slot box-num)))
 298           (declare (type index index))
 299           (when *load-code-verbose*
 300             (format t
 301                     "  obj addr=~X~%"
 302                     (sb!kernel::get-lisp-obj-address code)))
 303           (setf (%code-debug-info code) (pop stuff))
 304           (dotimes (i box-num)
 305             (declare (fixnum i))
 306             (setf (code-header-ref code (decf index)) (pop stuff)))
 307           (sb!sys:without-gcing
 308            (read-n-bytes *fasl-input-stream*
 309                          (code-instructions code)
 310                          0
 311                          code-length))
 312           code)))))
 313 \f
 314 ;;;; linkage fixups
 315
 316 ;;; how we learn about assembler routines at startup
 317 (defvar *!initial-assembler-routines*)
 318
 319 (defun !loader-cold-init ()
 320   (/show0 "/!loader-cold-init")
 321   (dolist (routine *!initial-assembler-routines*)
 322     (setf (gethash (car routine) *assembler-routines*) (cdr routine))))