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