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