X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=72c6be073402489630298c7b6be1904129558efd;hb=0af84c9c90b1277be6863df8f28f1f0e5512323c;hp=4ad3aed0d1587b0d002552716cf1a702c2645be6;hpb=4dc6290ab8ea1ea15cd92791322f34f7f7973be0;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4ad3aed..72c6be0 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -6,13 +6,20 @@ ;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06 ;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less ;;;; fakes up static function linking. I.e. it makes sure that all the -;;;; functions in the fasl files it reads are bound to the +;;;; DEFUN-defined functions in the fasl files it reads are bound to the ;;;; corresponding symbols before execution starts. It doesn't do ;;;; anything to initialize variable values; instead it just arranges ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is ;;;; responsible for explicitly initializing anything which has to be ;;;; initialized early before it transfers control to the ordinary ;;;; top-level forms. +;;;; +;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined +;;;; by DEFUN aren't set up specially by GENESIS. In particular, +;;;; structure slot accessors are not set up. Slot accessors are +;;;; available at cold init time because they're usually compiled +;;;; inline. They're not available as out-of-line functions until the +;;;; toplevel forms installing them have run.) ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -25,9 +32,6 @@ (in-package "SB!IMPL") -(file-comment - "$Header$") - ;;; a magic number used to identify our core files (defconstant core-magic (logior (ash (char-code #\S) 24) @@ -47,7 +51,9 @@ ;;; ;;; 0: inherited from CMU CL ;;; 1: rearranged static symbols for sbcl-0.6.8 -(defconstant sbcl-core-version-integer 1) +;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support, +;;; deleted a slot from DEBUG-SOURCE structure +(defconstant sbcl-core-version-integer 2) (defun round-up (number size) #!+sb-doc @@ -65,16 +71,16 @@ (defvar *read-only*) (defconstant read-only-space-id 3) -(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant descriptor-low-bits 16 - "the number of bits in the low half of the descriptor") - (defconstant target-space-alignment (ash 1 descriptor-low-bits) - "the alignment requirement for spaces in the target. - Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")) +(defconstant descriptor-low-bits 16 + "the number of bits in the low half of the descriptor") +(defconstant target-space-alignment (ash 1 descriptor-low-bits) + "the alignment requirement for spaces in the target. + Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)") ;;; a GENESIS-time representation of a memory space (e.g. read-only space, ;;; dynamic space, or static space) -(defstruct (gspace (:constructor %make-gspace)) +(defstruct (gspace (:constructor %make-gspace) + (:copier nil)) ;; name and identifier for this GSPACE (name (required-argument) :type symbol :read-only t) (identifier (required-argument) :type fixnum :read-only t) @@ -124,7 +130,8 @@ (defstruct (descriptor (:constructor make-descriptor - (high low &optional gspace word-offset))) + (high low &optional gspace word-offset)) + (:copier nil)) ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet. (gspace nil :type (or gspace null)) ;; the offset in words from the start of GSPACE, or NIL if not set yet @@ -337,7 +344,7 @@ ;;; comparing the byte order of *BACKEND* to the byte order of ;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead, ;;; in SBCL byte order swapping would need to be explicitly requested -;;; with a keyword argument to GENESIS. +;;; with a &KEY argument to GENESIS. ;;; ;;; I'm not sure whether this is a problem or not, and I don't have a ;;; machine with different byte order to test to find out for sure. @@ -368,8 +375,8 @@ (defun maybe-byte-swap (word) (declare (type (unsigned-byte 32) word)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) word (logior (ash (ldb (byte 8 0) word) 24) @@ -379,8 +386,8 @@ (defun maybe-byte-swap-short (short) (declare (type (unsigned-byte 16) short)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) short (logior (ash (ldb (byte 8 0) short) 8) @@ -388,8 +395,8 @@ ;;; like SAP-REF-32, except that instead of a SAP we use a byte vector (defun byte-vector-ref-32 (byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (logior (ash (aref byte-vector (+ byte-index 0)) 0) @@ -399,8 +406,8 @@ (:big-endian (error "stub: no big-endian ports of SBCL (yet?)")))) (defun (setf byte-vector-ref-32) (new-value byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value) @@ -719,7 +726,7 @@ ;;;; symbol magic -;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL. +;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL. (defvar *cold-symbol-allocation-gspace* nil) ;;; Allocate (and initialize) a symbol. @@ -1550,7 +1557,7 @@ (#.sb!c:pmax-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1606,9 +1613,9 @@ gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) - (assert (= code-object-start-addr - (+ gspace-byte-address - (descriptor-byte-offset code-object)))) + (aver (= code-object-start-addr + (+ gspace-byte-address + (descriptor-byte-offset code-object)))) (ecase kind (:absolute (let ((fixed-up (+ value un-fixed-up))) @@ -1656,7 +1663,7 @@ (logand inst #xffffc000))) (:load-short (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) + (aver (<= 0 low-bits (1- (ash 1 4)))) (logior (ash low-bits 17) (logand inst #xffe0ffff)))) (:hi @@ -1668,13 +1675,13 @@ (logand inst #xffe00000))) (:branch (let ((bits (ldb (byte 9 2) value))) - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) (logior (ash bits 3) (logand inst #xffe0e002))))))))) (#.sb!c:alpha-fasl-file-implementation (ecase kind (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) #+nil (setf (sap-ref-16 sap 0) (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) @@ -1699,7 +1706,7 @@ (#.sb!c:sgi-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1743,16 +1750,17 @@ (defvar *normal-fop-functions*) -;;; This is like DEFINE-FOP which defines fops for warm load, but unlike -;;; DEFINE-FOP, this version -;;; (1) looks up the code for this name (created by a previous DEFINE-FOP) -;;; instead of creating a code, and -;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, instead -;;; of storing in the *FOP-FUNCTIONS* vector. +;;; Cause a fop to have a special definition for cold load. +;;; +;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version +;;; (1) looks up the code for this name (created by a previous +;; DEFINE-FOP) instead of creating a code, and +;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, +;;; instead of storing in the *FOP-FUNCTIONS* vector. (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) (let ((code (get name 'fop-code)) - (fname (concat-pnames 'cold- name))) + (fname (symbolicate "COLD-" name))) (unless code (error "~S is not a defined FOP." name)) `(progn @@ -1763,7 +1771,7 @@ (setf (svref *cold-fop-functions* ,code) #',fname)))) (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) `(progn (macrolet ((clone-arg () '(read-arg 4))) (define-cold-fop (,name ,pushp) ,@forms)) @@ -1775,8 +1783,9 @@ `(define-cold-fop (,name) (error "The fop ~S is not supported in cold load." ',name))) -;;; COLD-LOAD loads stuff into the core image being built by calling FASLOAD -;;; with the fop function table rebound to a table of cold loading functions. +;;; COLD-LOAD loads stuff into the core image being built by calling +;;; LOAD-AS-FASL with the fop function table rebound to a table of cold +;;; loading functions. (defun cold-load (filename) #!+sb-doc "Load the file named by FILENAME into the cold load image being built." @@ -1786,7 +1795,7 @@ (string filename) (pathname (namestring filename))))) (with-open-file (s filename :element-type '(unsigned-byte 8)) - (fasload s nil nil)))) + (load-as-fasl s nil nil)))) ;;;; miscellaneous cold fops @@ -1851,7 +1860,7 @@ (declare (type index old-length)) (declare (type fixnum old-depthoid)) (declare (type list old-inherits-list)) - (assert (eq name old-name)) + (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) (depthoid (descriptor-fixnum depthoid-des))) @@ -2840,7 +2849,7 @@ initially undefined function references:~2%") ;; less expensively (ERROR, not CERROR), and which reports ;; "internal error" on failure. Use it here and elsewhere in the ;; system. - (assert (zerop rem)) + (aver (zerop rem)) (write-long floor)) (write-long pages) @@ -3033,7 +3042,7 @@ initially undefined function references:~2%") ;; much. (And the old CMU CL code is still useful for making ;; sure that the appropriate keywords and internal symbols end ;; up interned in the target Lisp, which is good, e.g. in order - ;; to make keyword arguments work right and in order to make + ;; to make &KEY arguments work right and in order to make ;; BACKTRACEs into target Lisp system code be legible.) (dolist (exported-name (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))