From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 21 Jan 2018 22:01:03 +0000 (-0800)
Subject: Move bundle implementation to early in the cold load.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~325
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=451556e1622b05326b89fa632f12723c98f6d39b;p=mit-scheme.git

Move bundle implementation to early in the cold load.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 0fc2cdb33..771407a5d 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -116,28 +116,21 @@ USA.
 
 (define (bundle? object)
   (and (entity? object)
-       (bundle-metadata? (entity-extra object))))
-
-(add-boot-init!
- (lambda ()
-   (register-predicate! bundle? 'bundle '<= entity?)))
+       (let ((extra (entity-extra object)))
+	 (and (vector? extra)
+	      (fix:= 2 (vector-length extra))
+	      (bundle-interface-tag? (vector-ref extra 0))))))
 
 (define (%make-bundle tag values)
   (make-entity (lambda (self operator . args)
 		 (apply (bundle-ref self operator) args))
-	       (make-bundle-metadata tag values)))
-
-(define-record-type <bundle-metadata>
-    (make-bundle-metadata tag values)
-    bundle-metadata?
-  (tag bundle-metadata-tag)
-  (values bundle-metadata-values))
+	       (vector tag values)))
 
-(define (%bundle-tag bundle)
-  (bundle-metadata-tag (entity-extra bundle)))
+(define-integrable (%bundle-tag bundle)
+  (vector-ref (entity-extra bundle) 0))
 
-(define (%bundle-values bundle)
-  (bundle-metadata-values (entity-extra bundle)))
+(define-integrable (%bundle-values bundle)
+  (vector-ref (entity-extra bundle) 1))
 
 (define (bundle-interface bundle)
   (guarantee bundle? bundle 'bundle-interface)
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index c40fa1eed..a7f65ab1f 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -371,7 +371,8 @@ USA.
 	 ("gentag" . (runtime tagged-dispatch))
 	 ("thread-low" . (RUNTIME THREAD))
 	 ("poplat" . (RUNTIME POPULATION))
-	 ("record" . (RUNTIME RECORD))))
+	 ("record" . (RUNTIME RECORD))
+	 ("bundle" . (runtime bundle))))
       (files2
        '(("syntax-items" . (RUNTIME SYNTAX ITEMS))
 	 ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS))
@@ -409,6 +410,7 @@ USA.
   (package-initialize '(runtime tagged-dispatch) #f #t)
   (package-initialize '(RUNTIME POPULATION) #f #t)
   (package-initialize '(runtime record) #f #t)
+  (package-initialize '(runtime bundle) #f #t)
 
   (load-files-with-boot-inits files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) #f #t)	     ;First population.
@@ -479,7 +481,6 @@ USA.
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)
-   (RUNTIME BUNDLE)
    ;; Microcode data structures
    (RUNTIME HISTORY)
    (RUNTIME SCODE)
diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 028e140c0..89279ce85 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -232,7 +232,8 @@ USA.
    (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
    (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
-   (register-predicate! unparser-method? 'unparser-method '<= procedure?)))
+   (register-predicate! unparser-method? 'unparser-method '<= procedure?)
+   (register-predicate! bundle? 'bundle '<= entity?)))
 
 (add-boot-init!
  (lambda ()