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