X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=e633d66019364a99ed55aabd27d48a3030da1e2d;hb=9a0890f2e981ef940888a25ca757762f714c4a9f;hp=4de59b9727b2b659bdd8c8433413d03f75cb3cc1;hpb=f9ab6e62f6bc391395323ebc0906987d419725ad;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4de59b9..e633d66 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -60,7 +60,8 @@ ;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support, ;;; deleted a slot from DEBUG-SOURCE structure ;;; 3: added build ID to cores to discourage sbcl/.core mismatch -(defconstant sbcl-core-version-integer 3) +;;; 4: added gc page table data +(defconstant sbcl-core-version-integer 4) (defun round-up (number size) #!+sb-doc @@ -85,7 +86,8 @@ `(simple-array (unsigned-byte 8) (,+smallvec-length+))) (defun make-smallvec () - (make-array +smallvec-length+ :element-type '(unsigned-byte 8))) + (make-array +smallvec-length+ :element-type '(unsigned-byte 8) + :initial-element 0)) ;;; a big vector, implemented as a vector of SMALLVECs ;;; @@ -229,6 +231,9 @@ (defvar *read-only*) (defconstant read-only-core-space-id 3) +(defconstant max-core-space-id 3) +(defconstant deflated-core-space-id-flag 4) + (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) @@ -274,12 +279,22 @@ ;;;; representation of descriptors +(defun is-fixnum-lowtag (lowtag) + (zerop (logand lowtag sb!vm:fixnum-tag-mask))) + +(defun is-other-immediate-lowtag (lowtag) + ;; The other-immediate lowtags are similar to the fixnum lowtags, in + ;; that they have an "effective length" that is shorter than is used + ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the + ;; other-immediate lowtags are always effectively two bits wide. + (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag)) + (defstruct (descriptor (:constructor make-descriptor (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)) + (gspace nil :type (or gspace (eql :load-time-value) null)) ;; the offset in words from the start of GSPACE, or NIL if not set yet (word-offset nil :type (or sb!vm:word null)) ;; the high and low halves of the descriptor @@ -295,8 +310,7 @@ (def!method print-object ((des descriptor) stream) (let ((lowtag (descriptor-lowtag des))) (print-unreadable-object (des stream :type t) - (cond ((or (= lowtag sb!vm:even-fixnum-lowtag) - (= lowtag sb!vm:odd-fixnum-lowtag)) + (cond ((is-fixnum-lowtag lowtag) (let ((unsigned (logior (ash (descriptor-high des) (1+ (- descriptor-low-bits sb!vm:n-lowtag-bits))) @@ -307,12 +321,7 @@ (if (> unsigned #x1FFFFFFF) (- unsigned #x40000000) unsigned)))) - ((or (= lowtag sb!vm:other-immediate-0-lowtag) - (= lowtag sb!vm:other-immediate-1-lowtag) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (= lowtag sb!vm:other-immediate-2-lowtag) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (= lowtag sb!vm:other-immediate-3-lowtag)) + ((is-other-immediate-lowtag lowtag) (format stream "for other immediate: #X~X, type #b~8,'0B" (ash (descriptor-bits des) (- sb!vm:n-widetag-bits)) @@ -374,16 +383,15 @@ ;; 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 (- 1 sb!vm:n-lowtag-bits)) + (logior (ash bits (- sb!vm:n-fixnum-tag-bits)) (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) - (ash bits (- 1 sb!vm:n-lowtag-bits))))) + (ash bits (- sb!vm:n-fixnum-tag-bits))))) (defun descriptor-word-sized-integer (des) ;; Extract an (unsigned-byte 32), from either its fixnum or bignum ;; representation. (let ((lowtag (descriptor-lowtag des))) - (if (or (= lowtag sb!vm:even-fixnum-lowtag) - (= lowtag sb!vm:odd-fixnum-lowtag)) + (if (is-fixnum-lowtag lowtag) (make-random-descriptor (descriptor-fixnum des)) (read-wordindexed des 1)))) @@ -399,21 +407,31 @@ ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE. (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace)) (defun descriptor-intuit-gspace (des) - (if (descriptor-gspace des) - (descriptor-gspace des) - ;; KLUDGE: It's not completely clear to me what's going on here; - ;; this is a literal translation from of some rather mysterious - ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation - ;; would be nice. -- WHN 19990817 - (let ((lowtag (descriptor-lowtag des)) - (high (descriptor-high des)) - (low (descriptor-low des))) - (if (or (eql lowtag sb!vm:fun-pointer-lowtag) - (eql lowtag sb!vm:instance-pointer-lowtag) - (eql lowtag sb!vm:list-pointer-lowtag) - (eql lowtag sb!vm:other-pointer-lowtag)) + (or (descriptor-gspace des) + + ;; gspace wasn't set, now we have to search for it. + (let ((lowtag (descriptor-lowtag des)) + (high (descriptor-high des)) + (low (descriptor-low des))) + + ;; Non-pointer objects don't have a gspace. + (unless (or (eql lowtag sb!vm:fun-pointer-lowtag) + (eql lowtag sb!vm:instance-pointer-lowtag) + (eql lowtag sb!vm:list-pointer-lowtag) + (eql lowtag sb!vm:other-pointer-lowtag)) + (error "don't even know how to look for a GSPACE for ~S" des)) + (dolist (gspace (list *dynamic* *static* *read-only*) - (error "couldn't find a GSPACE for ~S" des)) + (error "couldn't find a GSPACE for ~S" des)) + ;; Bounds-check the descriptor against the allocated area + ;; within each gspace. + ;; + ;; Most of the faffing around in here involving ash and + ;; various computed shift counts is due to the high/low + ;; split representation of the descriptor bits and an + ;; apparent disinclination to create intermediate values + ;; larger than a target fixnum. + ;; ;; This code relies on the fact that GSPACEs are aligned ;; such that the descriptor-low-bits low bits are zero. (when (and (>= high (ash (gspace-word-address gspace) @@ -421,6 +439,8 @@ (<= high (ash (+ (gspace-word-address gspace) (gspace-free-word-index gspace)) (- sb!vm:word-shift descriptor-low-bits)))) + ;; Update the descriptor with the correct gspace and the + ;; offset within the gspace and return the gspace. (setf (descriptor-gspace des) gspace) (setf (descriptor-word-offset des) (+ (ash (- high (ash (gspace-word-address gspace) @@ -429,8 +449,7 @@ (- descriptor-low-bits sb!vm:word-shift)) (ash (logandc2 low sb!vm:lowtag-mask) (- sb!vm:word-shift)))) - (return gspace))) - (error "don't even know how to look for a GSPACE for ~S" des))))) + (return gspace)))))) (defun make-random-descriptor (value) (make-descriptor (logand (ash value (- descriptor-low-bits)) @@ -441,9 +460,9 @@ (defun make-fixnum-descriptor (num) (when (>= (integer-length num) - (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits))) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (error "~W is too big for a fixnum." num)) - (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits)))) + (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits))) (defun make-other-immediate-descriptor (data type) (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits)) @@ -497,6 +516,13 @@ ;;; purposes. (defvar *current-reversed-cold-toplevels*) +;;; the head of a list of DEBUG-SOURCEs which need to be patched when +;;; the cold core starts up +(defvar *current-debug-sources*) + +;;; foreign symbol references +(defparameter *cold-foreign-undefined-symbols* nil) + ;;; the name of the object file currently being cold loaded (as a string, not a ;;; pathname), or NIL if we're not currently cold loading any object file (defvar *cold-load-filename* nil) @@ -528,35 +554,31 @@ (read-wordindexed address 0)) ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS -;;; value, instead of the SAP-INT we use here.) -(declaim (ftype (function (sb!vm:word descriptor) (values)) +;;; value, instead of the object-and-offset we use here.) +(declaim (ftype (function (descriptor sb!vm:word descriptor) (values)) note-load-time-value-reference)) -(defun note-load-time-value-reference (address marker) +(defun note-load-time-value-reference (address offset marker) (cold-push (cold-cons (cold-intern :load-time-value-fixup) - (cold-cons (sap-int-to-core address) - (cold-cons - (number-to-core (descriptor-word-offset marker)) - *nil-descriptor*))) + (cold-cons address + (cold-cons (number-to-core offset) + (cold-cons + (number-to-core (descriptor-word-offset marker)) + *nil-descriptor*)))) *current-reversed-cold-toplevels*) (values)) -(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed)) +(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed)) (defun write-wordindexed (address index value) #!+sb-doc "Write VALUE displaced INDEX words from ADDRESS." - ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE) - ;; for calculating the value of the GSPACE slot from scratch. It - ;; doesn't work for all values, only some of them, but mightn't it - ;; be reasonable to see whether it works on VALUE before we give up - ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that, - ;; perhaps write a comment somewhere explaining why it's not a good - ;; idea?) -- WHN 19990817 - (if (and (null (descriptor-gspace value)) - (not (null (descriptor-word-offset value)))) - (note-load-time-value-reference (+ (logandc2 (descriptor-bits address) - sb!vm:lowtag-mask) - (ash index sb!vm:word-shift)) + ;; If we're passed a symbol as a value then it needs to be interned. + (when (symbolp value) (setf value (cold-intern value))) + (if (eql (descriptor-gspace value) :load-time-value) + (note-load-time-value-reference address + (- (ash index sb!vm:word-shift) + (logand (descriptor-bits address) + sb!vm:lowtag-mask)) value) (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address))) (byte-index (ash (+ index (descriptor-word-offset address)) @@ -564,7 +586,7 @@ (setf (bvref-word bytes byte-index) (descriptor-bits value))))) -(declaim (ftype (function (descriptor descriptor)) write-memory)) +(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory)) (defun write-memory (address value) #!+sb-doc "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)." @@ -724,10 +746,17 @@ core and return a descriptor to it." (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 - (make-random-descriptor (single-float-bits (realpart num)))) - (write-wordindexed des sb!vm:complex-single-float-imag-slot - (make-random-descriptor (single-float-bits (imagpart num)))) + #!-x86-64 + (progn + (write-wordindexed des sb!vm:complex-single-float-real-slot + (make-random-descriptor (single-float-bits (realpart num)))) + (write-wordindexed des sb!vm:complex-single-float-imag-slot + (make-random-descriptor (single-float-bits (imagpart num))))) + #!+x86-64 + (write-wordindexed des sb!vm:complex-single-float-data-slot + (make-random-descriptor + (logior (ldb (byte 32 0) (single-float-bits (realpart num))) + (ash (single-float-bits (imagpart num)) 32)))) des)) (defun complex-double-float-to-core (num) @@ -744,7 +773,7 @@ core and return a descriptor to it." (defun number-to-core (number) (typecase number (integer (if (< (integer-length number) - (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits)) + (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)) (make-fixnum-descriptor number) (bignum-to-core number))) (ratio (number-pair-to-core (number-to-core (numerator number)) @@ -792,14 +821,10 @@ core and return a descriptor to it." ;;;; symbol magic -;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL. -(defvar *cold-symbol-allocation-gspace* nil) - ;;; Allocate (and initialize) a symbol. -(defun allocate-symbol (name) +(defun allocate-symbol (name &key (gspace *dynamic*)) (declare (simple-string name)) - (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace* - *dynamic*) + (let ((symbol (allocate-unboxed-object gspace sb!vm:n-word-bits (1- sb!vm:symbol-size) sb!vm:symbol-header-widetag))) @@ -850,10 +875,27 @@ core and return a descriptor to it." ;;; the descriptor for layout's layout (needed when making layouts) (defvar *layout-layout*) -;;; FIXME: This information should probably be pulled out of the -;;; cross-compiler's tables at genesis time instead of inserted by -;;; hand here as a bare numeric constant. -(defconstant target-layout-length 17) +(defconstant target-layout-length + (layout-length (find-layout 'layout))) + +(defun target-layout-index (slot-name) + ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that + ;; structure slots don't have a terribly firm idea of their names. + ;; At least here if we change LAYOUT's package of definition, we + ;; only have to change one thing... + (let* ((name (find-symbol (symbol-name slot-name) "SB!KERNEL")) + (layout (find-layout 'layout)) + (dd (layout-info layout)) + (slots (dd-slots dd)) + (dsd (find name slots :key #'dsd-name))) + (aver dsd) + (dsd-index dsd))) + +(defun cold-set-layout-slot (cold-layout slot-name value) + (write-wordindexed + cold-layout + (+ sb!vm:instance-slots-offset (target-layout-index slot-name)) + value)) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. @@ -877,6 +919,7 @@ core and return a descriptor to it." (defun make-cold-layout (name length inherits depthoid nuntagged) (let ((result (allocate-boxed-object *dynamic* ;; KLUDGE: Why 1+? -- WHN 19990901 + ;; header word? -- CSR 20051204 (1+ target-layout-length) sb!vm:instance-pointer-lowtag))) (write-memory result @@ -890,72 +933,20 @@ core and return a descriptor to it." ;; Set slot 0 = the layout of the layout. (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*) - ;; Set the immediately following slots = CLOS hash values. + ;; Don't set the CLOS hash value: done in cold-init instead. ;; - ;; Note: CMU CL didn't set these in genesis, but instead arranged - ;; for them to be set at cold init time. That resulted in slightly - ;; kludgy-looking code, but there were at least two things to be - ;; said for it: - ;; 1. It put the hash values under the control of the target Lisp's - ;; RANDOM function, so that CLOS behavior would be nearly - ;; deterministic (instead of depending on the implementation of - ;; RANDOM in the cross-compilation host, and the state of its - ;; RNG when genesis begins). - ;; 2. It automatically ensured that all hash values in the target Lisp - ;; were part of the same sequence, so that we didn't have to worry - ;; about the possibility of the first hash value set in genesis - ;; being precisely equal to the some hash value set in cold init time - ;; (because the target Lisp RNG has advanced to precisely the same - ;; state that the host Lisp RNG was in earlier). - ;; Point 1 should not be an issue in practice because of the way we do our - ;; build procedure in two steps, so that the SBCL that we end up with has - ;; been created by another SBCL (whose RNG is under our control). - ;; Point 2 is more of an issue. If ANSI had provided a way to feed - ;; entropy into an RNG, we would have no problem: we'd just feed - ;; some specialized genesis-time-only pattern into the RNG state - ;; before using it. However, they didn't, so we have a slight - ;; problem. We address it by generating the hash values using a - ;; different algorithm than we use in ordinary operation. - (dotimes (i sb!kernel:layout-clos-hash-length) - (let (;; The expression here is pretty arbitrary, we just want - ;; to make sure that it's not something which is (1) - ;; evenly distributed and (2) not foreordained to arise in - ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence - ;; and show up as the CLOS-HASH value of some other - ;; LAYOUT. - ;; - ;; FIXME: This expression here can generate a zero value, - ;; and the CMU CL code goes out of its way to generate - ;; strictly positive values (even though the field is - ;; declared as an INDEX). Check that it's really OK to - ;; have zero values in the CLOS-HASH slots. - (hash-value (mod (logxor (logand (random-layout-clos-hash) 15253) - (logandc2 (random-layout-clos-hash) 15253) - 1) - ;; (The MOD here is defensive programming - ;; to make sure we never write an - ;; out-of-range value even if some joker - ;; sets LAYOUT-CLOS-HASH-MAX to other - ;; than 2^n-1 at some time in the - ;; future.) - (1+ sb!kernel:layout-clos-hash-max)))) - (write-wordindexed result - (+ i sb!vm:instance-slots-offset 1) - (make-fixnum-descriptor hash-value)))) - ;; Set other slot values. - (let ((base (+ sb!vm:instance-slots-offset - sb!kernel:layout-clos-hash-length - 1))) - ;; (Offset 0 is CLASS, "the class this is a layout for", which - ;; is uninitialized at this point.) - (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid - (write-wordindexed result (+ base 2) inherits) - (write-wordindexed result (+ base 3) depthoid) - (write-wordindexed result (+ base 4) length) - (write-wordindexed result (+ base 5) *nil-descriptor*) ; info - (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure - (write-wordindexed result (+ base 7) nuntagged)) + ;; + ;; leave CLASSOID uninitialized for now + (cold-set-layout-slot result 'invalid *nil-descriptor*) + (cold-set-layout-slot result 'inherits inherits) + (cold-set-layout-slot result 'depthoid depthoid) + (cold-set-layout-slot result 'length length) + (cold-set-layout-slot result 'info *nil-descriptor*) + (cold-set-layout-slot result 'pure *nil-descriptor*) + (cold-set-layout-slot result 'n-untagged-slots nuntagged) + (cold-set-layout-slot result 'source-location *nil-descriptor*) + (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*) (setf (gethash name *cold-layouts*) (list result @@ -975,17 +966,16 @@ core and return a descriptor to it." ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and ;; #() as INHERITS, (setq *layout-layout* *nil-descriptor*) - (setq *layout-layout* - (make-cold-layout 'layout - (number-to-core target-layout-length) - (vector-in-core) - ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT.. - (number-to-core 4) - ;; no raw slots in LAYOUT: - (number-to-core 0))) - (write-wordindexed *layout-layout* - sb!vm:instance-slots-offset - *layout-layout*) + (let ((xlayout-layout (find-layout 'layout))) + (aver (= 0 (layout-n-untagged-slots xlayout-layout))) + (setq *layout-layout* + (make-cold-layout 'layout + (number-to-core target-layout-length) + (vector-in-core) + (number-to-core (layout-depthoid xlayout-layout)) + (number-to-core 0))) + (write-wordindexed + *layout-layout* sb!vm:instance-slots-offset *layout-layout*) ;; Then we create the layouts that we'll need to make a correct INHERITS ;; vector for the layout of LAYOUT itself.. @@ -998,39 +988,26 @@ core and return a descriptor to it." (vector-in-core) (number-to-core 0) (number-to-core 0))) - (i-layout - (make-cold-layout 'instance - (number-to-core 0) - (vector-in-core t-layout) - (number-to-core 1) - (number-to-core 0))) (so-layout (make-cold-layout 'structure-object (number-to-core 1) - (vector-in-core t-layout i-layout) - (number-to-core 2) + (vector-in-core t-layout) + (number-to-core 1) (number-to-core 0))) (bso-layout (make-cold-layout 'structure!object (number-to-core 1) - (vector-in-core t-layout i-layout so-layout) - (number-to-core 3) + (vector-in-core t-layout so-layout) + (number-to-core 2) (number-to-core 0))) (layout-inherits (vector-in-core t-layout - i-layout so-layout bso-layout))) ;; ..and return to backpatch the layout of LAYOUT. (setf (fourth (gethash 'layout *cold-layouts*)) (listify-cold-inherits layout-inherits)) - (write-wordindexed *layout-layout* - ;; FIXME: hardcoded offset into layout struct - (+ sb!vm:instance-slots-offset - layout-clos-hash-length - 1 - 2) - layout-inherits))) + (cold-set-layout-slot *layout-layout* 'inherits layout-inherits)))) ;;;; interning symbols in the cold image @@ -1118,7 +1095,8 @@ core and return a descriptor to it." *cl-package* ;; ordinary case (let ((result (symbol-package symbol))) - (aver (package-ok-for-target-symbol-p result)) + (unless (package-ok-for-target-symbol-p result) + (bug "~A in bad package for target: ~A" symbol result)) result)))) ;;; Return a handle on an interned symbol. If necessary allocate the @@ -1126,8 +1104,9 @@ core and return a descriptor to it." ;;; we allocate the symbol, make sure we record a reference to the ;;; symbol in the home package so that the package gets set. (defun cold-intern (symbol - &optional - (package (symbol-package-for-target-symbol symbol))) + &key + (package (symbol-package-for-target-symbol symbol)) + (gspace *dynamic*)) (aver (package-ok-for-target-symbol-p package)) @@ -1151,7 +1130,7 @@ core and return a descriptor to it." (cold-intern-info (get symbol 'cold-intern-info))) (unless cold-intern-info (cond ((eq (symbol-package-for-target-symbol symbol) package) - (let ((handle (allocate-symbol (symbol-name symbol)))) + (let ((handle (allocate-symbol (symbol-name symbol) :gspace gspace))) (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol) (when (eq package *keyword-package*) (cold-set handle handle)) @@ -1218,34 +1197,48 @@ core and return a descriptor to it." (defun initialize-non-nil-symbols () #!+sb-doc "Initialize the cold load symbol-hacking data structures." - (let ((*cold-symbol-allocation-gspace* *static*)) - ;; Intern the others. - (dolist (symbol sb!vm:*static-symbols*) - (let* ((des (cold-intern symbol)) - (offset-wanted (sb!vm:static-symbol-offset symbol)) - (offset-found (- (descriptor-low des) - (descriptor-low *nil-descriptor*)))) - (unless (= offset-wanted offset-found) - ;; FIXME: should be fatal - (warn "Offset from ~S to ~S is ~W, not ~W" - symbol - nil - offset-found - offset-wanted)))) - ;; Establish the value of T. - (let ((t-symbol (cold-intern t))) - (cold-set t-symbol t-symbol)))) + ;; Intern the others. + (dolist (symbol sb!vm:*static-symbols*) + (let* ((des (cold-intern symbol :gspace *static*)) + (offset-wanted (sb!vm:static-symbol-offset symbol)) + (offset-found (- (descriptor-low des) + (descriptor-low *nil-descriptor*)))) + (unless (= offset-wanted offset-found) + ;; FIXME: should be fatal + (warn "Offset from ~S to ~S is ~W, not ~W" + symbol + nil + offset-found + offset-wanted)))) + ;; Establish the value of T. + (let ((t-symbol (cold-intern t :gspace *static*))) + (cold-set t-symbol t-symbol)) + ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the + ;; allocation sequences that expect it to be zero upon entrance + ;; actually find it to be so. + #!+(or x86-64 x86) + (let ((p-a-a-symbol (cold-intern 'sb!kernel:*pseudo-atomic-bits* + :gspace *static*))) + (cold-set p-a-a-symbol (make-fixnum-descriptor 0)))) ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable ;;; to be stored in *!INITIAL-LAYOUTS*. (defun cold-list-all-layouts () - (let ((result *nil-descriptor*)) + (let ((layouts nil) + (result *nil-descriptor*)) (maphash (lambda (key stuff) - (cold-push (cold-cons (cold-intern key) - (first stuff)) - result)) + (push (cons key (first stuff)) layouts)) *cold-layouts*) - result)) + (flet ((sorter (x y) + (let ((xpn (package-name (symbol-package-for-target-symbol x))) + (ypn (package-name (symbol-package-for-target-symbol y)))) + (cond + ((string= x y) (string< xpn ypn)) + (t (string< x y)))))) + (setq layouts (sort layouts #'sorter :key #'car))) + (dolist (layout layouts result) + (cold-push (cold-cons (cold-intern (car layout)) (cdr layout)) + result)))) ;;; Establish initial values for magic symbols. ;;; @@ -1266,17 +1259,8 @@ core and return a descriptor to it." ;; 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))))) - (frob sub-gc) - (frob internal-error) - (frob sb!kernel::control-stack-exhausted-error) - (frob sb!kernel::undefined-alien-variable-error) - (frob sb!kernel::undefined-alien-function-error) - (frob sb!kernel::memory-fault-error) - (frob sb!di::handle-breakpoint) - (frob sb!di::handle-fun-end-breakpoint)) + (dolist (symbol sb!vm::*c-callable-static-symbols*) + (cold-set symbol (cold-fdefinition-object (cold-intern symbol)))) (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0)) (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0)) @@ -1291,7 +1275,17 @@ core and return a descriptor to it." (let* ((cold-package (car cold-package-symbols-entry)) (symbols (cdr cold-package-symbols-entry)) (shadows (package-shadowing-symbols cold-package)) - (documentation (base-string-to-core (documentation cold-package t))) + (documentation (base-string-to-core + ;; KLUDGE: NIL punned as 0-length string. + (unless + ;; don't propagate the arbitrary + ;; docstring from host packages into + ;; the core + (or (eql cold-package *cl-package*) + (eql cold-package *keyword-package*)) + (documentation cold-package t)))) + (internal-count 0) + (external-count 0) (internal *nil-descriptor*) (external *nil-descriptor*) (imported-internal *nil-descriptor*) @@ -1333,10 +1327,14 @@ core and return a descriptor to it." (case where (:internal (if imported-p (cold-push handle imported-internal) - (cold-push handle internal))) + (progn + (cold-push handle internal) + (incf internal-count)))) (:external (if imported-p (cold-push handle imported-external) - (cold-push handle external))))))) + (progn + (cold-push handle external) + (incf external-count)))))))) (let ((r *nil-descriptor*)) (cold-push documentation r) (cold-push shadowing r) @@ -1344,7 +1342,10 @@ core and return a descriptor to it." (cold-push imported-internal r) (cold-push external r) (cold-push internal r) - (cold-push (make-make-package-args cold-package) r) + (cold-push (make-make-package-args cold-package + internal-count + external-count) + r) ;; FIXME: It would be more space-efficient to use vectors ;; instead of lists here, and space-efficiency here would be ;; nice, since it would reduce the peak memory usage in @@ -1355,6 +1356,7 @@ core and return a descriptor to it." (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects)) (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*) + (cold-set '*!initial-debug-sources* *current-debug-sources*) #!+(or x86 x86-64) (progn @@ -1363,9 +1365,9 @@ core and return a descriptor to it." (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0)) (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)))) -;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order -;;; to make a package that is similar to PKG. -(defun make-make-package-args (pkg) +;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in +;;; order to make a package that is similar to PKG. +(defun make-make-package-args (pkg internal-count external-count) (let* ((use *nil-descriptor*) (cold-nicknames *nil-descriptor*) (res *nil-descriptor*)) @@ -1394,13 +1396,14 @@ core and return a descriptor to it." (dolist (warm-nickname warm-nicknames) (cold-push (base-string-to-core warm-nickname) cold-nicknames))) - (cold-push (number-to-core (truncate (package-internal-symbol-count pkg) - 0.8)) - res) + ;; INTERNAL-COUNT and EXTERNAL-COUNT are the number of symbols that + ;; the package contains in the core. We arrange for the package + ;; symbol tables to be created somewhat larger so that they don't + ;; need to be rehashed so easily when additional symbols are + ;; interned during the warm build. + (cold-push (number-to-core (truncate internal-count 0.8)) res) (cold-push (cold-intern :internal-symbols) res) - (cold-push (number-to-core (truncate (package-external-symbol-count pkg) - 0.8)) - res) + (cold-push (number-to-core (truncate external-count 0.8)) res) (cold-push (cold-intern :external-symbols) res) (cold-push cold-nicknames res) @@ -1452,27 +1455,33 @@ core and return a descriptor to it." ;;; Given a cold representation of a function name, return a warm ;;; representation. -(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name)) +(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name)) (defun warm-fun-name (des) (let ((result - (ecase (descriptor-lowtag des) - (#.sb!vm:list-pointer-lowtag - (aver (not (cold-null des))) ; function named NIL? please no.. - ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..). - (let* ((car-des (cold-car des)) - (cdr-des (cold-cdr des)) - (cadr-des (cold-car cdr-des)) - (cddr-des (cold-cdr cdr-des))) - (aver (cold-null cddr-des)) - (list (warm-symbol car-des) - (warm-symbol cadr-des)))) - (#.sb!vm:other-pointer-lowtag - (warm-symbol des))))) + (if (symbolp des) + ;; This parallels the logic at the start of COLD-INTERN + ;; which re-homes symbols in SB-XC to COMMON-LISP. + (if (eq (symbol-package des) (find-package "SB-XC")) + (intern (symbol-name des) *cl-package*) + des) + (ecase (descriptor-lowtag des) + (#.sb!vm:list-pointer-lowtag + (aver (not (cold-null des))) ; function named NIL? please no.. + ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..). + (let* ((car-des (cold-car des)) + (cdr-des (cold-cdr des)) + (cadr-des (cold-car cdr-des)) + (cddr-des (cold-cdr cdr-des))) + (aver (cold-null cddr-des)) + (list (warm-symbol car-des) + (warm-symbol cadr-des)))) + (#.sb!vm:other-pointer-lowtag + (warm-symbol des)))))) (legal-fun-name-or-type-error result) result)) (defun cold-fdefinition-object (cold-name &optional leave-fn-raw) - (declare (type descriptor cold-name)) + (declare (type (or descriptor symbol) cold-name)) (/show0 "/cold-fdefinition-object") (let ((warm-name (warm-fun-name cold-name))) (or (gethash warm-name *cold-fdefn-objects*) @@ -1496,7 +1505,7 @@ core and return a descriptor to it." ;;; Handle the at-cold-init-time, fset-for-static-linkage operation ;;; requested by FOP-FSET. (defun static-fset (cold-name defn) - (declare (type descriptor cold-name)) + (declare (type (or descriptor symbol) cold-name)) (let ((fdefn (cold-fdefinition-object cold-name t)) (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask))) (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn) @@ -1534,12 +1543,23 @@ core and return a descriptor to it." sym nil offset desired)))))) (defun list-all-fdefn-objects () - (let ((result *nil-descriptor*)) + (let ((fdefns nil) + (result *nil-descriptor*)) (maphash (lambda (key value) - (declare (ignore key)) - (cold-push value result)) + (push (cons key value) fdefns)) *cold-fdefn-objects*) - result)) + (flet ((sorter (x y) + (let* ((xbn (fun-name-block-name x)) + (ybn (fun-name-block-name y)) + (xbnpn (package-name (symbol-package-for-target-symbol xbn))) + (ybnpn (package-name (symbol-package-for-target-symbol ybn)))) + (cond + ((eql xbn ybn) (consp x)) + ((string= xbn ybn) (string< xbnpn ybnpn)) + (t (string< xbn ybn)))))) + (setq fdefns (sort fdefns #'sorter :key #'car))) + (dolist (fdefn fdefns result) + (cold-push (cdr fdefn) result)))) ;;;; fixups and related stuff @@ -1587,6 +1607,13 @@ core and return a descriptor to it." (subseq line (1+ p2))) (values (parse-integer line :end p1 :radix 16) (subseq line (1+ p2)))) + ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us + ;; _function but dlsym expects us to look up + ;; function, without the leading _ . Therefore, we + ;; strip it off here. + #!+darwin + (when (equal (char name 0) #\_) + (setf name (subseq name 1))) (multiple-value-bind (old-value found) (gethash name *cold-foreign-symbol-table*) (when (and found @@ -1594,7 +1621,19 @@ core and return a descriptor to it." (warn "redefining ~S from #X~X to #X~X" name old-value value))) (/show "adding to *cold-foreign-symbol-table*:" name value) - (setf (gethash name *cold-foreign-symbol-table*) value)))))) + (setf (gethash name *cold-foreign-symbol-table*) value) + #!+win32 + (let ((at-position (position #\@ name))) + (when at-position + (let ((name (subseq name 0 at-position))) + (multiple-value-bind (old-value found) + (gethash name *cold-foreign-symbol-table*) + (when (and found + (not (= old-value value))) + (warn "redefining ~S from #X~X to #X~X" + name old-value value))) + (setf (gethash name *cold-foreign-symbol-table*) + value))))))))) (values)) ;; PROGN (defun cold-foreign-symbol-address (name) @@ -1634,37 +1673,44 @@ core and return a descriptor to it." ;;; The x86 port needs to store code fixups along with code objects if ;;; they are to be moved, so fixups for code objects in the dynamic ;;; heap need to be noted. -#!+(or x86 x86-64) +#!+x86 (defvar *load-time-code-fixups*) -#!+(or x86 x86-64) -(defun note-load-time-code-fixup (code-object offset value kind) +#!+x86 +(defun note-load-time-code-fixup (code-object offset) ;; If CODE-OBJECT might be moved (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) dynamic-core-space-id) - ;; FIXME: pushed thing should be a structure, not just a list - (push (list code-object offset value kind) *load-time-code-fixups*)) + (push offset (gethash (descriptor-bits code-object) + *load-time-code-fixups* + nil))) (values)) -#!+(or x86 x86-64) +#!+x86 (defun output-load-time-code-fixups () - (dolist (fixups *load-time-code-fixups*) - (let ((code-object (first fixups)) - (offset (second fixups)) - (value (third fixups)) - (kind (fourth fixups))) - (cold-push (cold-cons - (cold-intern :load-time-code-fixup) - (cold-cons - code-object - (cold-cons - (number-to-core offset) - (cold-cons - (number-to-core value) - (cold-cons - (cold-intern kind) - *nil-descriptor*))))) - *current-reversed-cold-toplevels*)))) + (let ((fixup-infos nil)) + (maphash + (lambda (code-object-address fixup-offsets) + (push (cons code-object-address fixup-offsets) fixup-infos)) + *load-time-code-fixups*) + (setq fixup-infos (sort fixup-infos #'< :key #'car)) + (dolist (fixup-info fixup-infos) + (let ((code-object-address (car fixup-info)) + (fixup-offsets (cdr fixup-info))) + (let ((fixup-vector + (allocate-vector-object + *dynamic* sb!vm:n-word-bits (length fixup-offsets) + sb!vm:simple-array-unsigned-byte-32-widetag))) + (do ((index sb!vm:vector-data-offset (1+ index)) + (fixups fixup-offsets (cdr fixups))) + ((null fixups)) + (write-wordindexed fixup-vector index + (make-random-descriptor (car fixups)))) + ;; KLUDGE: The fixup vector is stored as the first constant, + ;; not as a separately-named slot. + (write-wordindexed (make-random-descriptor code-object-address) + sb!vm:code-constants-offset + fixup-vector)))))) ;;; Given a pointer to a code object and an offset relative to the ;;; tail of the code object's header, return an offset relative to the @@ -1730,32 +1776,44 @@ core and return a descriptor to it." (ecase kind (:load (setf (bvref-32 gspace-bytes gspace-byte-offset) - (logior (ash (ldb (byte 11 0) value) 1) - (logand (bvref-32 gspace-bytes gspace-byte-offset) - #xffffc000)))) + (logior (mask-field (byte 18 14) + (bvref-32 gspace-bytes gspace-byte-offset)) + (if (< value 0) + (1+ (ash (ldb (byte 13 0) value) 1)) + (ash (ldb (byte 13 0) value) 1))))) + (:load11u + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (mask-field (byte 18 14) + (bvref-32 gspace-bytes gspace-byte-offset)) + (if (< value 0) + (1+ (ash (ldb (byte 10 0) value) 1)) + (ash (ldb (byte 11 0) value) 1))))) (:load-short (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) - (setf (bvref-32 gspace-bytes gspace-byte-offset) - (logior (ash low-bits 17) - (logand (bvref-32 gspace-bytes gspace-byte-offset) - #xffe0ffff))))) + (assert (<= 0 low-bits (1- (ash 1 4))))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (dpb (ldb (byte 4 0) value) + (byte 4 1) + (ldb (byte 1 4) value)) 17) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe0ffff)))) (:hi (setf (bvref-32 gspace-bytes gspace-byte-offset) - (logior (ash (ldb (byte 5 13) value) 16) + (logior (mask-field (byte 11 21) + (bvref-32 gspace-bytes gspace-byte-offset)) + (ash (ldb (byte 5 13) value) 16) (ash (ldb (byte 2 18) value) 14) (ash (ldb (byte 2 11) value) 12) (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand (bvref-32 gspace-bytes gspace-byte-offset) - #xffe00000)))) + (ldb (byte 1 31) value)))) (:branch (let ((bits (ldb (byte 9 2) value))) (assert (zerop (ldb (byte 2 0) value))) (setf (bvref-32 gspace-bytes gspace-byte-offset) (logior (ash bits 3) - (logand (bvref-32 gspace-bytes gspace-byte-offset) - #xffe0e002))))))) + (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset)) + (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset)) + (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset)))))))) (:mips (ecase kind (:jump @@ -1767,27 +1825,35 @@ core and return a descriptor to it." (setf (bvref-32 gspace-bytes gspace-byte-offset) (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset)) - (+ (ash value -16) - (if (logbitp 15 value) 1 0))))) + (ash (1+ (ldb (byte 17 15) value)) -1)))) (:addi (setf (bvref-32 gspace-bytes gspace-byte-offset) (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset)) (ldb (byte 16 0) value)))))) + ;; FIXME: PowerPC Fixups are not fully implemented. The bit + ;; here starts to set things up to work properly, but there + ;; needs to be corresponding code in ppc-vm.lisp (:ppc - (ecase kind - (:ba - (setf (bvref-32 gspace-bytes gspace-byte-offset) - (dpb (ash value -2) (byte 24 2) - (bvref-32 gspace-bytes gspace-byte-offset)))) - (:ha - (let* ((h (ldb (byte 16 16) value)) - (l (ldb (byte 16 0) value))) - (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) - (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) - (:l - (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) - (ldb (byte 16 0) value))))) + (ecase kind + (:ba + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (dpb (ash value -2) (byte 24 2) + (bvref-32 gspace-bytes gspace-byte-offset)))) + (:ha + (let* ((un-fixed-up (bvref-16 gspace-bytes + (+ gspace-byte-offset 2))) + (fixed-up (+ un-fixed-up value)) + (h (ldb (byte 16 16) fixed-up)) + (l (ldb (byte 16 0) fixed-up))) + (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (:l + (let* ((un-fixed-up (bvref-16 gspace-bytes + (+ gspace-byte-offset 2))) + (fixed-up (+ un-fixed-up value))) + (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) + (ldb (byte 16 0) fixed-up)))))) (:sparc (ecase kind (:call @@ -1803,6 +1869,11 @@ core and return a descriptor to it." (byte 10 0) (bvref-32 gspace-bytes gspace-byte-offset)))))) ((:x86 :x86-64) + ;; XXX: Note that un-fixed-up is read via bvref-word, which is + ;; 64 bits wide on x86-64, but the fixed-up value is written + ;; via bvref-32. This would make more sense if we supported + ;; :absolute64 fixups, but apparently the cross-compiler + ;; doesn't dump them. (let* ((un-fixed-up (bvref-word gspace-bytes gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) @@ -1824,11 +1895,17 @@ core and return a descriptor to it." ;; (not beyond it). It would be good to add an ;; explanation of why that's true, or an assertion that ;; it's really true, or both. + ;; + ;; One possible explanation is that all absolute fixups + ;; point either within the code object, within the + ;; runtime, within read-only or static-space, or within + ;; the linkage-table space. In all x86 configurations, + ;; these areas are prior to the start of dynamic space, + ;; where all the code-objects are loaded. + #!+x86 (unless (< fixed-up code-object-start-addr) (note-load-time-code-fixup code-object - after-header - value - kind)))) + after-header)))) (:relative ; (used for arguments to X86 relative CALL instruction) (let ((fixed-up (- (+ value un-fixed-up) gspace-byte-address @@ -1840,10 +1917,9 @@ core and return a descriptor to it." ;; object, which is to say all relative fixups, since ;; relative addressing within a code object never needs ;; a fixup. + #!+x86 (note-load-time-code-fixup code-object - after-header - value - kind)))))))) + after-header)))))))) (values)) (defun resolve-assembler-fixups () @@ -1853,20 +1929,50 @@ core and return a descriptor to it." (when value (do-cold-fixup (second fixup) (third fixup) value (fourth fixup)))))) +#!+sb-dynamic-core +(progn + (defparameter *dyncore-address* sb!vm::linkage-table-space-start) + (defparameter *dyncore-linkage-keys* nil) + (defparameter *dyncore-table* (make-hash-table :test 'equal)) + + (defun dyncore-note-symbol (symbol-name datap) + "Register a symbol and return its address in proto-linkage-table." + (let ((key (cons symbol-name datap))) + (symbol-macrolet ((entry (gethash key *dyncore-table*))) + (or entry + (setf entry + (prog1 *dyncore-address* + (push key *dyncore-linkage-keys*) + (incf *dyncore-address* sb!vm::linkage-table-entry-size)))))))) + ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in ;;; target-load.lisp refers to. (defun foreign-symbols-to-core () + (let ((symbols nil) + (result *nil-descriptor*)) + #!-sb-dynamic-core + (progn + (maphash (lambda (symbol value) + (push (cons symbol value) symbols)) + *cold-foreign-symbol-table*) + (setq symbols (sort symbols #'string< :key #'car)) + (dolist (symbol symbols) + (cold-push (cold-cons (base-string-to-core (car symbol)) + (number-to-core (cdr symbol))) + result))) + (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result) + #!+sb-dynamic-core + (let ((runtime-linking-list *nil-descriptor*)) + (dolist (symbol *dyncore-linkage-keys*) + (cold-push (cold-cons (base-string-to-core (car symbol)) + (cdr symbol)) + runtime-linking-list)) + (cold-set (cold-intern 'sb!vm::*required-runtime-c-symbols*) + runtime-linking-list))) (let ((result *nil-descriptor*)) - (maphash (lambda (symbol value) - (cold-push (cold-cons (base-string-to-core symbol) - (number-to-core value)) - result)) - *cold-foreign-symbol-table*) - (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)) - (let ((result *nil-descriptor*)) - (dolist (rtn *cold-assembler-routines*) + (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car)) (cold-push (cold-cons (cold-intern (car rtn)) (number-to-core (cdr rtn))) result)) @@ -1882,8 +1988,6 @@ core and return a descriptor to it." ;; modified. (copy-seq *fop-funs*)) -(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 @@ -1927,8 +2031,7 @@ core and return a descriptor to it." (defun cold-load (filename) #!+sb-doc "Load the file named by FILENAME into the cold load image being built." - (let* ((*normal-fop-funs* *fop-funs*) - (*fop-funs* *cold-fop-funs*) + (let* ((*fop-funs* *cold-fop-funs*) (*cold-load-filename* (etypecase filename (string filename) (pathname (namestring filename))))) @@ -1942,17 +2045,8 @@ core and return a descriptor to it." (define-cold-fop (fop-short-character) (make-character-descriptor (read-byte-arg))) -(define-cold-fop (fop-empty-list) *nil-descriptor*) -(define-cold-fop (fop-truth) (cold-intern t)) - -(define-cold-fop (fop-normal-load :stackp nil) - (setq *fop-funs* *normal-fop-funs*)) - -(define-fop (fop-maybe-cold-load 82 :stackp nil) - (when *cold-load-filename* - (setq *fop-funs* *cold-fop-funs*))) - -(define-cold-fop (fop-maybe-cold-load :stackp nil)) +(define-cold-fop (fop-empty-list) nil) +(define-cold-fop (fop-truth) t) (clone-cold-fop (fop-struct) (fop-small-struct) @@ -1963,7 +2057,10 @@ core and return a descriptor to it." (layout (pop-stack)) (nuntagged (descriptor-fixnum - (read-wordindexed layout (+ sb!vm:instance-slots-offset 16)))) + (read-wordindexed + layout + (+ sb!vm:instance-slots-offset + (target-layout-index 'n-untagged-slots))))) (ntagged (- size nuntagged))) (write-memory result (make-other-immediate-descriptor size sb!vm:instance-header-widetag)) @@ -2048,14 +2145,14 @@ core and return a descriptor to it." (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-string-as-bytes *fasl-input-stream* string) - (cold-intern (intern string package)))) + (intern string package))) (macrolet ((frob (name pname-len package-len) `(define-cold-fop (,name) (let ((index (read-arg ,package-len))) (push-fop-table (cold-load-symbol (read-arg ,pname-len) - (svref *current-fop-table* index))))))) + (ref-fop-table index))))))) (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes) (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes) (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1) @@ -2077,6 +2174,15 @@ core and return a descriptor to it." (let ((symbol-des (allocate-symbol name))) (push-fop-table symbol-des)))) +;;;; cold fops for loading packages + +(clone-cold-fop (fop-named-package-save :stackp nil) + (fop-small-named-package-save) + (let* ((size (clone-arg)) + (name (make-string size))) + (read-string-as-bytes *fasl-input-stream* name) + (push-fop-table (find-package name)))) + ;;;; cold fops for loading lists ;;; Make a list of the top LENGTH things on the fop stack. The last @@ -2223,19 +2329,19 @@ core and return a descriptor to it." (write-wordindexed result sb!vm:array-data-slot data-vector) (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*) (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*) + (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*) (let ((total-elements 1)) (dotimes (axis rank) (let ((dim (pop-stack))) - (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag) - (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag)) + (unless (is-fixnum-lowtag (descriptor-lowtag dim)) (error "non-fixnum dimension? (~S)" dim)) (setf total-elements (* total-elements (logior (ash (descriptor-high dim) (- descriptor-low-bits - (1- sb!vm:n-lowtag-bits))) + sb!vm:n-fixnum-tag-bits)) (ash (descriptor-low dim) - (- 1 sb!vm:n-lowtag-bits))))) + sb!vm:n-fixnum-tag-bits)))) (write-wordindexed result (+ sb!vm:array-dimensions-offset axis) dim))) @@ -2295,7 +2401,7 @@ core and return a descriptor to it." *nil-descriptor*))) *current-reversed-cold-toplevels*) (setf *load-time-value-counter* (1+ counter)) - (make-descriptor 0 0 nil counter))) + (make-descriptor 0 0 :load-time-value counter))) (defun finalize-load-time-value-noise () (cold-set (cold-intern '*!load-time-values*) @@ -2313,17 +2419,17 @@ core and return a descriptor to it." ;;;; cold fops for fixing up circularities (define-cold-fop (fop-rplaca :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) (define-cold-fop (fop-rplacd :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) (define-cold-fop (fop-svset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (+ idx @@ -2333,7 +2439,7 @@ core and return a descriptor to it." (pop-stack)))) (define-cold-fop (fop-structset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) @@ -2366,6 +2472,10 @@ core and return a descriptor to it." (setf (gethash warm-name *cold-fset-warm-names*) t)) (static-fset cold-name fn))) +(define-cold-fop (fop-note-debug-source :pushp nil) + (let ((debug-source (pop-stack))) + (cold-push debug-source *current-debug-sources*))) + (define-cold-fop (fop-fdefinition) (cold-fdefinition-object (pop-stack))) @@ -2445,7 +2555,8 @@ core and return a descriptor to it." (write-wordindexed code slot value))) (define-cold-fop (fop-fun-entry) - (let* ((type (pop-stack)) + (let* ((info (pop-stack)) + (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) @@ -2502,6 +2613,7 @@ core and return a descriptor to it." (write-wordindexed fn sb!vm:simple-fun-name-slot name) (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist) (write-wordindexed fn sb!vm:simple-fun-type-slot type) + (write-wordindexed fn sb!vm::simple-fun-info-slot info) fn)) (define-cold-fop (fop-foreign-fixup) @@ -2510,6 +2622,12 @@ core and return a descriptor to it." (len (read-byte-arg)) (sym (make-string len))) (read-string-as-bytes *fasl-input-stream* sym) + #!+sb-dynamic-core + (let ((offset (read-word-arg)) + (value (dyncore-note-symbol sym nil))) + (do-cold-fixup code-object offset value kind)) + #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object) + #!-sb-dynamic-core (let ((offset (read-word-arg)) (value (cold-foreign-symbol-address sym))) (do-cold-fixup code-object offset value kind)) @@ -2521,11 +2639,19 @@ core and return a descriptor to it." (code-object (pop-stack)) (len (read-byte-arg)) (sym (make-string len))) + #!-sb-dynamic-core (declare (ignore code-object)) (read-string-as-bytes *fasl-input-stream* sym) - (maphash (lambda (k v) - (format *error-output* "~&~S = #X~8X~%" k v)) - *cold-foreign-symbol-table*) - (error "shared foreign symbol in cold load: ~S (~S)" sym kind))) + #!+sb-dynamic-core + (let ((offset (read-word-arg)) + (value (dyncore-note-symbol sym t))) + (do-cold-fixup code-object offset value kind) + code-object) + #!-sb-dynamic-core + (progn + (maphash (lambda (k v) + (format *error-output* "~&~S = #X~8X~%" k v)) + *cold-foreign-symbol-table*) + (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))) (define-cold-fop (fop-assembler-code) (let* ((length (read-word-arg)) @@ -2583,6 +2709,30 @@ core and return a descriptor to it." (do-cold-fixup code-object offset value kind) code-object)) +;;;; sanity checking space layouts + +(defun check-spaces () + ;;; Co-opt type machinery to check for intersections... + (let (types) + (flet ((check (start end space) + (unless (< start end) + (error "Bogus space: ~A" space)) + (let ((type (specifier-type `(integer ,start ,end)))) + (dolist (other types) + (unless (eq *empty-type* (type-intersection (cdr other) type)) + (error "Space overlap: ~A with ~A" space (car other)))) + (push (cons space type) types)))) + (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only) + (check sb!vm:static-space-start sb!vm:static-space-end :static) + #!+gencgc + (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic) + #!-gencgc + (progn + (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0) + (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1)) + #!+linkage-table + (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table)))) + ;;;; emitting C header file (defun tailwise-equal (string tail) @@ -2594,7 +2744,7 @@ core and return a descriptor to it." (dolist (line '("This is a machine-generated file. Please do not edit it by hand." "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)" - "" + nil "This file contains low-level information about the" "internals of a particular version and configuration" "of SBCL. It is used by the C compiler to create a runtime" @@ -2602,17 +2752,31 @@ core and return a descriptor to it." "operating system's native format, which can then be used to" "load and run 'core' files, which are basically programs" "in SBCL's own format.")) - (format t " * ~A~%" line)) + (format t " *~@[ ~A~]~%" line)) (format t " */~%")) +(defun c-name (string &optional strip) + (delete #\+ + (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%))) + (remove-if (lambda (c) (position c strip)) + string)))) + +(defun c-symbol-name (symbol &optional strip) + (c-name (symbol-name symbol) strip)) + +(defun write-makefile-features () + ;; propagating *SHEBANG-FEATURES* into the Makefiles + (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name + sb-cold:*shebang-features*) + #'string<)) + (format t "LISP_FEATURE_~A=1~%" shebang-feature-name))) + (defun write-config-h () ;; propagating *SHEBANG-FEATURES* into C-level #define's - (dolist (shebang-feature-name (sort (mapcar #'symbol-name + (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name sb-cold:*shebang-features*) #'string<)) - (format t - "#define LISP_FEATURE_~A~%" - (substitute #\_ #\- shebang-feature-name))) + (format t "#define LISP_FEATURE_~A~%" shebang-feature-name)) (terpri) ;; and miscellaneous constants (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer) @@ -2630,7 +2794,7 @@ core and return a descriptor to it." (defun write-constants-h () ;; writing entire families of named constants (let ((constants nil)) - (dolist (package-name '(;; Even in CMU CL, constants from VM + (dolist (package-name '( ;; Even in CMU CL, constants from VM ;; were automatically propagated ;; into the runtime. "SB!VM" @@ -2641,11 +2805,12 @@ core and return a descriptor to it." (do-external-symbols (symbol (find-package package-name)) (when (constantp symbol) (let ((name (symbol-name symbol))) - (labels (;; shared machinery - (record (string priority) + (labels ( ;; shared machinery + (record (string priority suffix) (push (list string priority (symbol-value symbol) + suffix (documentation symbol 'variable)) constants)) ;; machinery for old-style CMU CL Lisp-to-C @@ -2657,7 +2822,8 @@ core and return a descriptor to it." 'simple-string prefix (delete #\- (string-capitalize string))) - priority)) + priority + "")) (maybe-record-with-munged-name (tail prefix priority) (when (tailwise-equal name tail) (record-with-munged-name prefix @@ -2666,24 +2832,31 @@ core and return a descriptor to it." (length tail))) priority))) ;; machinery for new-style SBCL Lisp-to-C naming - (record-with-translated-name (priority) - (record (substitute #\_ #\- name) - priority)) - (maybe-record-with-translated-name (suffixes priority) + (record-with-translated-name (priority large) + (record (c-name name) priority + (if large + #!+(and win32 x86-64) "LLU" + #!-(and win32 x86-64) "LU" + ""))) + (maybe-record-with-translated-name (suffixes priority &key large) (when (some (lambda (suffix) (tailwise-equal name suffix)) suffixes) - (record-with-translated-name priority)))) - + (record-with-translated-name priority large)))) (maybe-record-with-translated-name '("-LOWTAG") 0) - (maybe-record-with-translated-name '("-WIDETAG") 1) + (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1) (maybe-record-with-munged-name "-FLAG" "flag_" 2) (maybe-record-with-munged-name "-TRAP" "trap_" 3) (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) - (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6) - (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7) - (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8)))))) + (maybe-record-with-translated-name '("-SIZE") 6) + (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES" + "-CARD-BYTES" "-GRANULARITY") + 7 :large t) + (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8) + (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9) + (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9) + (maybe-record-with-translated-name '("-GENERATION+") 10)))))) ;; KLUDGE: these constants are sort of important, but there's no ;; pleasing way to inform the code above about them. So we fake ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply @@ -2694,61 +2867,38 @@ core and return a descriptor to it." sb!vm:n-lowtag-bits sb!vm:lowtag-mask sb!vm:n-widetag-bits sb!vm:widetag-mask sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask)) - (push (list (substitute #\_ #\- (symbol-name c)) + (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) + "" nil) constants)) ;; One more symbol that doesn't fit into the code above. - (flet ((translate (name) - (delete #\+ (substitute #\_ #\- name)))) - (let ((c 'sb!impl::+magic-hash-vector-value+)) - (push (list (translate (symbol-name c)) - 9 - (symbol-value c) - nil) - constants))) - + (let ((c 'sb!impl::+magic-hash-vector-value+)) + (push (list (c-symbol-name c) + 9 + (symbol-value c) + #!+(and win32 x86-64) "LLU" + #!-(and win32 x86-64) "LU" + nil) + constants)) (setf constants (sort constants (lambda (const1 const2) (if (= (second const1) (second const2)) - (< (third const1) (third const2)) + (if (= (third const1) (third const2)) + (string< (first const1) (first const2)) + (< (third const1) (third const2))) (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) (dolist (const constants) - (destructuring-bind (name priority value doc) const + (destructuring-bind (name priority value suffix doc) const (unless (= prev-priority priority) (terpri) (setf prev-priority priority)) - (format t "#define ~A " name) - (format t - ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two - ;; different kinds of values here, (1) small codes - ;; and (2) machine addresses. The small codes can be - ;; dumped as bare integer values. The large machine - ;; addresses might cause problems if they're large - ;; and represented as (signed) C integers, so we - ;; want to force them to be unsigned. We do that by - ;; wrapping them in the LISPOBJ macro. (We could do - ;; it with a bare "(unsigned)" cast, except that - ;; this header file is used not only in C files, but - ;; also in assembly files, which don't understand - ;; the cast syntax. The LISPOBJ macro goes away in - ;; assembly files, but that shouldn't matter because - ;; we don't do arithmetic on address constants in - ;; assembly files. See? It really is a kludge..) -- - ;; WHN 2000-10-18 - (let (;; cutoff for treatment as a small code - (cutoff (expt 2 16))) - (cond ((minusp value) - (error "stub: negative values unsupported")) - ((< value cutoff) - "~D") - (t - "LISPOBJ(~D)"))) - value) - (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) + (when (minusp value) + (error "stub: negative values unsupported")) + (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc)))) (terpri)) ;; writing information about internal errors @@ -2759,8 +2909,17 @@ core and return a descriptor to it." ;; interr.lisp) -- APD, 2002-03-05 (unless (eq nil (car current-error)) (format t "#define ~A ~D~%" - (substitute #\_ #\- (symbol-name (car current-error))) - i))))) + (c-symbol-name (car current-error)) + i)))) + (format t "#define INTERNAL_ERROR_NAMES \\~%~{~S~#[~:;, \\~%~]~}~%" + (map 'list #'cdr internal-errors))) + (terpri) + + ;; I'm not really sure why this is in SB!C, since it seems + ;; conceptually like something that belongs to SB!VM. In any case, + ;; it's needed C-side. + (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*) + (terpri) ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between @@ -2778,52 +2937,83 @@ core and return a descriptor to it." ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant ;; [possibly applicable to other platforms]) + #!+sb-safepoint + (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%" + sb!vm:gc-safepoint-page-addr) + (dolist (symbol '(sb!vm::float-traps-byte sb!vm::float-exceptions-byte sb!vm::float-sticky-bits sb!vm::float-rounding-mode)) (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%" - (substitute #\_ #\- (symbol-name symbol)) + (c-symbol-name symbol) (sb!xc:byte-position (symbol-value symbol))) (format t "#define ~A_MASK 0x~X /* ~:*~A */~%" - (substitute #\_ #\- (symbol-name symbol)) + (c-symbol-name symbol) (sb!xc:mask-field (symbol-value symbol) -1)))) - +#!+sb-ldb +(defun write-tagnames-h (&optional (out *standard-output*)) + (labels + ((pretty-name (symbol strip) + (let ((name (string-downcase symbol))) + (substitute #\Space #\- + (subseq name 0 (- (length name) (length strip)))))) + (list-sorted-tags (tail) + (loop for symbol being the external-symbols of "SB!VM" + when (and (constantp symbol) + (tailwise-equal (string symbol) tail)) + collect symbol into tags + finally (return (sort tags #'< :key #'symbol-value)))) + (write-tags (kind limit ash-count) + (format out "~%static const char *~(~A~)_names[] = {~%" + (subseq kind 1)) + (let ((tags (list-sorted-tags kind))) + (dotimes (i limit) + (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count)) + (format out " \"~A\"" (pretty-name (pop tags) kind)) + (format out " \"unknown [~D]\"" i)) + (unless (eql i (1- limit)) + (write-string "," out)) + (terpri out))) + (write-line "};" out))) + (write-tags "-LOWTAG" sb!vm:lowtag-limit 0) + ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG + ;; ending with the same 2 bits. (#b10) + (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2)) + (values)) (defun write-primitive-object (obj) ;; writing primitive object layouts - (format t "#ifndef LANGUAGE_ASSEMBLY~2%") - (format t - "struct ~A {~%" - (substitute #\_ #\- - (string-downcase (string (sb!vm:primitive-object-name 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]~];~%" - (getf (sb!vm:slot-options slot) :c-type "lispobj") - (substitute #\_ #\- - (string-downcase (string (sb!vm:slot-name slot)))) - (sb!vm:slot-rest-p slot))) + (format t "#ifndef LANGUAGE_ASSEMBLY~2%") + (format t + "struct ~A {~%" + (c-name (string-downcase (string (sb!vm:primitive-object-name 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]~];~%" + (getf (sb!vm:slot-options slot) :c-type "lispobj") + (c-name (string-downcase (string (sb!vm:slot-name slot)))) + (sb!vm:slot-rest-p slot))) (format t "};~2%") - (format t "#else /* LANGUAGE_ASSEMBLY */~2%") - (let ((name (sb!vm:primitive-object-name obj)) - (lowtag (eval (sb!vm:primitive-object-lowtag obj)))) - (when lowtag - (dolist (slot (sb!vm:primitive-object-slots obj)) - (format t "#define ~A_~A_OFFSET ~D~%" - (substitute #\_ #\- (string name)) - (substitute #\_ #\- (string (sb!vm:slot-name slot))) - (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) - (terpri))) - (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) + (format t "#else /* LANGUAGE_ASSEMBLY */~2%") + (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%") + (format t " * so they work directly on tagged addresses. */~2%") + (let ((name (sb!vm:primitive-object-name obj)) + (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj)) + 0))) + (dolist (slot (sb!vm:primitive-object-slots obj)) + (format t "#define ~A_~A_OFFSET ~D~%" + (c-symbol-name name) + (c-symbol-name (sb!vm:slot-name slot)) + (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) + (terpri)) + (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) (defun write-structure-object (dd) (flet ((cstring (designator) - (substitute - #\_ #\% - (substitute #\_ #\- (string-downcase (string designator)))))) + (c-name (string-downcase (string designator))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "struct ~A {~%" (cstring (dd-name dd))) (format t " lispobj header;~%") @@ -2832,9 +3022,9 @@ core and return a descriptor to it." (when (eq t (dsd-raw-type slot)) (format t " lispobj ~A;~%" (cstring (dsd-name slot))))) (unless (oddp (+ (dd-length dd) (dd-raw-length dd))) - (format t " long raw_slot_padding;~%")) + (format t " lispobj raw_slot_padding;~%")) (dotimes (n (dd-raw-length dd)) - (format t " long raw~D;~%" (- (dd-raw-length dd) n 1))) + (format t " lispobj raw~D;~%" (- (dd-raw-length dd) n 1))) (format t "};~2%") (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))) @@ -2843,10 +3033,9 @@ core and return a descriptor to it." ;; FIXME: It would be nice to use longer names than NIL and ;; (particularly) T in #define statements. (format t "#define ~A LISPOBJ(0x~X)~%" - (substitute #\_ #\- - (remove-if (lambda (char) - (member char '(#\% #\* #\. #\!))) - (symbol-name symbol))) + ;; FIXME: It would be nice not to need to strip anything + ;; that doesn't get stripped always by C-SYMBOL-NAME. + (c-symbol-name symbol "%*.!") (if *static* ; if we ran GENESIS ;; We actually ran GENESIS, use the real value. (descriptor-bits (cold-intern symbol)) @@ -2903,7 +3092,9 @@ initially undefined function references:~2%") (setf undefs (sort undefs #'string< :key #'fun-name-block-name)) (dolist (name undefs) - (format t "~S~%" name))) + (format t "~8,'0X: ~S~%" + (descriptor-bits (gethash name *cold-fdefn-objects*)) + name))) (format t "~%~|~%layout names:~2%") (collect ((stuff)) @@ -2936,6 +3127,7 @@ initially undefined function references:~2%") (defconstant build-id-core-entry-type-code 3899) (defconstant new-directory-core-entry-type-code 3861) (defconstant initial-fun-core-entry-type-code 3863) +(defconstant page-table-core-entry-type-code 3880) (defconstant end-core-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) @@ -2954,17 +3146,17 @@ initially undefined function references:~2%") (force-output *core-file*) (file-position *core-file* (round-up (file-position *core-file*) - sb!c:*backend-page-size*))) + sb!c:*backend-page-bytes*))) (defun output-gspace (gspace) (force-output *core-file*) (let* ((posn (file-position *core-file*)) (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*))) + (pages (ceiling bytes sb!c:*backend-page-bytes*)) + (total-bytes (* pages sb!c:*backend-page-bytes*))) (file-position *core-file* - (* sb!c:*backend-page-size* (1+ *data-page*))) + (* sb!c:*backend-page-bytes* (1+ *data-page*))) (format t "writing ~S byte~:P [~S page~:P] from ~S~%" total-bytes @@ -2994,7 +3186,7 @@ initially undefined function references:~2%") (write-word (gspace-free-word-index gspace)) (write-word *data-page*) (multiple-value-bind (floor rem) - (floor (gspace-byte-address gspace) sb!c:*backend-page-size*) + (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*) (aver (zerop rem)) (write-word floor)) (write-word pages) @@ -3102,7 +3294,10 @@ initially undefined function references:~2%") symbol-table-file-name core-file-name map-file-name - c-header-dir-name) + c-header-dir-name + #+nil (list-objects t)) + #!+sb-dynamic-core + (declare (ignorable symbol-table-file-name)) (format t "~&beginning GENESIS, ~A~%" @@ -3116,11 +3311,19 @@ initially undefined function references:~2%") (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal))) + #!-sb-dynamic-core (when core-file-name (if symbol-table-file-name (load-cold-foreign-symbol-table symbol-table-file-name) (error "can't output a core file without symbol table file input"))) + #!+sb-dynamic-core + (progn + (setf (gethash (extern-alien-name "undefined_tramp") + *cold-foreign-symbol-table*) + (dyncore-note-symbol "undefined_tramp" nil)) + (dyncore-note-symbol "undefined_alien_function" nil)) + ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure ;; that there'll be someplace for our output files to go when @@ -3138,6 +3341,8 @@ initially undefined function references:~2%") (do-all-symbols (sym) (remprop sym 'cold-intern-info)) + (check-spaces) + (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0)) (*load-time-value-counter* 0) (*cold-fdefn-objects* (make-hash-table :test 'equal)) @@ -3155,12 +3360,13 @@ initially undefined function references:~2%") #!-gencgc sb!vm:dynamic-0-space-start)) (*nil-descriptor* (make-nil-descriptor)) (*current-reversed-cold-toplevels* *nil-descriptor*) + (*current-debug-sources* *nil-descriptor*) (*unbound-marker* (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)) *cold-assembler-fixups* *cold-assembler-routines* - #!+(or x86 x86-64) *load-time-code-fixups*) + #!+x86 (*load-time-code-fixups* (make-hash-table))) ;; Prepare for cold load. (initialize-non-nil-symbols) @@ -3213,7 +3419,7 @@ initially undefined function references:~2%") ;; nothing if NAME is NIL. (chill (name) (when name - (cold-intern (intern name package) package)))) + (cold-intern (intern name package) :package package)))) (mapc-on-tree #'chill (sb-cold:package-data-export pd)) (mapc #'chill (sb-cold:package-data-reexport pd)) (dolist (sublist (sb-cold:package-data-import-from pd)) @@ -3228,7 +3434,7 @@ initially undefined function references:~2%") ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?") (resolve-assembler-fixups) - #!+(or x86 x86-64) (output-load-time-code-fixups) + #!+x86 (output-load-time-code-fixups) (foreign-symbols-to-core) (finish-symbols) (/show "back from FINISH-SYMBOLS") @@ -3243,10 +3449,6 @@ initially undefined function references:~2%") (allocate-cold-descriptor *static* 0 sb!vm:even-fixnum-lowtag)) - (cold-set 'sb!vm:*initial-dynamic-space-free-pointer* - (allocate-cold-descriptor *dynamic* - 0 - sb!vm:even-fixnum-lowtag)) (/show "done setting free pointers") ;; Write results to files. @@ -3262,7 +3464,7 @@ initially undefined function references:~2%") (with-open-file (*standard-output* fn :if-exists :supersede :direction :output) (write-boilerplate) - (let ((n (substitute #\_ #\- (string-upcase ,name)))) + (let ((n (c-name (string-upcase ,name)))) (format t "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%" @@ -3271,13 +3473,15 @@ initially undefined function references:~2%") (format t "#endif /* SBCL_GENESIS_~A */~%" (string-upcase ,name)))))) - (when map-file-name - (with-open-file (*standard-output* map-file-name - :direction :output - :if-exists :supersede) - (write-map))) + (when map-file-name + (with-open-file (*standard-output* map-file-name + :direction :output + :if-exists :supersede) + (write-map))) (out-to "config" (write-config-h)) (out-to "constants" (write-constants-h)) + #!+sb-ldb + (out-to "tagnames" (write-tagnames-h)) (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< :key (lambda (obj) (symbol-name @@ -3302,5 +3506,11 @@ initially undefined function references:~2%") (sb!kernel:layout-info (sb!kernel:find-layout class))))) (out-to "static-symbols" (write-static-symbols)) - (when core-file-name + (let ((fn (format nil "~A/Makefile.features" c-header-dir-name))) + (ensure-directories-exist fn) + (with-open-file (*standard-output* fn :if-exists :supersede + :direction :output) + (write-makefile-features))) + + (when core-file-name (write-initial-core-file core-file-name))))))