From f26a95f4b7fef56ca9c865fc05ebd497b3b8e745 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Jan 2018 20:38:24 -0800
Subject: [PATCH] Move set-{dispatch-tag,predicate}<=! into boot for use in
 cold load.

---
 src/runtime/boot.scm               | 10 ++++++++++
 src/runtime/gentag.scm             |  5 -----
 src/runtime/predicate-lattice.scm  |  8 ++++----
 src/runtime/predicate-metadata.scm |  6 +++---
 src/runtime/predicate-tagging.scm  |  2 +-
 src/runtime/record.scm             |  1 +
 src/runtime/runtime.pkg            |  6 +++---
 7 files changed, 22 insertions(+), 16 deletions(-)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index d8f30aeb3..389501167 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -377,6 +377,16 @@ USA.
 	  unspecific))
   unspecific)
 
+(define (set-dispatch-tag<=! t1 t2)
+  (defer-boot-action 'predicate-relations
+    (lambda ()
+      (set-dispatch-tag<=! t1 t2))))
+
+(define (set-predicate<=! p1 p2)
+  (defer-boot-action 'predicate-relations
+    (lambda ()
+      (set-predicate<=! p1 p2))))
+
 (define (guarantee predicate object #!optional caller)
   (if (predicate object)
       object
diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 2826b78ea..4c70c25a3 100644
--- a/src/runtime/gentag.scm
+++ b/src/runtime/gentag.scm
@@ -132,11 +132,6 @@ USA.
  (lambda ()
    (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#()))
    (%record-set! metatag-tag 0 metatag-tag)))
-
-(define (set-dispatch-tag<=! t1 t2)
-  (defer-boot-action 'predicate-relations
-    (lambda ()
-      (set-dispatch-tag<=! t1 t2))))
 
 (define (dispatch-tag-metatag tag)
   (guarantee dispatch-tag? tag 'dispatch-tag-metatag)
diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index c38ee3a27..67acfd01e 100644
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -36,10 +36,6 @@ USA.
 (define (predicate>= predicate1 predicate2)
   (predicate<= predicate2 predicate1))
 
-(define (set-predicate<=! predicate superset)
-  (set-dispatch-tag<=! (predicate->dispatch-tag predicate 'set-predicate<=!)
-		       (predicate->dispatch-tag superset 'set-predicate<=!)))
-
 (define (dispatch-tag= tag1 tag2)
   (guarantee dispatch-tag? tag1 'dispatch-tag=)
   (guarantee dispatch-tag? tag2 'dispatch-tag=)
@@ -119,4 +115,8 @@ USA.
 	   (if (dispatch-tag>= tag superset)
 	       (error "Not allowed to create a superset loop:" tag superset))
 	   (hash-table-clear! dispatch-tag<=-cache)))
+   (set! set-predicate<=!
+	 (named-lambda (set-predicate<=! predicate superset)
+	   (set-dispatch-tag<=! (predicate->dispatch-tag predicate)
+				(predicate->dispatch-tag superset))))
    (run-deferred-boot-actions 'predicate-relations)))
\ No newline at end of file
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index a97e56bf5..8e90f5034 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -39,12 +39,12 @@ USA.
      (run-deferred-boot-actions 'set-predicate-tag!))))
 
 (define (predicate-name predicate)
-  (dispatch-tag-name (predicate->dispatch-tag predicate 'predicate-name)))
+  (dispatch-tag-name (predicate->dispatch-tag predicate)))
 
-(define (predicate->dispatch-tag predicate #!optional caller)
+(define (predicate->dispatch-tag predicate)
   (let ((tag (get-predicate-tag predicate #f)))
     (if (not tag)
-        (error:not-a predicate? predicate caller))
+        (error:not-a predicate? predicate))
     tag))
 
 (define simple-tag-metatag)
diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index eec437270..36065a19b 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -44,7 +44,7 @@ USA.
       object))
 
 (define (predicate-tagger predicate)
-  (%tag-tagger (predicate->dispatch-tag predicate 'predicate-tagger) predicate))
+  (%tag-tagger (predicate->dispatch-tag predicate) predicate))
 
 (define (dispatch-tag-tagger tag)
   (%tag-tagger tag (dispatch-tag->predicate tag)))
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index c9c3e29d3..e90f897e7 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -74,6 +74,7 @@ USA.
 			       (if (default-object? default-inits)
 				   (vector-cons n #f)
 				   (list->vector default-inits)))))
+	(set-predicate<=! predicate record?)
 	(if (and unparser-method
 		 (not (default-object? unparser-method)))
 	    (define-unparser-method predicate unparser-method))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 36928f0de..a04b90f3c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -180,6 +180,8 @@ USA.
 	  object-pure?
 	  predicate?
 	  register-predicate!
+	  set-dispatch-tag<=!
+	  set-predicate<=!
 	  simple-parser-method
 	  simple-unparser-method
 	  standard-unparser-method
@@ -1859,7 +1861,6 @@ USA.
 	  no-object?
 	  predicate<=
 	  predicate>=
-	  set-predicate<=!
 	  top-dispatch-tag)
   (export (runtime)
 	  define-dispatch-tag<=))
@@ -5105,8 +5106,7 @@ USA.
 	  dispatch-tag-metatag
 	  dispatch-tag-name
 	  dispatch-tag?
-	  make-dispatch-metatag
-	  set-dispatch-tag<=!)
+	  make-dispatch-metatag)
   (export (runtime predicate-lattice)
 	  add-dispatch-tag-superset
 	  any-dispatch-tag-superset)
-- 
2.25.1