X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=90c22bd7ed8cdf3ea89178993303b676278594b4;hb=a41e7cf8667de9ae078a8e318e8c5c045cdee87d;hp=33a504b17991f253a8c2d9874456181b6f3d6253;hpb=b0a7abdf2bd6f2d66fcce97196024cdb0e1a1886;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 33a504b..90c22bd 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1223,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*. @@ -1747,8 +1753,7 @@ 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) @@ -2434,7 +2439,8 @@ core and return a descriptor to it." (write-wordindexed code slot value))) (define-cold-fop (fop-fun-entry) - (let* ((type (pop-stack)) + (let* ((xrefs (pop-stack)) + (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) @@ -2491,6 +2497,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-xrefs-slot xrefs) fn)) (define-cold-fop (fop-foreign-fixup) @@ -2594,6 +2601,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 @@ -2782,31 +2798,33 @@ core and return a descriptor to it." (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 {~%" + (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 "};~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))) + (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 (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 "#endif /* LANGUAGE_ASSEMBLY */~2%")) (defun write-structure-object (dd) (flet ((cstring (designator) @@ -2821,9 +2839,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%"))) @@ -2926,6 +2944,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)) @@ -3233,10 +3253,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. @@ -3261,11 +3277,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< @@ -3292,5 +3308,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)))))) + +