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