0.7.13.5

	Committed patch for gencgc refactoring based on work done
	on threads branch.

	... to make header file management a lot simpler, and allow
	the use of interesting typedefs in genesis :C-TYPE slot
	options, we split runtime.h into lots of smaller files that
	can be (semi-)independently included.

	... all GC and GCish functions now have the same interface,
	so no need for (eq *internal-gc* #'collect-garbage) test in
	SUB-GC

	... current_region_end_addr and current_region_free_pointer
	go away, eliminating potential for weird bugs when they're
	not synchronized properly.  Yay OAOO

	... disabled (actually, removed) inline allocation, as it
	depended on old current_region_* (see above) and appears
	to make not a lot of actual difference to run times anyway

	pseudo-atomic support is now always compiled in.  I can see
	no good reason for not having it

	... much code in alloc() collapsed.  Also alloc() no longer
	attempts to drop its PA and do a collection in the middle of
	allocation - instead it uses the existing maybe_gc flag to
	indicate that collection should happen when the allocation is
	done.  Possibly this has bad effects when trying to allocate
	an object bigger than available dynamic space, but that would
	fit if a GC were done first.  Given the (complete lack of)
	error handling for out-of-memory conditions in this and all
	previous SBCL versions, it would be a foolish programmer who
	was depending on this anyway, though.

make-genesis-2.sh

@@ -44,7 +44,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
 	    (read s)))
 	(host-load-stem "src/compiler/generic/genesis")
 	(sb!vm:genesis :object-file-names *target-object-file-names*
-		       :c-header-file-name "output/sbcl2.h"
+		       :c-header-dir-name "output/genesis-2"
 		       :symbol-table-file-name "src/runtime/sbcl.nm"
 		       :core-file-name "output/cold-sbcl.core"
 		       ;; The map file is not needed by the system, but can
@@ -54,9 +54,9 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
 	EOF
 
 echo //testing for consistency of first and second GENESIS passes
-if cmp src/runtime/sbcl.h output/sbcl2.h; then
-    echo //sbcl2.h matches sbcl.h -- good.
+if diff -qr src/runtime/genesis output/genesis-2; then
+    echo //header files match between first and second GENESIS -- good
 else
-    echo error: sbcl2.h does not match sbcl.h.
+    echo error: header files do not match between first and second GENESIS
     exit 1
 fi

make-host-1.sh

@@ -43,6 +43,6 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
 	  (load "tests/type.before-xc.lisp")
 	  (load "tests/info.before-xc.lisp"))
         (host-cload-stem "src/compiler/generic/genesis")
-	(sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h")
+	(sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
         #+cmu (ext:quit)
 	EOF

src/code/gc.lisp

@@ -349,17 +349,7 @@ function should notify the user that the system has finished GC'ing.")
 		   ;; triggered GC could've done a fair amount of
 		   ;; consing.)
 		   (pre-internal-gc-dynamic-usage (dynamic-usage))
-		   (ignore-me
-		    #!-gencgc (funcall *internal-gc*)
-		    ;; FIXME: This EQ test is pretty gross. Among its other
-		    ;; nastinesses, it looks as though it could break if we
-		    ;; recompile COLLECT-GARBAGE. We should probably just
-		    ;; straighten out the interface so that all *INTERNAL-GC*
-		    ;; functions accept a GEN argument (and then the
-		    ;; non-generational ones just ignore it).
-		    #!+gencgc (if (eq *internal-gc* #'collect-garbage)
-				  (funcall *internal-gc* gen)
-				  (funcall *internal-gc*)))
+		   (ignore-me (funcall *internal-gc* gen))
 		   (post-gc-dynamic-usage (dynamic-usage))
 		   (n-bytes-freed (- pre-internal-gc-dynamic-usage
 				     post-gc-dynamic-usage))

src/code/purify.lisp

