X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ef6968bca15ea921c84ce8966bdd6c420034613f;hb=670d28c10c178142146f6916c5fa0967732f3a8f;hp=fa3c971047fcb1106b87c63a1df02a6185f6e4cc;hpb=f1ffbf976aaa50b7b22f126b97e34afe06a91210;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index fa3c971..ef6968b 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)))) @@ -980,7 +976,7 @@ core and return a descriptor to it." (number-to-core target-layout-length) (vector-in-core) ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT.. - (number-to-core 4) + (number-to-core 3) ;; no raw slots in LAYOUT: (number-to-core 0))) (write-wordindexed *layout-layout* @@ -998,26 +994,19 @@ 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))) @@ -1234,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*. @@ -1266,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)) @@ -1767,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 @@ -2594,7 +2588,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,9 +2596,18 @@ 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 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 @@ -2699,6 +2702,15 @@ core and return a descriptor to it." (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))) (setf constants (sort constants @@ -2737,7 +2749,7 @@ core and return a descriptor to it." ((< value cutoff) "~D") (t - "LISPOBJ(~D)"))) + "LISPOBJ(~DU)"))) value) (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) (terpri)) @@ -2812,7 +2824,9 @@ core and return a descriptor to it." (defun write-structure-object (dd) (flet ((cstring (designator) - (substitute #\_ #\- (string-downcase (string designator))))) + (substitute + #\_ #\% + (substitute #\_ #\- (string-downcase (string designator)))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "struct ~A {~%" (cstring (dd-name dd))) (format t " lispobj header;~%") @@ -2821,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%"))) @@ -2925,6 +2939,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)) @@ -3232,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. @@ -3260,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< @@ -3280,12 +3293,24 @@ initially undefined function references:~2%") (format t "~&#include \"~A.h\"~%" (string-downcase (string (sb!vm:primitive-object-name obj))))))) - (dolist (class '(hash-table layout)) + (dolist (class '(hash-table + layout + sb!c::compiled-debug-info + sb!c::compiled-debug-fun + sb!xc:package)) (out-to (string-downcase (string class)) (write-structure-object (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)))))) + +