;;;; that part of the loader is only needed on the target system ;;;; (which is basically synonymous with "that part of the loader ;;;; which is not needed by GENESIS") ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!FASL") (defvar *load-source-default-type* "lisp" #!+sb-doc "The source file types which LOAD looks for by default.") (declaim (type (or pathname null) *load-truename* *load-pathname*)) (defvar *load-truename* nil #!+sb-doc "the TRUENAME of the file that LOAD is currently loading") (defvar *load-pathname* nil #!+sb-doc "the defaulted pathname that LOAD is currently loading") ;;;; LOAD-AS-SOURCE ;;; Load a text file. (defun load-as-source (stream verbose print) (maybe-announce-load stream verbose) (do ((sexpr (read stream nil *eof-object*) (read stream nil *eof-object*))) ((eq sexpr *eof-object*) t) (if print (let ((results (multiple-value-list (eval sexpr)))) (load-fresh-line) (format t "~{~S~^, ~}~%" results)) (eval sexpr)))) ;;;; LOAD itself (define-condition fasl-header-missing (invalid-fasl) ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss)) (:report (lambda (condition stream) (format stream "~@" (invalid-fasl-stream condition) (invalid-fasl-expected condition) (invalid-fasl-fhsss condition))))) ;;; a helper function for LOAD: Load the stuff in a file when we have ;;; the name. ;;; ;;; FIXME: with the addition of the EXTERNAL-FORMAT argument, this ;;; interface has become truly sucky. (defun internal-load (pathname truename if-does-not-exist verbose print &optional contents external-format) (declare (type (member nil :error) if-does-not-exist)) (unless truename (if if-does-not-exist (error 'simple-file-error :pathname pathname :format-control "~S does not exist." :format-arguments (list (namestring pathname))) (return-from internal-load nil))) (let ((*load-truename* truename) (*load-pathname* (merge-pathnames pathname))) (case contents (:source (with-open-file (stream truename :direction :input :if-does-not-exist if-does-not-exist :external-format external-format) (load-as-source stream verbose print))) (:binary (with-open-file (stream truename :direction :input :if-does-not-exist if-does-not-exist :element-type '(unsigned-byte 8)) (load-as-fasl stream verbose print))) (t (let* ((fhsss *fasl-header-string-start-string*) (first-line (make-array (length fhsss) :element-type '(unsigned-byte 8))) (read-length (with-open-file (stream truename :direction :input :element-type '(unsigned-byte 8)) (read-sequence first-line stream)))) (cond ((and (= read-length (length fhsss)) (do ((i 0 (1+ i))) ((= i read-length) t) (when (/= (char-code (aref fhsss i)) (aref first-line i)) (return)))) (internal-load pathname truename if-does-not-exist verbose print :binary)) (t (when (string= (pathname-type truename) *fasl-file-type*) (error 'fasl-header-missing :stream (namestring truename) :fhsss first-line :expected fhsss)) (internal-load pathname truename if-does-not-exist verbose print :source external-format)))))))) ;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default ;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match, ;;; or (VALUES PATHNAME NIL) if the file doesn't exist. ;;; ;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a ;;; single type. By avoiding CMU CL's generality here, we avoid having ;;; to worry about some annoying ambiguities. (E.g. what if the ;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and ;;; "foo.cl" exist?) (defun try-default-type (pathname type) (let ((pn (translate-logical-pathname (make-pathname :type type :defaults pathname)))) (values pn (probe-file pn)))) ;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where ;;; the file does not exist. (defun internal-load-default-type (pathname if-does-not-exist verbose print external-format) (declare (type (member nil :error) if-does-not-exist)) (multiple-value-bind (src-pn src-tn) (try-default-type pathname *load-source-default-type*) (multiple-value-bind (obj-pn obj-tn) (try-default-type pathname *fasl-file-type*) (cond ((and obj-tn src-tn (> (file-write-date src-tn) (file-write-date obj-tn))) (restart-case (error "The object file ~A is~@ older than the presumed source:~% ~A." (namestring obj-tn) (namestring src-tn)) (source () :report "load source file" (internal-load src-pn src-tn if-does-not-exist verbose print :source external-format)) (object () :report "load object file" (internal-load src-pn obj-tn if-does-not-exist verbose print :binary)))) (obj-tn (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary)) (src-pn (internal-load src-pn src-tn if-does-not-exist verbose print :source external-format)) (t (internal-load pathname nil if-does-not-exist verbose print nil external-format)))))) ;;; This function mainly sets up special bindings and then calls ;;; sub-functions. We conditionally bind the switches with PROGV so ;;; that people can set them in their init files and have the values ;;; take effect. If the compiler is loaded, we make the ;;; compiler-policy local to LOAD by binding it to itself. ;;; ;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an ;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU ;;; CL does not correctly record source file information when LOADing a ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so. (defun load (filespec &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist t) (external-format :default)) #!+sb-doc "Load the file given by FILESPEC into the Lisp environment, returning T on success." (let ((*load-depth* (1+ *load-depth*)) ;; KLUDGE: I can't find in the ANSI spec where it says that ;; DECLAIM/PROCLAIM of optimization policy should have file ;; scope. CMU CL did this, and it seems reasonable, but it ;; might not be right; after all, things like (PROCLAIM '(TYPE ;; ..)) don't have file scope, and I can't find anything under ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which ;; justifies this behavior. Hmm. -- WHN 2001-04-06 (sb!c::*policy* sb!c::*policy*) ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and ;; *PACKAGE* to the values they held before loading the file." (*package* (sane-package)) (*readtable* *readtable*) ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to ;; accept a generalized boolean argument value for this ;; externally-visible function, but the internal functions ;; still use the old convention. (internal-if-does-not-exist (if if-does-not-exist :error nil))) ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL ;; gets function return type checking right, we can achieve a ;; similar effect better by adding FTYPE declarations. (values (if (streamp filespec) (if (or (equal (stream-element-type filespec) '(unsigned-byte 8))) (load-as-fasl filespec verbose print) (load-as-source filespec verbose print)) (let* ((pathname (pathname filespec)) (physical-pathname (translate-logical-pathname pathname)) (probed-file (probe-file physical-pathname))) (if (or probed-file (pathname-type physical-pathname)) (internal-load physical-pathname probed-file internal-if-does-not-exist verbose print nil external-format) (internal-load-default-type pathname internal-if-does-not-exist verbose print external-format))))))) ;;; Load a code object. BOX-NUM objects are popped off the stack for ;;; the boxed storage section, then SIZE bytes of code are read in. #!-x86 (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) (with-fop-stack t (let ((code (%primitive sb!c:allocate-code-object box-num code-length)) (index (+ sb!vm:code-trace-table-offset-slot box-num))) (declare (type index index)) (setf (%code-debug-info code) (pop-stack)) (dotimes (i box-num) (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop-stack))) (sb!sys:without-gcing (read-n-bytes *fasl-input-stream* (code-instructions code) 0 code-length)) code))) ;;; Moving native code during a GC or purify is not so trivial on the ;;; x86 port. ;;; ;;; Our strategy for allowing the loading of x86 native code into the ;;; dynamic heap requires that the addresses of fixups be saved for ;;; all these code objects. After a purify these fixups can be ;;; dropped. In CMU CL, this policy was enabled with ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used. #!+x86 (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) (with-fop-stack t (let ((stuff (list (pop-stack)))) (dotimes (i box-num) (declare (fixnum i)) (push (pop-stack) stuff)) (let* ((dbi (car (last stuff))) ; debug-info (tto (first stuff))) ; trace-table-offset (setq stuff (nreverse stuff)) ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW. (when *load-code-verbose* (format t "stuff: ~S~%" stuff) (format t " : ~S ~S ~S ~S~%" (sb!c::compiled-debug-info-p dbi) (sb!c::debug-info-p dbi) (sb!c::compiled-debug-info-name dbi) tto) (format t " loading to the dynamic space~%")) (let ((code (%primitive sb!c:allocate-code-object box-num code-length)) (index (+ sb!vm:code-trace-table-offset-slot box-num))) (declare (type index index)) (when *load-code-verbose* (format t " obj addr=~X~%" (sb!kernel::get-lisp-obj-address code))) (setf (%code-debug-info code) (pop stuff)) (dotimes (i box-num) (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop stuff))) (sb!sys:without-gcing (read-n-bytes *fasl-input-stream* (code-instructions code) 0 code-length)) code))))) ;;;; linkage fixups ;;; how we learn about assembler routines at startup (defvar *!initial-assembler-routines*) (defun !loader-cold-init () (/show0 "/!loader-cold-init") (dolist (routine *!initial-assembler-routines*) (setf (gethash (car routine) *assembler-routines*) (cdr routine))))