From 80c4401cf00909700fa942cf8bd34de500cbc73b Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Sat, 8 Nov 2014 18:52:53 +0000
Subject: [PATCH] equal .lisp-obj files produce identical cold-sbcl.cores

(apart from the build-id, that is.  But now
  cmp -i 1024 {sbcl,$X}/output/cold-sbcl.core
returns true for X in {ccl32,ccl64,clisp})
---
 src/compiler/generic/genesis.lisp | 74 ++++++++++++++++++++++-----------------
 1 file changed, 42 insertions(+), 32 deletions(-)

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index d6f382b20..0c5da5fb8 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1419,38 +1419,48 @@ core and return a descriptor to it."
   ;; Inasmuch as the "offending" things are compiled by ordinary target code
   ;; and not cold-init, I think we should use an ordinary DEFPACKAGE for
   ;; the added-on bits. What I've done is somewhat of a fragile kludge.
-  (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE"
-                                 "SB!PROFILE" "SB!EXT" "SB!VM"
-                                 "SB!C" "SB!FASL" "SB!DEBUG")
-                               :external)
-    (loop
-     (multiple-value-bind (foundp sym accessibility package) (iter)
-       (declare (ignore accessibility))
-       (cond ((not foundp) (return))
-             ((eq (symbol-package sym) package) (cold-intern sym))))))
-
-  (let ((cold-pkg-inits *nil-descriptor*))
-    (maphash
-     (lambda (pkg-name pkg-info)
-       (unless (member pkg-name '("COMMON-LISP" "KEYWORD") :test 'string=)
-         (let ((host-pkg (find-package pkg-name))
-               (sb-xc-pkg (find-package "SB-XC")))
-           ;; Scan for symbols present in this package whose home is not this,
-           ;; but skip any present symbol whose home package is SB-XC because
-           ;; on the target, no symbol will be imported from SB-XC.
-           (with-package-iterator (iter host-pkg :internal :external)
-             (loop
-              (multiple-value-bind (foundp sym accessibility) (iter)
-                (unless foundp (return))
-                (unless (or (eq (symbol-package sym) host-pkg)
-                            (eq (symbol-package sym) sb-xc-pkg))
-                  (record-accessibility
-                   accessibility (cold-intern sym) pkg-info sym host-pkg)))))))
-       (cold-push (cold-cons (car pkg-info)
-                             (cold-cons (vector-to-core (cadr pkg-info))
-                                        (vector-to-core (cddr pkg-info))))
-                  cold-pkg-inits))
-     *cold-package-symbols*)
+  (let (syms)
+    (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE"
+                                   "SB!PROFILE" "SB!EXT" "SB!VM"
+                                   "SB!C" "SB!FASL" "SB!DEBUG")
+                                 :external)
+      (loop
+         (multiple-value-bind (foundp sym accessibility package) (iter)
+           (declare (ignore accessibility))
+           (cond ((not foundp) (return))
+                 ((eq (symbol-package sym) package) (push sym syms))))))
+    (setf syms (stable-sort syms #'string<))
+    (dolist (sym syms)
+      (cold-intern sym)))
+
+  (let ((cold-pkg-inits *nil-descriptor*)
+        cold-package-symbols-list)
+    (maphash (lambda (name info)
+               (push (cons name info) cold-package-symbols-list))
+             *cold-package-symbols*)
+    (setf cold-package-symbols-list
+          (sort cold-package-symbols-list #'string< :key #'car))
+    (dolist (pkgcons cold-package-symbols-list)
+      (destructuring-bind (pkg-name . pkg-info) pkgcons
+        (unless (member pkg-name '("COMMON-LISP" "KEYWORD") :test 'string=)
+          (let ((host-pkg (find-package pkg-name))
+                (sb-xc-pkg (find-package "SB-XC"))
+                syms)
+            (with-package-iterator (iter host-pkg :internal :external)
+              (loop (multiple-value-bind (foundp sym accessibility) (iter)
+                      (unless foundp (return))
+                      (unless (or (eq (symbol-package sym) host-pkg)
+                                  (eq (symbol-package sym) sb-xc-pkg))
+                        (push (cons sym accessibility) syms)))))
+            (setq syms (sort syms #'string< :key #'car))
+            (dolist (symcons syms)
+              (destructuring-bind (sym . accessibility) symcons
+                (record-accessibility accessibility (cold-intern sym)
+                                      pkg-info sym host-pkg)))))
+        (cold-push (cold-cons (car pkg-info)
+                              (cold-cons (vector-to-core (cadr pkg-info))
+                                         (vector-to-core (cddr pkg-info))))
+                   cold-pkg-inits)))
     (cold-set 'sb!impl::*!initial-symbols* cold-pkg-inits))
 
   (attach-fdefinitions-to-symbols)
-- 
2.11.4.GIT