X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=8fa8d500dab19b9c3ade6d47856eceabc5443387;hb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;hp=cfb66af5eca0857b8bf589347b9d88edc7cf7ab3;hpb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index cfb66af..8fa8d50 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -12,7 +12,7 @@ ;;;; 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. +;;;; 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, @@ -85,18 +85,18 @@ (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) + (name (missing-arg) :type symbol :read-only t) + (identifier (missing-arg) :type fixnum :read-only t) ;; the word address where the data will be loaded - (word-address (required-argument) :type unsigned-byte :read-only t) + (word-address (missing-arg) :type unsigned-byte :read-only t) ;; the data themselves. (Note that in CMU CL this was a pair ;; of fields SAP and WORDS-ALLOCATED, but that wasn't very portable.) (bytes (make-array target-space-alignment :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) 1)) ;; the index of the next unwritten word (i.e. chunk of - ;; SB!VM:WORD-BYTES bytes) in BYTES, or equivalently the number of + ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of ;; words actually written in BYTES. In order to convert to an actual - ;; index into BYTES, thus must be multiplied by SB!VM:WORD-BYTES. + ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES. (free-word-index 0)) (defun gspace-byte-address (gspace) @@ -138,7 +138,7 @@ ;; 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 - (word-offset nil :type (or (unsigned-byte #.sb!vm:word-bits) null)) + (word-offset nil :type (or (unsigned-byte #.sb!vm:n-word-bits) null)) ;; the high and low halves of the descriptor ;; ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL @@ -160,7 +160,7 @@ (ash (descriptor-low des) (- 1 sb!vm:n-lowtag-bits))))) (format stream - "for fixnum: ~D" + "for fixnum: ~W" (if (> unsigned #x1FFFFFFF) (- unsigned #x40000000) unsigned)))) @@ -194,7 +194,7 @@ ;; NEW-FREE-WORD-INDEX. (do () ((>= (length (gspace-bytes gspace)) - (* new-free-word-index sb!vm:word-bytes))) + (* new-free-word-index sb!vm:n-word-bytes))) (expand-gspace-bytes gspace)) ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it. (setf (gspace-free-word-index gspace) new-free-word-index) @@ -220,14 +220,14 @@ (defun descriptor-fixnum (des) (let ((bits (descriptor-bits des))) - (if (logbitp (1- sb!vm:word-bits) bits) - ;; KLUDGE: The (- SB!VM:WORD-BITS 2) term here looks right to - ;; me, and it works, but in CMU CL it was (1- SB!VM:WORD-BITS), + (if (logbitp (1- sb!vm:n-word-bits) bits) + ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to + ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS), ;; and although that doesn't make sense for me, or work for me, ;; it's hard to see how it could have been wrong, since CMU CL ;; genesis worked. It would be nice to understand how this came ;; to be.. -- WHN 19990901 - (logior (ash bits -2) (ash -1 (- sb!vm:word-bits 2))) + (logior (ash bits -2) (ash -1 (- sb!vm:n-word-bits 2))) (ash bits -2)))) ;;; common idioms @@ -278,13 +278,14 @@ (defun make-random-descriptor (value) (make-descriptor (logand (ash value (- descriptor-low-bits)) (1- (ash 1 - (- sb!vm:word-bits descriptor-low-bits)))) + (- sb!vm:n-word-bits + descriptor-low-bits)))) (logand value (1- (ash 1 descriptor-low-bits))))) (defun make-fixnum-descriptor (num) (when (>= (integer-length num) - (1+ (- sb!vm:word-bits sb!vm:n-lowtag-bits))) - (error "~D is too big for a fixnum." num)) + (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits))) + (error "~W is too big for a fixnum." num)) (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits)))) (defun make-other-immediate-descriptor (data type) @@ -380,8 +381,8 @@ (defun maybe-byte-swap (word) (declare (type (unsigned-byte 32) word)) - (aver (= sb!vm:word-bits 32)) - (aver (= sb!vm:byte-bits 8)) + (aver (= sb!vm:n-word-bits 32)) + (aver (= sb!vm:n-byte-bits 8)) (if (not *genesis-byte-order-swap-p*) word (logior (ash (ldb (byte 8 0) word) 24) @@ -391,8 +392,8 @@ (defun maybe-byte-swap-short (short) (declare (type (unsigned-byte 16) short)) - (aver (= sb!vm:word-bits 32)) - (aver (= sb!vm:byte-bits 8)) + (aver (= sb!vm:n-word-bits 32)) + (aver (= sb!vm:n-byte-bits 8)) (if (not *genesis-byte-order-swap-p*) short (logior (ash (ldb (byte 8 0) short) 8) @@ -415,16 +416,16 @@ (ldb (byte 8 ,(* i 8)) new-value))))) `(progn (defun ,name (byte-vector byte-index) - (aver (= sb!vm:word-bits 32)) - (aver (= sb!vm:byte-bits 8)) + (aver (= sb!vm:n-word-bits 32)) + (aver (= sb!vm:n-byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (logior ,@ash-list)) (:big-endian (error "stub: no big-endian ports of SBCL (yet?)")))) (defun (setf ,name) (new-value byte-vector byte-index) - (aver (= sb!vm:word-bits 32)) - (aver (= sb!vm:byte-bits 8)) + (aver (= sb!vm:n-word-bits 32)) + (aver (= sb!vm:n-byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (setf ,@setf-list)) @@ -520,9 +521,9 @@ "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and return an ``other-pointer'' descriptor to them. Initialize the header word with the resultant length and TYPE." - (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits)) + (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits)) (des (allocate-cold-descriptor gspace - (+ bytes sb!vm:word-bytes) + (+ bytes sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag))) (write-memory des (make-other-immediate-descriptor (ash bytes @@ -536,9 +537,9 @@ header word with TYPE and the length slot with LENGTH." ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using ;; #'/ instead of #'CEILING, which seems wrong. - (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits)) + (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits)) (des (allocate-cold-descriptor gspace - (+ bytes (* 2 sb!vm:word-bytes)) + (+ bytes (* 2 sb!vm:n-word-bytes)) sb!vm:other-pointer-lowtag))) (write-memory des (make-other-immediate-descriptor 0 type)) (write-wordindexed des @@ -555,11 +556,11 @@ ;; extra null byte at the end to aid in call-out to C.) (let* ((length (length string)) (des (allocate-vector-object gspace - sb!vm:byte-bits + sb!vm:n-byte-bits (1+ length) sb!vm:simple-string-widetag)) (bytes (gspace-bytes gspace)) - (offset (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) + (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) (descriptor-byte-offset des)))) (write-wordindexed des sb!vm:vector-length-slot @@ -581,20 +582,20 @@ (defun bignum-to-core (n) #!+sb-doc "Copy a bignum to the cold core." - (let* ((words (ceiling (1+ (integer-length n)) sb!vm:word-bits)) + (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits)) (handle (allocate-unboxed-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits words sb!vm:bignum-widetag))) (declare (fixnum words)) (do ((index 1 (1+ index)) - (remainder n (ash remainder (- sb!vm:word-bits)))) + (remainder n (ash remainder (- sb!vm:n-word-bits)))) ((> index words) (unless (zerop (integer-length remainder)) ;; FIXME: Shouldn't this be a fatal error? - (warn "~D words of ~D were written, but ~D bits were left over." + (warn "~W words of ~W were written, but ~W bits were left over." words n remainder))) - (let ((word (ldb (byte sb!vm:word-bits 0) remainder))) + (let ((word (ldb (byte sb!vm:n-word-bits 0) remainder))) (write-wordindexed handle index (make-descriptor (ash word (- descriptor-low-bits)) (ldb (byte descriptor-low-bits 0) @@ -604,7 +605,7 @@ (defun number-pair-to-core (first second type) #!+sb-doc "Makes a number pair of TYPE (ratio or complex) and fills it in." - (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits 2 type))) + (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits 2 type))) (write-wordindexed des 1 first) (write-wordindexed des 2 second) des)) @@ -613,7 +614,7 @@ (etypecase x (single-float (let ((des (allocate-unboxed-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits (1- sb!vm:single-float-size) sb!vm:single-float-widetag))) (write-wordindexed des @@ -622,7 +623,7 @@ des)) (double-float (let ((des (allocate-unboxed-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits (1- sb!vm:double-float-size) sb!vm:double-float-widetag)) (high-bits (make-random-descriptor (double-float-high-bits x))) @@ -638,7 +639,7 @@ #!+(and long-float x86) (long-float (let ((des (allocate-unboxed-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits (1- sb!vm:long-float-size) sb!vm:long-float-widetag)) (exp-bits (make-random-descriptor (long-float-exp-bits x))) @@ -655,7 +656,7 @@ (defun complex-single-float-to-core (num) (declare (type (complex single-float) num)) - (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-single-float-size) sb!vm:complex-single-float-widetag))) (write-wordindexed des sb!vm:complex-single-float-real-slot @@ -666,7 +667,7 @@ (defun complex-double-float-to-core (num) (declare (type (complex double-float) num)) - (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-double-float-size) sb!vm:complex-double-float-widetag))) (let* ((real (realpart num)) @@ -715,7 +716,7 @@ (declaim (ftype (function (sb!vm:word) descriptor) sap-to-core)) (defun sapint-to-core (sapint) (let ((des (allocate-unboxed-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits (1- sb!vm:sap-size) sb!vm:sap-widetag))) (write-wordindexed des @@ -734,7 +735,7 @@ ;;; descriptor. (defun vector-in-core (&rest objects) (let* ((size (length objects)) - (result (allocate-vector-object *dynamic* sb!vm:word-bits size + (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size sb!vm:simple-vector-widetag))) (dotimes (index size) (write-wordindexed result (+ index sb!vm:vector-data-offset) @@ -751,7 +752,7 @@ (declare (simple-string name)) (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace* *dynamic*) - sb!vm:word-bits + sb!vm:n-word-bits (1- sb!vm:symbol-size) sb!vm:symbol-header-widetag))) (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*) @@ -1012,7 +1013,7 @@ (defun cold-intern (symbol &optional (package (symbol-package symbol))) ;; Anything on the cross-compilation host which refers to the target - ;; machinery through the host SB-XC package can be translated to + ;; machinery through the host SB-XC package should be translated to ;; something on the target which refers to the same machinery ;; through the target COMMON-LISP package. (let ((p (find-package "SB-XC"))) @@ -1021,6 +1022,25 @@ (when (eq (symbol-package symbol) p) (setf symbol (intern (symbol-name symbol) *cl-package*)))) + ;; Make sure that the symbol has an appropriate package. In + ;; particular, catch the so-easy-to-make error of typing something + ;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really + ;; need is SB!KERNEL:%BYTE-BLT. + (let ((package-name (package-name package))) + (cond ((find package-name '("COMMON-LISP" "KEYWORD") :test #'string=) + ;; That's OK then. + (values)) + ((string= package-name "SB!" :end1 3 :end2 3) + ;; That looks OK, too. (All the target-code packages + ;; have names like that.) + (values)) + (t + ;; looks bad: maybe COMMON-LISP-USER? maybe an extension + ;; package in the xc host? something we can't think of + ;; a valid reason to dump, anyway... + (error "internal error: PACKAGE-NAME=~S looks too much like a typo." + package-name)))) + (let (;; Information about each cold-interned symbol is stored ;; in COLD-INTERN-INFO. ;; (CAR COLD-INTERN-INFO) = descriptor of symbol @@ -1056,12 +1076,12 @@ (defun make-nil-descriptor () (let* ((des (allocate-unboxed-object *static* - sb!vm:word-bits + sb!vm:n-word-bits sb!vm:symbol-size 0)) (result (make-descriptor (descriptor-high des) (+ (descriptor-low des) - (* 2 sb!vm:word-bytes) + (* 2 sb!vm:n-word-bytes) (- sb!vm:list-pointer-lowtag sb!vm:other-pointer-lowtag))))) (write-wordindexed des @@ -1107,7 +1127,7 @@ (descriptor-low *nil-descriptor*)))) (unless (= offset-wanted offset-found) ;; FIXME: should be fatal - (warn "Offset from ~S to ~S is ~D, not ~D" + (warn "Offset from ~S to ~S is ~W, not ~W" symbol nil offset-found @@ -1135,13 +1155,17 @@ ;;; intern it. (defun finish-symbols () - ;; FIXME: Why use SETQ (setting symbol value) instead of just using - ;; the function values for these things?? I.e. why do we need this - ;; section at all? Is it because all the FDEFINITION stuff gets in - ;; the way of reading function values and is too hairy to rely on at - ;; cold boot? FIXME: Most of these are in *STATIC-SYMBOLS* in - ;; parms.lisp, but %HANDLE-FUN-END-BREAKPOINT is not. Why? - ;; Explain. + ;; I think the point of setting these functions into SYMBOL-VALUEs + ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL + ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty + ;; hairy operation (involving globaldb.lisp etc.) which we don't + ;; want to invoke early in cold init. -- WHN 2001-12-05 + ;; + ;; FIXME: So OK, that's a reasonable reason to do something weird like + ;; this, but this is still a weird thing to do, and we should change + ;; the names to highlight that something weird is going on. Perhaps + ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*, + ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*... (macrolet ((frob (symbol) `(cold-set ',symbol (cold-fdefinition-object (cold-intern ',symbol))))) @@ -1351,7 +1375,7 @@ (warm-symbol cadr-des)))) (#.sb!vm:other-pointer-lowtag (warm-symbol des))))) - (unless (legal-function-name-p result) + (unless (legal-fun-name-p result) (error "not a legal function name: ~S" result)) result)) @@ -1398,28 +1422,29 @@ sb!vm:word-shift)))) (#.sb!vm:closure-header-widetag (make-random-descriptor - (cold-foreign-symbol-address-as-integer "closure_tramp"))))) + (cold-foreign-symbol-address-as-integer + "closure_tramp"))))) fdefn)) (defun initialize-static-fns () (let ((*cold-fdefn-gspace* *static*)) - (dolist (sym sb!vm:*static-functions*) + (dolist (sym sb!vm:*static-funs*) (let* ((fdefn (cold-fdefinition-object (cold-intern sym))) (offset (- (+ (- (descriptor-low fdefn) sb!vm:other-pointer-lowtag) - (* sb!vm:fdefn-raw-addr-slot sb!vm:word-bytes)) + (* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes)) (descriptor-low *nil-descriptor*))) - (desired (sb!vm:static-function-offset sym))) + (desired (sb!vm:static-fun-offset sym))) (unless (= offset desired) ;; FIXME: should be fatal - (warn "Offset from FDEFN ~S to ~S is ~D, not ~D." + (warn "Offset from FDEFN ~S to ~S is ~W, not ~W." sym nil offset desired)))))) (defun list-all-fdefn-objects () (let ((result *nil-descriptor*)) - (maphash #'(lambda (key value) - (declare (ignore key)) - (cold-push value result)) + (maphash (lambda (key value) + (declare (ignore key)) + (cold-push value result)) *cold-fdefn-objects*) result)) @@ -1643,7 +1668,7 @@ (let ((fixed-up (- (+ value un-fixed-up) gspace-byte-address gspace-byte-offset - sb!vm:word-bytes))) ; length of CALL argument + sb!vm:n-word-bytes))) ; length of CALL argument (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset) fixed-up) ;; Note relative fixups that point outside the code @@ -1685,41 +1710,43 @@ ;;;; general machinery for cold-loading FASL files ;;; FOP functions for cold loading -(defvar *cold-fop-functions* - ;; We start out with a copy of the ordinary *FOP-FUNCTIONS*. The - ;; ones which aren't appropriate for cold load will be destructively +(defvar *cold-fop-funs* + ;; We start out with a copy of the ordinary *FOP-FUNS*. The ones + ;; which aren't appropriate for cold load will be destructively ;; modified. - (copy-seq *fop-functions*)) + (copy-seq *fop-funs*)) -(defvar *normal-fop-functions*) +(defvar *normal-fop-funs*) ;;; 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) - (aver (member pushp '(nil t :nope))) +;;; (2) stores its definition in the *COLD-FOP-FUNS* vector, +;;; instead of storing in the *FOP-FUNS* vector. +(defmacro define-cold-fop ((name &key (pushp t) (stackp t)) &rest forms) + (aver (member pushp '(nil t))) + (aver (member stackp '(nil t))) (let ((code (get name 'fop-code)) (fname (symbolicate "COLD-" name))) (unless code (error "~S is not a defined FOP." name)) `(progn (defun ,fname () - ,@(if (eq pushp :nope) - forms - `((with-fop-stack ,pushp ,@forms)))) - (setf (svref *cold-fop-functions* ,code) #',fname)))) - -(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms) - (aver (member pushp '(nil t :nope))) + ,@(if stackp + `((with-fop-stack ,pushp ,@forms)) + forms)) + (setf (svref *cold-fop-funs* ,code) #',fname)))) + +(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) (small-name) &rest forms) + (aver (member pushp '(nil t))) + (aver (member stackp '(nil t))) `(progn (macrolet ((clone-arg () '(read-arg 4))) - (define-cold-fop (,name ,pushp) ,@forms)) + (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms)) (macrolet ((clone-arg () '(read-arg 1))) - (define-cold-fop (,small-name ,pushp) ,@forms)))) + (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms)))) ;;; Cause a fop to be undefined in cold load. (defmacro not-cold-fop (name) @@ -1732,8 +1759,8 @@ (defun cold-load (filename) #!+sb-doc "Load the file named by FILENAME into the cold load image being built." - (let* ((*normal-fop-functions* *fop-functions*) - (*fop-functions* *cold-fop-functions*) + (let* ((*normal-fop-funs* *fop-funs*) + (*fop-funs* *cold-fop-funs*) (*cold-load-filename* (etypecase filename (string filename) (pathname (namestring filename))))) @@ -1752,14 +1779,14 @@ (define-cold-fop (fop-empty-list) *nil-descriptor*) (define-cold-fop (fop-truth) (cold-intern t)) -(define-cold-fop (fop-normal-load :nope) - (setq *fop-functions* *normal-fop-functions*)) +(define-cold-fop (fop-normal-load :stackp nil) + (setq *fop-funs* *normal-fop-funs*)) -(define-fop (fop-maybe-cold-load 82 :nope) +(define-fop (fop-maybe-cold-load 82 :stackp nil) (when *cold-load-filename* - (setq *fop-functions* *cold-fop-functions*))) + (setq *fop-funs* *cold-fop-funs*))) -(define-cold-fop (fop-maybe-cold-load :nope)) +(define-cold-fop (fop-maybe-cold-load :stackp nil)) (clone-cold-fop (fop-struct) (fop-small-struct) @@ -1926,7 +1953,7 @@ (fop-small-vector) (let* ((size (clone-arg)) (result (allocate-vector-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits size sb!vm:simple-vector-widetag))) (do ((index (1- size) (1- index))) @@ -1947,13 +1974,13 @@ (8 sb!vm:simple-array-unsigned-byte-8-widetag) (16 sb!vm:simple-array-unsigned-byte-16-widetag) (32 sb!vm:simple-array-unsigned-byte-32-widetag) - (t (error "losing element size: ~D" sizebits)))) + (t (error "losing element size: ~W" sizebits)))) (result (allocate-vector-object *dynamic* sizebits len type)) (start (+ (descriptor-byte-offset result) (ash sb!vm:vector-data-offset sb!vm:word-shift))) (end (+ start (ceiling (* len sizebits) - sb!vm:byte-bits)))) + sb!vm:n-byte-bits)))) (read-sequence-or-die (descriptor-bytes result) *fasl-input-stream* :start start @@ -1964,12 +1991,12 @@ (let* ((len (read-arg 4)) (result (allocate-vector-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits len sb!vm:simple-array-single-float-widetag)) (start (+ (descriptor-byte-offset result) (ash sb!vm:vector-data-offset sb!vm:word-shift))) - (end (+ start (* len sb!vm:word-bytes)))) + (end (+ start (* len sb!vm:n-word-bytes)))) (read-sequence-or-die (descriptor-bytes result) *fasl-input-stream* :start start @@ -2019,7 +2046,7 @@ ;;;; cold fops for loading numbers (defmacro define-cold-number-fop (fop) - `(define-cold-fop (,fop :nope) + `(define-cold-fop (,fop :stackp nil) ;; Invoke the ordinary warm version of this fop to push the ;; number. (,fop) @@ -2043,7 +2070,7 @@ (ecase +backend-fasl-file-implementation+ (:x86 ; (which has 80-bit long-float format) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:long-float-size) sb!vm:long-float-widetag)) (low-bits (make-random-descriptor (fast-read-u-integer 4))) @@ -2059,7 +2086,7 @@ #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:long-float-size) sb!vm:long-float-widetag)) (low-bits (make-random-descriptor (fast-read-u-integer 4))) @@ -2078,7 +2105,7 @@ (ecase +backend-fasl-file-implementation+ (:x86 ; (which has 80-bit long-float format) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-widetag)) (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) @@ -2111,7 +2138,7 @@ #+nil (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits + (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-long-float-size) sb!vm:complex-long-float-widetag)) (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) @@ -2182,11 +2209,11 @@ (defun finalize-load-time-value-noise () (cold-set (cold-intern '*!load-time-values*) (allocate-vector-object *dynamic* - sb!vm:word-bits + sb!vm:n-word-bits *load-time-value-counter* sb!vm:simple-vector-widetag))) -(define-cold-fop (fop-funcall-for-effect nil) +(define-cold-fop (fop-funcall-for-effect :pushp nil) (if (= (read-arg 1) 0) (cold-push (pop-stack) *current-reversed-cold-toplevels*) @@ -2194,17 +2221,17 @@ ;;;; cold fops for fixing up circularities -(define-cold-fop (fop-rplaca nil) +(define-cold-fop (fop-rplaca :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) -(define-cold-fop (fop-rplacd nil) +(define-cold-fop (fop-rplacd :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) -(define-cold-fop (fop-svset nil) +(define-cold-fop (fop-svset :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4))) (write-wordindexed obj @@ -2214,12 +2241,14 @@ (#.sb!vm:other-pointer-lowtag 2))) (pop-stack)))) -(define-cold-fop (fop-structset nil) +(define-cold-fop (fop-structset :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4))) (write-wordindexed obj (1+ idx) (pop-stack)))) -(define-cold-fop (fop-nthcdr t) +;;; In the original CMUCL code, this actually explicitly declared PUSHP +;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP. +(define-cold-fop (fop-nthcdr) (cold-nthcdr (read-arg 4) (pop-stack))) (defun cold-nthcdr (index obj) @@ -2237,7 +2266,7 @@ ;; (SETF CAR). (make-hash-table :test 'equal)) -(define-cold-fop (fop-fset nil) +(define-cold-fop (fop-fset :pushp nil) (let* ((fn (pop-stack)) (cold-name (pop-stack)) (warm-name (warm-fun-name cold-name))) @@ -2302,10 +2331,10 @@ #!+sb-show (when *show-pre-fixup-code-p* (format *trace-output* - "~&/raw code from code-fop ~D ~D:~%" + "~&/raw code from code-fop ~W ~W:~%" nconst code-size) - (do ((i start (+ i sb!vm:word-bytes))) + (do ((i start (+ i sb!vm:n-word-bytes))) ((>= i end)) (format *trace-output* "/#X~8,'0x: #X~8,'0x~%" @@ -2317,14 +2346,14 @@ (define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2)) -(clone-cold-fop (fop-alter-code nil) +(clone-cold-fop (fop-alter-code :pushp nil) (fop-byte-alter-code) (let ((slot (clone-arg)) (value (pop-stack)) (code (pop-stack))) (write-wordindexed code slot value))) -(define-cold-fop (fop-function-entry) +(define-cold-fop (fop-fun-entry) (let* ((type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) @@ -2555,8 +2584,8 @@ (maybe-record-with-translated-name '("-START" "-END") 6))))) (setf constants (sort constants - #'(lambda (const1 const2) - (if (= (second const1) (second const2)) + (lambda (const1 const2) + (if (= (second const1) (second const2)) (< (third const1) (third const2)) (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) @@ -2606,9 +2635,9 @@ ;; writing primitive object layouts (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< - :key #'(lambda (obj) - (symbol-name - (sb!vm:primitive-object-name obj)))))) + :key (lambda (obj) + (symbol-name + (sb!vm:primitive-object-name obj)))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "#define LISPOBJ(x) ((lispobj)x)~2%") (dolist (obj structs) @@ -2616,7 +2645,7 @@ "struct ~A {~%" (nsubstitute #\_ #\- (string-downcase (string (sb!vm:primitive-object-name obj))))) - (when (sb!vm:primitive-object-header obj) + (when (sb!vm:primitive-object-widetag obj) (format t " lispobj header;~%")) (dolist (slot (sb!vm:primitive-object-slots obj)) (format t " ~A ~A~@[[1]~];~%" @@ -2635,7 +2664,7 @@ (format t "#define ~A_~A_OFFSET ~D~%" (substitute #\_ #\- (string name)) (substitute #\_ #\- (string (sb!vm:slot-name slot))) - (- (* (sb!vm:slot-offset slot) sb!vm:word-bytes) lowtag))) + (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) (terpri)))) (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) @@ -2645,15 +2674,15 @@ ;; in #define statements. (format t "#define ~A LISPOBJ(0x~X)~%" (nsubstitute #\_ #\- - (remove-if #'(lambda (char) - (member char '(#\% #\* #\. #\!))) + (remove-if (lambda (char) + (member char '(#\% #\* #\. #\!))) (symbol-name symbol))) (if *static* ; if we ran GENESIS ;; We actually ran GENESIS, use the real value. (descriptor-bits (cold-intern symbol)) ;; We didn't run GENESIS, so guess at the address. (+ sb!vm:static-space-start - sb!vm:word-bytes + sb!vm:n-word-bytes sb!vm:other-pointer-lowtag (if symbol (sb!vm:static-symbol-offset symbol) 0))))) @@ -2675,16 +2704,16 @@ (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine))) (let ((funs nil) (undefs nil)) - (maphash #'(lambda (name fdefn) - (let ((fun (read-wordindexed fdefn - sb!vm:fdefn-fun-slot))) - (if (= (descriptor-bits fun) - (descriptor-bits *nil-descriptor*)) - (push name undefs) - (let ((addr (read-wordindexed - fdefn sb!vm:fdefn-raw-addr-slot))) - (push (cons name (descriptor-bits addr)) - funs))))) + (maphash (lambda (name fdefn) + (let ((fun (read-wordindexed fdefn + sb!vm:fdefn-fun-slot))) + (if (= (descriptor-bits fun) + (descriptor-bits *nil-descriptor*)) + (push name undefs) + (let ((addr (read-wordindexed + fdefn sb!vm:fdefn-raw-addr-slot))) + (push (cons name (descriptor-bits addr)) + funs))))) *cold-fdefn-objects*) (format t "~%~|~%initially defined functions:~2%") (setf funs (sort funs #'< :key #'cdr)) @@ -2704,26 +2733,16 @@ that they were called before the out-of-line definition is installed, as is fairly common for structure accessors.) initially undefined function references:~2%") - (setf undefs (sort undefs #'string< :key #'function-name-block-name)) + (setf undefs (sort undefs #'string< :key #'fun-name-block-name)) (dolist (name undefs) - (format t "~S" name) - ;; FIXME: This ACCESSOR-FOR stuff should go away when the - ;; code has stabilized. (It's only here to help me - ;; categorize the flood of undefined functions caused by - ;; completely rewriting the bootstrap process. Hopefully any - ;; future maintainers will mostly have small numbers of - ;; undefined functions..) - (let ((accessor-for (info :function :accessor-for name))) - (when accessor-for - (format t " (accessor for ~S)" accessor-for))) - (format t "~%"))) + (format t "~S~%" name))) (format t "~%~|~%layout names:~2%") (collect ((stuff)) - (maphash #'(lambda (name gorp) - (declare (ignore name)) - (stuff (cons (descriptor-bits (car gorp)) - (cdr gorp)))) + (maphash (lambda (name gorp) + (declare (ignore name)) + (stuff (cons (descriptor-bits (car gorp)) + (cdr gorp)))) *cold-layouts*) (dolist (x (sort (stuff) #'< :key #'car)) (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))) @@ -2742,7 +2761,7 @@ initially undefined function references:~2%") (defparameter validate-entry-type-code 3845) (defparameter directory-entry-type-code 3841) (defparameter new-directory-entry-type-code 3861) -(defparameter initial-function-entry-type-code 3863) +(defparameter initial-fun-entry-type-code 3863) (defparameter end-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-long)) @@ -2765,7 +2784,7 @@ initially undefined function references:~2%") (defun output-gspace (gspace) (force-output *core-file*) (let* ((posn (file-position *core-file*)) - (bytes (* (gspace-free-word-index gspace) sb!vm:word-bytes)) + (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes)) (pages (ceiling bytes sb!c:*backend-page-size*)) (total-bytes (* pages sb!c:*backend-page-size*))) @@ -2842,16 +2861,16 @@ initially undefined function references:~2%") (output-gspace *dynamic*) ;; Write the initial function. - (write-long initial-function-entry-type-code) + (write-long initial-fun-entry-type-code) (write-long 3) (let* ((cold-name (cold-intern '!cold-init)) (cold-fdefn (cold-fdefinition-object cold-name)) - (initial-function (read-wordindexed cold-fdefn - sb!vm:fdefn-fun-slot))) + (initial-fun (read-wordindexed cold-fdefn + sb!vm:fdefn-fun-slot))) (format t - "~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%" - (descriptor-bits initial-function)) - (write-long (descriptor-bits initial-function))) + "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%" + (descriptor-bits initial-fun)) + (write-long (descriptor-bits initial-fun))) ;; Write the End entry. (write-long end-entry-type-code)