@@ -52,7 +52,7 @@
 	   (write-string "[doing purification: " notify-stream)
 	   (force-output notify-stream)))
 	(*internal-gc*
-	 (lambda ()
+	 (lambda (ignored-generation-arg)
 	   (%purify (get-lisp-obj-address root-structures)
 		    (get-lisp-obj-address nil))))
 	(*gc-notify-after*

src/compiler/generic/genesis.lisp

@@ -2643,9 +2643,7 @@
   (and (>= (length string) (length tail))
        (string= string tail :start1 (- (length string) (length tail)))))
 
-(defun write-c-header ()
-
-  ;; writing beginning boilerplate
+(defun write-boilerplate ()
   (format t "/*~%")
   (dolist (line
 	   '("This is a machine-generated file. Please do not edit it by hand."
@@ -2658,11 +2656,9 @@
 	     "load and run 'core' files, which are basically programs"
 	     "in SBCL's own format."))
     (format t " * ~A~%" line))
-  (format t " */~%")
-  (terpri)
-  (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
-  (terpri)
+  (format t " */~%"))
 
+(defun write-config-h ()
   ;; propagating *SHEBANG-FEATURES* into C-level #define's
   (dolist (shebang-feature-name (sort (mapcar #'symbol-name
 					      sb-cold:*shebang-features*)
@@ -2671,15 +2667,20 @@
 	    "#define LISP_FEATURE_~A~%"
 	    (substitute #\_ #\- shebang-feature-name)))
   (terpri)
-
-  ;; writing miscellaneous constants
+  ;; and miscellaneous constants
   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
   (format t
 	  "#define SBCL_VERSION_STRING ~S~%"
 	  (sb!xc:lisp-implementation-version))
   (format t "#define CORE_MAGIC 0x~X~%" core-magic)
-  (terpri)
-
+  (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+  (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
+  (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+  (format t "#define LISPOBJ(thing) thing~2%")
+  (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")
+  (terpri))
+
+(defun write-constants-h ()
   ;; writing entire families of named constants 
   (let ((constants nil))
     (dolist (package-name '(;; Even in CMU CL, constants from VM
@@ -2809,16 +2810,13 @@
 	    (sb!xc:byte-position (symbol-value symbol)))
     (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
 	    (substitute #\_ #\- (symbol-name symbol))
-	    (sb!xc:mask-field (symbol-value symbol) -1)))
+	    (sb!xc:mask-field (symbol-value symbol) -1))))
 
+
+
+(defun write-primitive-object (obj)  
   ;; writing primitive object layouts
-  (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
-		       :key (lambda (obj)
-			      (symbol-name
-			       (sb!vm:primitive-object-name obj))))))
     (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
-    (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
-    (dolist (obj structs)
       (format t
 	      "struct ~A {~%"
 	      (substitute #\_ #\-
@@ -2831,10 +2829,8 @@
 	(substitute #\_ #\-
 		    (string-downcase (string (sb!vm:slot-name slot))))
 	(sb!vm:slot-rest-p slot)))
-      (format t "};~2%"))
+  (format t "};~2%")
     (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
-    (format t "#define LISPOBJ(thing) thing~2%")
-    (dolist (obj structs)
       (let ((name (sb!vm:primitive-object-name obj))
       (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
 	(when lowtag
@@ -2843,10 +2839,10 @@
 		  (substitute #\_ #\- (string name))
 		  (substitute #\_ #\- (string (sb!vm:slot-name slot)))
 		  (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
-	(terpri))))
+      (terpri)))
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
 
-  ;; writing static symbol offsets
+(defun write-static-symbols ()
   (dolist (symbol (cons nil sb!vm:*static-symbols*))
     ;; FIXME: It would be nice to use longer names than NIL and
     ;; (particularly) T in #define statements.
@@ -2862,10 +2858,8 @@
 	      (+ sb!vm:static-space-start
 		 sb!vm:n-word-bytes
 		 sb!vm:other-pointer-lowtag
-		 (if symbol (sb!vm:static-symbol-offset symbol) 0)))))
+		   (if symbol (sb!vm:static-symbol-offset symbol) 0))))))
 
-  ;; Voila.
-  (format t "~%#endif~%"))
 
 ;;;; writing map file
 
@@ -3111,7 +3105,7 @@ initially undefined function references:~2%")
 		      symbol-table-file-name
 		      core-file-name
 		      map-file-name
-		      c-header-file-name)
+		      c-header-dir-name)
 
   (when (and core-file-name
 	     (not symbol-table-file-name))
@@ -3125,8 +3119,7 @@ initially undefined function references:~2%")
 	    ;; we're not e.g. also creating a header file when we
 	    ;; create a core.
 	    (format nil "creating core ~S" core-file-name)
-	    (format nil "creating header ~S" c-header-file-name)))
-
+	    (format nil "creating headers in ~S" c-header-dir-name)))
   (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
 
     ;; Read symbol table, if any.
@@ -3141,8 +3134,7 @@ initially undefined function references:~2%")
 	     (when filename
 	       (ensure-directories-exist filename :verbose t))))
       (frob core-file-name)
-      (frob map-file-name)
-      (frob c-header-file-name))
+      (frob map-file-name))
 
     ;; (This shouldn't matter in normal use, since GENESIS normally
     ;; only runs once in any given Lisp image, but it could reduce
@@ -3269,15 +3261,37 @@ initially undefined function references:~2%")
       ;; lexical variable, and it's annoying to have WRITE-MAP (to
       ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
       ;; (to a stream explicitly passed as an argument).
+      (macrolet ((out-to (name &body body)
+		   `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name)))
+		     (ensure-directories-exist fn)
+		     (with-open-file (*standard-output* fn  
+				      :if-exists :supersede :direction :output)
+		       (write-boilerplate)
+		       (let ((n (substitute #\_ #\- (string-upcase ,name))))
+			 (format 
+			  t
+			  "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
+			  n n))
+		       ,@body
+		       (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 c-header-file-name
-	(with-open-file (*standard-output* c-header-file-name
-					   :direction :output
-					   :if-exists :supersede)
-	  (write-c-header)))
+	(out-to "config" (write-config-h))
+	(out-to "constants" (write-constants-h))
+	(let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
+			     :key (lambda (obj)
+				    (symbol-name
+				     (sb!vm:primitive-object-name obj))))))
+	  (dolist (obj structs)
+	    (out-to
+	     (string-downcase (string (sb!vm:primitive-object-name obj)))
+	     (write-primitive-object obj))))
+	(out-to "static-symbols" (write-static-symbols))
+
       (when core-file-name
-	(write-initial-core-file core-file-name)))))
+	  (write-initial-core-file core-file-name))))))