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   "The source file types which LOAD looks for by default.")
  18
  19 (declaim (type (or pathname null) *load-truename* *load-pathname*))
  20 (defvar *load-truename* nil
  21   "the TRUENAME of the file that LOAD is currently loading")
  22 (defvar *load-pathname* nil
  23   "the defaulted pathname that LOAD is currently loading")
  24 \f
  25 ;;;; LOAD-AS-SOURCE
  26
  27 ;;; Load a text stream.  (Note that load-as-fasl is in another file.)
  28 ;; We'd like, when entering the debugger as a result of an EVAL error,
  29 ;; that the condition be annotated with the stream position.
  30 ;; One way to do it is catch all conditions and encapsulate them in
  31 ;; something new such as a LOADER-EVAL-ERROR and re-signal.
  32 ;; The printer for the encapsulated condition has the data it needs to
  33 ;; show the original condition and the line/col. That would unfortunately
  34 ;; interfere with handlers that were bound around LOAD, since they would
  35 ;; only receive the encapsulated condition, and not be able to test for
  36 ;; things they're interested in, such as which redefinition warnings to ignore.
  37 ;; Instead, printing a herald for any SERIOUS-CONDITION approximates
  38 ;; the desired behavior closely enough without printing something for warnings.
  39 ;; TODO: It would be supremely cool if, for toplevel PROGN, we could
  40 ;; indicate the position of the specific subform that failed
  41 (defun load-as-source (stream &key verbose print (context "loading"))
  42   (maybe-announce-load stream verbose)
  43   (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
  44          (native (when pathname (native-namestring pathname))))
  45     (with-simple-restart (abort "Abort ~A file ~S." context native)
  46      (labels ((condition-herald (c)
  47                 (declare (ignore c)) ; propagates up
  48                 (when (form-tracking-stream-p stream)
  49                   (let* ((startpos
  50                           (form-tracking-stream-form-start-char-pos stream))
  51                          (point (line/col-from-charpos stream startpos)))
  52                     (format *error-output* "~&While evaluating the form ~
  53  starting at line ~D, column ~D~%  of ~S:"
  54                             (car point) (cdr point)
  55                             (or pathname stream)))))
  56               (eval-form (form index)
  57                (with-simple-restart (continue "Ignore error and continue ~A file ~S."
  58                                               context native)
  59                  (loop
  60                   (handler-bind ((serious-condition #'condition-herald))
  61                    (with-simple-restart (retry "Retry EVAL of current toplevel form.")
  62                      (if print
  63                          (let ((results (multiple-value-list (eval-tlf form index))))
  64                            (load-fresh-line)
  65                            (format t "~{~S~^, ~}~%" results))
  66                          (eval-tlf form index)))
  67                    (return))))))
  68         (if pathname
  69             (let* ((info (sb!c::make-file-source-info
  70                           pathname (stream-external-format stream)))
  71                    (sb!c::*source-info* info))
  72               (setf (sb!c::source-info-stream info) stream)
  73               (sb!c::do-forms-from-info ((form current-index) info
  74                                          'sb!c::input-error-in-load)
  75                 (sb!c::with-source-paths
  76                   (sb!c::find-source-paths form current-index)
  77                   (eval-form form current-index))))
  78             (let ((sb!c::*source-info* nil))
  79               (do ((form (read stream nil *eof-object*)
  80                          (read stream nil *eof-object*)))
  81                   ((eq form *eof-object*))
  82                 (sb!c::with-source-paths
  83                   (eval-form form nil))))))))
  84   t)
  85 \f
  86 ;;;; LOAD itself
  87
  88 (define-condition fasl-header-missing (invalid-fasl)
  89   ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
  90   (:report
  91    (lambda (condition stream)
  92      (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
  93                      Expected ~S, but got ~S.~:@>"
  94              (invalid-fasl-stream condition)
  95              (invalid-fasl-expected condition)
  96              (invalid-fasl-fhsss condition)))))
  97
  98
  99 ;;; The following comment preceded the pre 1.0.12.36 definition of
 100 ;;; LOAD; it may no longer be accurate:
 101
 102 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
 103 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
 104 ;; that CMU CL does not correctly record source file information when
 105 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
 106 ;; and fix it if so.
 107
 108 (defun call-with-load-bindings (function stream)
 109            (let* (;; Bindings required by ANSI.
 110                   (*readtable* *readtable*)
 111                   (*package* (sane-package))
 112                   ;; FIXME: we should probably document the circumstances
 113                   ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
 114                   ;; pathnames during LOAD.  ANSI makes no exceptions here.
 115                   (*load-pathname* (handler-case (pathname stream)
 116                                      ;; FIXME: it should probably be a type
 117                                      ;; error to try to get a pathname for a
 118                                      ;; stream that doesn't have one, but I
 119                                      ;; don't know if we guarantee that.
 120                                      (error () nil)))
 121                   (*load-truename* (when *load-pathname*
 122                                      (handler-case (truename stream)
 123                                        (file-error () nil))))
 124                   ;; Bindings used internally.
 125                   (*load-depth* (1+ *load-depth*))
 126                   )
 127              (funcall function)))
 128
 129 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
 130              (if-does-not-exist t) (external-format :default))
 131   "Load the file given by FILESPEC into the Lisp environment, returning
 132    T on success."
 133   (flet ((load-stream (stream faslp)
 134            (when (and (fd-stream-p stream)
 135                       (eq (sb!impl::fd-stream-fd-type stream) :directory))
 136              (error 'simple-file-error
 137                     :pathname (pathname stream)
 138                     :format-control
 139                     "Can't LOAD a directory: ~s."
 140                     :format-arguments (list (pathname stream))))
 141            (dx-flet ((thunk ()
 142                        (let (
 143                   ;; KLUDGE: I can't find in the ANSI spec where it says
 144                   ;; that DECLAIM/PROCLAIM of optimization policy should
 145                   ;; have file scope. CMU CL did this, and it seems
 146                   ;; reasonable, but it might not be right; after all,
 147                   ;; things like (PROCLAIM '(TYPE ..)) don't have file
 148                   ;; scope, and I can't find anything under PROCLAIM or
 149                   ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
 150                   ;; behavior. Hmm. -- WHN 2001-04-06
 151                              (sb!c::*policy* sb!c::*policy*))
 152                          (if faslp
 153                              (load-as-fasl stream verbose print)
 154                              (sb!c:with-compiler-error-resignalling
 155                                  (load-as-source stream :verbose verbose
 156                                                         :print print))))))
 157              (call-with-load-bindings #'thunk stream))))
 158
 159     ;; Case 1: stream.
 160     (when (streamp pathspec)
 161       (return-from load (load-stream pathspec (fasl-header-p pathspec))))
 162
 163     (let ((pathname (pathname pathspec)))
 164       ;; Case 2: Open as binary, try to process as a fasl.
 165       (with-open-stream
 166           (stream (or (open pathspec :element-type '(unsigned-byte 8)
 167                                      :if-does-not-exist nil)
 168                       (when (null (pathname-type pathspec))
 169                         (let ((defaulted-pathname
 170                                 (probe-load-defaults pathspec)))
 171                           (if defaulted-pathname
 172                               (progn (setq pathname defaulted-pathname)
 173                                      (open pathname
 174                                            :if-does-not-exist
 175                                            (if if-does-not-exist :error nil)
 176                                            :element-type '(unsigned-byte 8))))))
 177                       (if if-does-not-exist
 178                           (error 'simple-file-error
 179                                  :pathname pathspec
 180                                  :format-control
 181                                  "~@<Couldn't load ~S: file does not exist.~@:>"
 182                                  :format-arguments (list pathspec))
 183                           (return-from load nil))))
 184         (let* ((real (probe-file stream))
 185                (should-be-fasl-p
 186                 (and real (string-equal (pathname-type real) *fasl-file-type*))))
 187           ;; Don't allow empty .fasls, and assume other empty files
 188           ;; are source files.
 189           (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
 190                      (fasl-header-p stream :errorp should-be-fasl-p))
 191             (return-from load (load-stream stream t)))))
 192
 193       ;; Case 3: Open using the given external format, process as source.
 194       (with-open-file (stream pathname :external-format external-format
 195                               :class 'form-tracking-stream)
 196         (load-stream stream nil)))))
 197
 198 ;; This implements the defaulting SBCL seems to have inherited from
 199 ;; CMU.  This routine does not try to perform any loading; all it does
 200 ;; is return the pathname (not the truename) of a file to be loaded,
 201 ;; or NIL if no such file can be found.  This routine is supposed to
 202 ;; signal an error if a fasl's timestamp is older than its source
 203 ;; file, but we protect against errors in PROBE-FILE, because any of
 204 ;; the ways that we might fail to find a defaulted file are reasons
 205 ;; not to load it, but not worth exposing to the user who didn't
 206 ;; expicitly ask us to load a file with a made-up name (e.g., the
 207 ;; defaulted filename might exceed filename length limits).
 208 (defun probe-load-defaults (pathname)
 209   (destructuring-bind (defaulted-source-pathname
 210                        defaulted-source-truename
 211                        defaulted-fasl-pathname
 212                        defaulted-fasl-truename)
 213       (loop for type in (list *load-source-default-type*
 214                               *fasl-file-type*)
 215             as probe-pathname = (make-pathname :type type
 216                                                :defaults pathname)
 217             collect probe-pathname
 218             collect (handler-case (probe-file probe-pathname)
 219                       (file-error () nil)))
 220     (cond ((and defaulted-fasl-truename
 221                 defaulted-source-truename
 222                 (> (file-write-date defaulted-source-truename)
 223                    (file-write-date defaulted-fasl-truename)))
 224            (restart-case
 225                (error "The object file ~A is~@
 226                        older than the presumed source:~%  ~A."
 227                       defaulted-fasl-truename
 228                       defaulted-source-truename)
 229              (source () :report "load source file"
 230                      defaulted-source-pathname)
 231              (object () :report "load object file"
 232                      defaulted-fasl-pathname)))
 233           (defaulted-fasl-truename defaulted-fasl-pathname)
 234           (defaulted-source-truename defaulted-source-pathname))))
 235 \f
 236 ;;; Load a code object. BOX-NUM objects are popped off the stack for
 237 ;;; the boxed storage section, then CODE-LENGTH bytes of code are read in.
 238 (defun load-code (nfuns box-num code-length stack ptr fasl-input)
 239   (declare (fixnum box-num code-length))
 240   (declare (simple-vector stack) (type index ptr))
 241   (let* ((debug-info-index (+ ptr box-num))
 242          (toplevel-p (svref stack (1+ debug-info-index)))
 243          (code (sb!c:allocate-code-object (not toplevel-p) box-num code-length)))
 244     (declare (ignorable toplevel-p))
 245     (setf (%code-debug-info code) (svref stack debug-info-index))
 246     (loop for i of-type index from sb!vm:code-constants-offset
 247           for j of-type index from ptr below debug-info-index
 248           do (setf (code-header-ref code i) (svref stack j)))
 249     (without-gcing
 250       ;; FIXME: can this be WITH-PINNED-OBJECTS? Probably.
 251       ;; We must pin the range of bytes containing instructions,
 252       ;; but we also must prevent scavenging the code object until
 253       ;; the embedded simple-funs have been installed,
 254       ;; otherwise GC could assert that the word referenced by
 255       ;; a fun offset does not have the right widetag.
 256       ;; This is achieved by not writing the 'nfuns' value
 257       ;; until after the loop which stores the offsets.
 258       (read-n-bytes (%fasl-input-stream fasl-input)
 259                     (code-instructions code) 0 code-length)
 260       (loop for i from (1- nfuns) downto 0
 261             do (sb!c::new-simple-fun code i (read-varint-arg fasl-input)
 262                                      nfuns)))
 263     code))
 264 \f
 265 ;;;; linkage fixups
 266
 267 ;;; how we learn about assembler routines at startup
 268 (defvar *!initial-assembler-routines*)
 269
 270 (defun !loader-cold-init ()
 271   (dovector (routine *!initial-assembler-routines*)
 272     (destructuring-bind (name code offset) routine
 273       (setf (gethash name *assembler-routines*)
 274             (sap-int (sap+ (code-instructions code) offset))))))
 275
 276 (defun !warm-load (file)
 277   (restart-case (load file)
 278     (abort ()
 279       :report "Abort building SBCL."
 280       (sb!ext:exit :code 1))))