X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=aa879d2a22415b60b711e84489acc5d66eea0a5a;hb=1de12891f900d156ed035a097561ecd7755a256a;hp=bb05ce1ef8536a184fb78e37470ec574f2a05172;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index bb05ce1..aa879d2 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 @@ -853,7 +854,7 @@ core and return a descriptor to it." ;;; 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 18) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. @@ -923,22 +924,17 @@ core and return a descriptor to it." ;; 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)))) + (hash-value + (1+ (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.) + sb!kernel:layout-clos-hash-max)))) (write-wordindexed result (+ i sb!vm:instance-slots-offset 1) (make-fixnum-descriptor hash-value)))) @@ -1227,7 +1223,13 @@ core and return a descriptor to it." offset-wanted)))) ;; Establish the value of T. (let ((t-symbol (cold-intern t))) - (cold-set t-symbol t-symbol)))) + (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*))) + (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*. @@ -1259,17 +1261,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)) @@ -1760,27 +1753,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 @@ -2825,9 +2826,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%"))) @@ -2929,6 +2930,9 @@ 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) +#!+(and sb-lutex sb-thread) +(defconstant lutex-table-core-entry-type-code 3887) (defconstant end-core-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) @@ -3236,10 +3240,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.