0.9.18.49:

[sbcl.git] / src / compiler / generic / genesis.lisp

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index a381dfd..ef6968b 100644 (file)
--- 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*.
@@ -1255,19 +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)
-    #!+win32 (frob handle-win32-exception)
-    (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))
@@ -1758,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)
@@ -2605,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
@@ -2832,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%")))
 
@@ -2937,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))
@@ -3244,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.
@@ -3272,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<
@@ -3303,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))))))
+
+