From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 15 May 2018 04:36:22 +0000 (-0700)
Subject: Move the arity-dispatcher-tag from the microcode to the runtime system.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~38
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ba41a57470157972fe43db4073965948c05923a6;p=mit-scheme.git

Move the arity-dispatcher-tag from the microcode to the runtime system.
---

diff --git a/src/microcode/utabmd.c b/src/microcode/utabmd.c
index a24b20463..a141b622c 100644
--- a/src/microcode/utabmd.c
+++ b/src/microcode/utabmd.c
@@ -172,9 +172,6 @@ initialize_fixed_objects_vector (void)
   STORE_FIXOBJ (GENERIC_TRAMPOLINE_REMAINDER, SHARP_F);
   STORE_FIXOBJ (GENERIC_TRAMPOLINE_MODULO, SHARP_F);
 
-  STORE_FIXOBJ (ARITY_DISPATCHER_TAG,
-		(char_pointer_to_symbol
-		 ("#[(microcode)arity-dispatcher-tag]")));
   STORE_FIXOBJ (FIXOBJ_PROXIED_RECORD_TYPES,
 		(make_vector ((FASDUMP_RECORD_MARKER_END
 			       - FASDUMP_RECORD_MARKER_START),
diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm
index 6306ef4c8..e34fbc1cf 100644
--- a/src/runtime/procedure.scm
+++ b/src/runtime/procedure.scm
@@ -454,15 +454,21 @@ USA.
   ;; SELF argument.
   (make-entity default
 	       (list->vector
-		(cons (fixed-objects-item 'arity-dispatcher-tag)
+		(cons arity-dispatcher-tag
 		      dispatched-cases))))
 
 (define (arity-dispatched-procedure? object)
   (and (entity? object)
        (vector? (entity-extra object))
        (fix:< 0 (vector-length (entity-extra object)))
-       (eq? (vector-ref (entity-extra object) 0)
-	    (fixed-objects-item 'arity-dispatcher-tag))))
+       (eq? (vector-ref (entity-extra object) 0) arity-dispatcher-tag)))
+
+(define-integrable arity-dispatcher-tag
+  '|#[(microcode)arity-dispatcher-tag]|)
+
+(defer-boot-action 'fixed-objects
+  (lambda ()
+    (set-fixed-objects-item! 'arity-dispatcher-tag arity-dispatcher-tag)))
 
 (define (procedure-chains-to p1 p2)
   (let loop ((p1 p1))