X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ef6968bca15ea921c84ce8966bdd6c420034613f;hb=670d28c10c178142146f6916c5fa0967732f3a8f;hp=4ba0bc2f9bfc33520e2f818b12e219e625b04afb;hpb=817aab3f6fb638e487c59945a36e7b5c8ffce2cb;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4ba0bc2..ef6968b 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -854,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. @@ -924,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)))) @@ -1228,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*. @@ -1260,18 +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) - #!+sb-thread (frob sb!thread::run-interruption)) + (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)) @@ -1762,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 @@ -2600,6 +2599,15 @@ core and return a descriptor to it." (format t " *~@[ ~A~]~%" line)) (format t " */~%")) +(defun write-makefile-features () + ;; propagating *SHEBANG-FEATURES* into the Makefiles + (dolist (shebang-feature-name (sort (mapcar #'symbol-name + sb-cold:*shebang-features*) + #'string<)) + (format t + "LISP_FEATURE_~A=1~%" + (substitute #\_ #\- shebang-feature-name)))) + (defun write-config-h () ;; propagating *SHEBANG-FEATURES* into C-level #define's (dolist (shebang-feature-name (sort (mapcar #'symbol-name @@ -2827,9 +2835,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%"))) @@ -2932,6 +2940,8 @@ initially undefined function references:~2%") (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)) @@ -3239,10 +3249,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. @@ -3267,11 +3273,11 @@ 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)) (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< @@ -3298,5 +3304,13 @@ 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)))))) + +