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.
  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 ;;; a helper function for LOAD: Load the stuff in a file when we have
  56 ;;; the name.
  57 ;;;
  58 ;;; FIXME: with the addition of the EXTERNAL-FORMAT argument, this
  59 ;;; interface has become truly sucky.
  60 (defun internal-load (pathname truename if-does-not-exist verbose print
  61                       &optional contents external-format)
  62   (declare (type (member nil :error) if-does-not-exist))
  63   (unless truename
  64     (if if-does-not-exist
  65         (error 'simple-file-error
  66                :pathname pathname
  67                :format-control "~S does not exist."
  68                :format-arguments (list (namestring pathname)))
  69         (return-from internal-load nil)))
  70
  71   (let ((*load-truename* truename)
  72         (*load-pathname* (merge-pathnames pathname)))
  73     (case contents
  74       (:source
  75        (with-open-file (stream truename
  76                                :direction :input
  77                                :if-does-not-exist if-does-not-exist
  78                                :external-format external-format)
  79          (load-as-source stream verbose print)))
  80       (:binary
  81        (with-open-file (stream truename
  82                                :direction :input
  83                                :if-does-not-exist if-does-not-exist
  84                                :element-type '(unsigned-byte 8))
  85          (load-as-fasl stream verbose print)))
  86       (t
  87        (let* ((fhsss *fasl-header-string-start-string*)
  88               (first-line (make-array (length fhsss)
  89                                       :element-type '(unsigned-byte 8)))
  90               (read-length
  91                (with-open-file (stream truename
  92                                        :direction :input
  93                                        :element-type '(unsigned-byte 8))
  94                  (read-sequence first-line stream))))
  95          (cond
  96            ((and (= read-length (length fhsss))
  97                  (do ((i 0 (1+ i)))
  98                      ((= i read-length) t)
  99                    (when (/= (char-code (aref fhsss i)) (aref first-line i))
 100                      (return))))
 101             (internal-load pathname truename if-does-not-exist verbose print
 102                            :binary))
 103            (t
 104             (when (string= (pathname-type truename) *fasl-file-type*)
 105               (error 'fasl-header-missing
 106                      :stream (namestring truename)
 107                      :fhsss first-line
 108                      :expected fhsss))
 109             (internal-load pathname truename if-does-not-exist verbose print
 110                            :source external-format))))))))
 111
 112 ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
 113 ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
 114 ;;; or (VALUES PATHNAME NIL) if the file doesn't exist.
 115 ;;;
 116 ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a
 117 ;;; single type. By avoiding CMU CL's generality here, we avoid having
 118 ;;; to worry about some annoying ambiguities. (E.g. what if the
 119 ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and
 120 ;;; "foo.cl" exist?)
 121 (defun try-default-type (pathname type)
 122   (let ((pn (translate-logical-pathname (make-pathname :type type :defaults pathname))))
 123     (values pn (probe-file pn))))
 124
 125 ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
 126 ;;; the file does not exist.
 127 (defun internal-load-default-type
 128     (pathname if-does-not-exist verbose print external-format)
 129   (declare (type (member nil :error) if-does-not-exist))
 130   (multiple-value-bind (src-pn src-tn)
 131       (try-default-type pathname *load-source-default-type*)
 132     (multiple-value-bind (obj-pn obj-tn)
 133         (try-default-type pathname *fasl-file-type*)
 134       (cond
 135        ((and obj-tn
 136              src-tn
 137              (> (file-write-date src-tn) (file-write-date obj-tn)))
 138         (restart-case
 139          (error "The object file ~A is~@
 140                  older than the presumed source:~%  ~A."
 141                 (namestring obj-tn)
 142                 (namestring src-tn))
 143          (source () :report "load source file"
 144            (internal-load src-pn src-tn if-does-not-exist verbose print
 145                           :source external-format))
 146          (object () :report "load object file"
 147             (internal-load src-pn obj-tn if-does-not-exist verbose print
 148                            :binary))))
 149        (obj-tn
 150         (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
 151        (src-pn
 152         (internal-load src-pn src-tn if-does-not-exist
 153                        verbose print :source external-format))
 154        (t
 155         (internal-load pathname nil if-does-not-exist
 156                        verbose print nil external-format))))))
 157
 158 ;;; This function mainly sets up special bindings and then calls
 159 ;;; sub-functions. We conditionally bind the switches with PROGV so
 160 ;;; that people can set them in their init files and have the values
 161 ;;; take effect. If the compiler is loaded, we make the
 162 ;;; compiler-policy local to LOAD by binding it to itself.
 163 ;;;
 164 ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
 165 ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
 166 ;;; CL does not correctly record source file information when LOADing a
 167 ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
 168 (defun load (filespec
 169              &key
 170              (verbose *load-verbose*)
 171              (print *load-print*)
 172              (if-does-not-exist t)
 173              (external-format :default))
 174   #!+sb-doc
 175   "Load the file given by FILESPEC into the Lisp environment, returning
 176    T on success."
 177   (let ((*load-depth* (1+ *load-depth*))
 178         ;; KLUDGE: I can't find in the ANSI spec where it says that
 179         ;; DECLAIM/PROCLAIM of optimization policy should have file
 180         ;; scope. CMU CL did this, and it seems reasonable, but it
 181         ;; might not be right; after all, things like (PROCLAIM '(TYPE
 182         ;; ..)) don't have file scope, and I can't find anything under
 183         ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which
 184         ;; justifies this behavior. Hmm. -- WHN 2001-04-06
 185         (sb!c::*policy* sb!c::*policy*)
 186         ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and
 187         ;; *PACKAGE* to the values they held before loading the file."
 188         (*package* (sane-package))
 189         (*readtable* *readtable*)
 190         ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST
 191         ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to
 192         ;; accept a generalized boolean argument value for this
 193         ;; externally-visible function, but the internal functions
 194         ;; still use the old convention.
 195         (internal-if-does-not-exist (if if-does-not-exist :error nil)))
 196     ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL
 197     ;; gets function return type checking right, we can achieve a
 198     ;; similar effect better by adding FTYPE declarations.
 199     (values
 200      (if (streamp filespec)
 201          (if (or (equal (stream-element-type filespec)
 202                         '(unsigned-byte 8)))
 203              (load-as-fasl filespec verbose print)
 204              (load-as-source filespec verbose print))
 205          (let* ((pathname (pathname filespec))
 206                 (physical-pathname (translate-logical-pathname pathname))
 207                 (probed-file (probe-file physical-pathname)))
 208            (if (or probed-file
 209                    (pathname-type physical-pathname))
 210                (internal-load
 211                 physical-pathname probed-file internal-if-does-not-exist
 212                 verbose print nil external-format)
 213                (internal-load-default-type
 214                 pathname internal-if-does-not-exist
 215                 verbose print external-format)))))))
 216 \f
 217 ;;; Load a code object. BOX-NUM objects are popped off the stack for
 218 ;;; the boxed storage section, then SIZE bytes of code are read in.
 219 #!-x86
 220 (defun load-code (box-num code-length)
 221   (declare (fixnum box-num code-length))
 222   (with-fop-stack t
 223     (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
 224           (index (+ sb!vm:code-trace-table-offset-slot box-num)))
 225       (declare (type index index))
 226       (setf (%code-debug-info code) (pop-stack))
 227       (dotimes (i box-num)
 228         (declare (fixnum i))
 229         (setf (code-header-ref code (decf index)) (pop-stack)))
 230       (sb!sys:without-gcing
 231         (read-n-bytes *fasl-input-stream*
 232                       (code-instructions code)
 233                       0
 234                       code-length))
 235       code)))
 236
 237 ;;; Moving native code during a GC or purify is not so trivial on the
 238 ;;; x86 port.
 239 ;;;
 240 ;;; Our strategy for allowing the loading of x86 native code into the
 241 ;;; dynamic heap requires that the addresses of fixups be saved for
 242 ;;; all these code objects. After a purify these fixups can be
 243 ;;; dropped. In CMU CL, this policy was enabled with
 244 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
 245 #!+x86
 246 (defun load-code (box-num code-length)
 247   (declare (fixnum box-num code-length))
 248   (with-fop-stack t
 249     (let ((stuff (list (pop-stack))))
 250       (dotimes (i box-num)
 251         (declare (fixnum i))
 252         (push (pop-stack) stuff))
 253       (let* ((dbi (car (last stuff)))   ; debug-info
 254              (tto (first stuff)))       ; trace-table-offset
 255
 256         (setq stuff (nreverse stuff))
 257
 258         ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
 259         (when *load-code-verbose*
 260               (format t "stuff: ~S~%" stuff)
 261               (format t
 262                       "   : ~S ~S ~S ~S~%"
 263                       (sb!c::compiled-debug-info-p dbi)
 264                       (sb!c::debug-info-p dbi)
 265                       (sb!c::compiled-debug-info-name dbi)
 266                       tto)
 267               (format t "   loading to the dynamic space~%"))
 268
 269         (let ((code (%primitive sb!c:allocate-code-object
 270                                 box-num
 271                                 code-length))
 272               (index (+ sb!vm:code-trace-table-offset-slot box-num)))
 273           (declare (type index index))
 274           (when *load-code-verbose*
 275             (format t
 276                     "  obj addr=~X~%"
 277                     (sb!kernel::get-lisp-obj-address code)))
 278           (setf (%code-debug-info code) (pop stuff))
 279           (dotimes (i box-num)
 280             (declare (fixnum i))
 281             (setf (code-header-ref code (decf index)) (pop stuff)))
 282           (sb!sys:without-gcing
 283            (read-n-bytes *fasl-input-stream*
 284                          (code-instructions code)
 285                          0
 286                          code-length))
 287           code)))))
 288 \f
 289 ;;;; linkage fixups
 290
 291 ;;; how we learn about assembler routines at startup
 292 (defvar *!initial-assembler-routines*)
 293
 294 (defun !loader-cold-init ()
 295   (/show0 "/!loader-cold-init")
 296   (dolist (routine *!initial-assembler-routines*)
 297     (setf (gethash (car routine) *assembler-routines*) (cdr routine))))