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 fa3c971..ef6968b 100644 (file)
--- 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
 ;;; 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
 
 (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.
 ;;; 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.
 
 ;;; 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.
             ;; 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))))
         (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 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*
                           ;; 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)))
                             (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)
          (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)
                             (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
                             (number-to-core 0)))
          (layout-inherits (vector-in-core t-layout

-                                          i-layout

                                           so-layout
                                           bso-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)))
                 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*.
 
 ;;; 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*...
   ;; 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))
 
   (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))
           (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))))))
          (: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
        (: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
       (: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.)"
   (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"
              "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."))
              "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 " */~%"))
 
   (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
 (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))
                   (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
 
     (setf constants
           (sort constants

@@ -2737,7 +2749,7 @@ core and return a descriptor to it."
                           ((< value cutoff)
                            "~D")
                           (t
                           ((< value cutoff)
                            "~D")
                           (t

-                           "LISPOBJ(~D)")))
+                           "LISPOBJ(~DU)")))

                   value)
           (format t " /* 0x~X */~@[  /* ~A */~]~%" value doc))))
     (terpri))
                   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)
 
 (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;~%")
     (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)))
       (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))
     (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%")))
 
     (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 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))
 (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))
                 (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.
       (/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))))))
                        (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<
         (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)))))))
                     (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))
 
           (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))))))
           (write-initial-core-file core-file-name))))))

+
+