X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=90c22bd7ed8cdf3ea89178993303b676278594b4;hb=a41e7cf8667de9ae078a8e318e8c5c045cdee87d;hp=1e3ed361c11d316612a4a5c7eeaef00b6248a229;hpb=1600081cf1b71b3d0e2e40de1c1c124a3a4fd40c;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 1e3ed36..90c22bd 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -2439,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))
@@ -2496,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)
@@ -2599,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
@@ -2787,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)
@@ -3240,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.
@@ -3268,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<
@@ -3299,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))))))
+
+