X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=10641b39f89bec0172d80cd11a6b620871f0e84b;hb=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=6ef6c4a63aee438882bd77cb27dd6a4fbc69cdf7;hpb=8a19c6876412b8ad1cf729297c2a373d63a0d0ec;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 6ef6c4a..10641b3 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -47,13 +47,20 @@
 ;;; way to do this in high level data like this (as opposed to e.g. in
 ;;; IP packets), and in fact the CMU CL version number never ended up
 ;;; being incremented past 0. A better approach might be to use a
-;;; string which is set from CVS data.
+;;; string which is set from CVS data. (Though now as of sbcl-0.7.8 or
+;;; so, we have another problem that the core incompatibility
+;;; detection mechanisms are on such a hair trigger -- with even
+;;; different builds from the same sources being considered
+;;; incompatible -- that any coarser-grained versioning mechanisms
+;;; like this are largely irrelevant as long as the hair-triggering
+;;; persists.)
 ;;;
 ;;; 0: inherited from CMU CL
 ;;; 1: rearranged static symbols for sbcl-0.6.8
 ;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support,
 ;;;    deleted a slot from DEBUG-SOURCE structure
-(defconstant sbcl-core-version-integer 2)
+;;; 3: added build ID to cores to discourage sbcl/.core mismatch
+(defconstant sbcl-core-version-integer 3)
 
 (defun round-up (number size)
   #!+sb-doc
@@ -1740,7 +1747,23 @@
 		  (logior (ash bits 3)
 			  (logand (bvref-32 gspace-bytes gspace-byte-offset)
 				  #xffe0e002)))))))
-      (:ppc
+      (:mips
+       (ecase kind
+	 (:jump
+	  (assert (zerop (ash value -28)))
+	  (setf (ldb (byte 26 0) 
+		     (bvref-32 gspace-bytes gspace-byte-offset))
+		(ash value -2)))
+	 (:lui
+	  (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)))))
+	 (: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))))))
+       (:ppc
        (ecase kind
          (:ba
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
@@ -2906,7 +2929,18 @@ initially undefined function references:~2%")
 (defvar *core-file*)
 (defvar *data-page*)
 
+;;; magic numbers to identify entries in a core file
+;;;
+;;; (In case you were wondering: No, AFAIK there's no special magic about
+;;; these which requires them to be in the 38xx range. They're just
+;;; arbitrary words, tested not for being in a particular range but just
+;;; for equality. However, if you ever need to look at a .core file and
+;;; figure out what's going on, it's slightly convenient that they're
+;;; all in an easily recognizable range, and displacing the range away from
+;;; zero seems likely to reduce the chance that random garbage will be
+;;; misinterpreted as a .core file.)
 (defconstant version-core-entry-type-code 3860)
+(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 end-core-entry-type-code 3840)
@@ -3001,6 +3035,22 @@ initially undefined function references:~2%")
       (write-word 3)
       (write-word sbcl-core-version-integer)
 
+      ;; Write the build ID.
+      (write-word build-id-core-entry-type-code)
+      (let ((build-id (with-open-file (s "output/build-id.tmp"
+					 :direction :input)
+			(read s))))
+	(declare (type simple-string build-id))
+	(/show build-id (length build-id))
+	;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
+	;; word, this length word, and one word for each char of BUILD-ID.
+	(write-word (+ 2 (length build-id)))
+	(dovector (char build-id)
+	  ;; (We write each character as a word in order to avoid
+	  ;; having to think about word alignment issues in the
+	  ;; sbcl-0.7.8 version of coreparse.c.)
+	  (write-word (char-code char))))
+
       ;; Write the New Directory entry header.
       (write-word new-directory-core-entry-type-code)
       (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
@@ -3159,6 +3209,7 @@ initially undefined function references:~2%")
 	(let ((package (find-package (sb-cold:package-data-name pd))))
 	  (labels (;; Call FN on every node of the TREE.
 		   (mapc-on-tree (fn tree)
+                                 (declare (type function fn))
 				 (typecase tree
 				   (cons (mapc-on-tree fn (car tree))
 					 (mapc-on-tree fn (cdr tree)))