X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=b5d6fe653bd14d8161682f0da365cf8ae83e8fb6;hb=a8fa26a6e9804d3548f5bca9361a91345a689099;hp=28eb128cad9c260fcc42b88b957613eaf5ff19f4;hpb=c3887143fdc6da9b63d18ce5cde2a0c037ea3a24;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 28eb128..b5d6fe6 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -79,7 +79,8 @@ ;;; 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) @@ -129,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 @@ -342,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. @@ -373,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) @@ -384,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) @@ -393,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) @@ -404,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) @@ -724,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. @@ -1555,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 @@ -1611,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))) @@ -1661,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 @@ -1673,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))))) @@ -1704,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 @@ -1748,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)) (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 @@ -1780,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 +;;; FASLOAD 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." @@ -1856,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))) @@ -2845,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) @@ -3038,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"))