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