First draft of predicate tagging support.

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index e5486f7fb84f0f31db384f1bce1ec66c96f01c07..f6766b5280230b6acacea5e401e051e19bbbfb71 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -236,7 +236,8 @@ USA.
    (register-predicate! dotted-list? 'dotted-list)
    (register-predicate! not-pair? 'not-pair)))
 \f
-;;; Registration of predicates defined earlier in the boot load
+;;; Registration of predicates defined earlier in the boot load, or
+;;; needed before their packages are initialized.
 (add-boot-init!
  (lambda ()
    ;; MIT/GNU Scheme: specialized arithmetic
@@ -246,14 +247,14 @@ USA.
    (register-predicate! exact-positive-integer? 'exact-positive-integer
                        '<= exact-integer?)
    (register-predicate! exact-rational? 'exact-rational '<= rational?)
-   (register-predicate! byte? 'byte '<= exact-nonnegative-integer?)
 
    (register-predicate! fix:fixnum? 'fixnum '<= exact-integer?)
-   (register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum?)
+   (register-predicate! index-fixnum? 'index-fixnum
+                       '<= (list fix:fixnum? exact-nonnegative-integer?))
+   (register-predicate! byte? 'byte '<= index-fixnum?)
    (register-predicate! negative-fixnum? 'negative-fixnum '<= fix:fixnum?)
    (register-predicate! positive-fixnum? 'positive-fixnum
                        '<= (list fix:fixnum? exact-positive-integer?))
-
    (register-predicate! non-negative-fixnum? 'non-negative-fixnum
                        '<= (list fix:fixnum? exact-nonnegative-integer?))
    (register-predicate! non-positive-fixnum? 'non-positive-fixnum
@@ -287,22 +288,33 @@ USA.
    ;; MIT/GNU Scheme: URIs
    (register-predicate! uri? 'uniform-resource-identifier)
    (register-predicate! absolute-uri? 'absolute-uri '<= uri?)
-   (register-predicate! relative-uri? 'relative-uri '<= uri?)
-
-   ;; MIT/GNU Scheme: other stuff
+   (register-predicate! relative-uri? 'relative-uri '<= uri?)))
+\f
+(add-boot-init!
+ (lambda ()
+   ;; MIT/GNU Scheme: misc
    (register-predicate! 8-bit-char? '8-bit-char '<= char?)
+   (register-predicate! bit-string? 'bit-string)
+   (register-predicate! cell? 'cell)
+   (register-predicate! compiled-code-address? 'compiled-code-address)
+   (register-predicate! compiled-code-block? 'compiled-code-block)
+   (register-predicate! compiled-expression? 'compiled-expression)
+   (register-predicate! compiled-return-address? 'compiled-return-address)
    (register-predicate! dispatch-tag? 'dispatch-tag)
+   (register-predicate! ephemeron? 'ephemeron)
    (register-predicate! environment? 'environment)
    (register-predicate! equality-predicate? 'equality-predicate
                        '<= binary-procedure?)
    (register-predicate! hash-table? 'hash-table)
    (register-predicate! interned-symbol? 'interned-symbol '<= symbol?)
    (register-predicate! keyword? 'keyword '<= symbol?)
-   (register-predicate! lambda-tag? 'lambda-tag '<= symbol?)
+   (register-predicate! lambda-tag? 'lambda-tag)
    (register-predicate! named-structure? 'named-structure)
    (register-predicate! population? 'population)
+   (register-predicate! promise? 'promise)
    (register-predicate! record? 'record)
    (register-predicate! record-type? 'record-type)
+   (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread? 'thread)
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 33b9560b3b04e5ca1317df58271a790bee872630..d92d672b703abd21435ee27bd00891034e1cd9ab 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1735,7 +1735,9 @@ USA.
          thunk?
          unary-procedure?)
   (export (runtime continuation-parser)
-         compiled-procedure-frame-size))
+         compiled-procedure-frame-size)
+  (export (runtime tagging)
+         %entity-is-apply-hook?))
 
 (define-package (runtime predicate-metadata)
   (files "predicate-metadata")
@@ -3643,6 +3645,8 @@ USA.
   (files "tagging")
   (parent (runtime))
   (export ()
+         object->datum
+         object->predicate
          object-tagger
          set-tagged-object-unparser-method!
          tag-object

diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index e6b028de6053a7d25d607b96704298a6be863340..fd67b872383e9063739c6232dc82794f51fd80d5 100644 (file)
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -24,16 +24,16 @@ USA.
 
 |#
 
-;;;; Tagged objects
+;;;; Predicates: tagging
 ;;; package: (runtime tagging)
 
 (declare (usual-integrations))
-
+\f
 ;;; TODO(cph): eliminate after 9.3 release:
-(define tagged-object-type #x25)
+(define-integrable tagged-object-type #x25)
 
 (define (tagged-object? object)
-  (fix:= (object-type object) tagged-object-type))
+  (fix:= tagged-object-type (object-type object)))
 
 (define (object-tagger predicate)
   (let ((tag (predicate->tag predicate)))
@@ -73,4 +73,115 @@ USA.
        (guarantee unparser-method? unparser
                   'set-tagged-object-unparser-method!)
        (hash-table-set! unparser-methods tag unparser))
-      (hash-table-delete! unparser-methods tag)))
\ No newline at end of file
+      (hash-table-delete! unparser-methods tag)))
+
+(define (object->predicate object)
+  (tag->predicate (object->tag object)))
+
+(define (object->tag object)
+  (let ((code (object-type object)))
+    (or (vector-ref primitive-tags code)
+       ((vector-ref primitive-tag-methods code) object))))
+
+(define (object->datum object)
+  (cond ((tagged-object? object) (system-pair-cdr object))
+        (else object)))
+\f
+(define primitive-tags)
+(define primitive-tag-methods)
+(add-boot-init!
+ (lambda ()
+   (set! primitive-tags
+        (make-vector (microcode-type/code-limit)
+                     (top-tag)))
+   (set! primitive-tag-methods
+        (make-vector (microcode-type/code-limit) #f))
+   unspecific))
+
+(add-boot-init!
+ (lambda ()
+   (define (define-primitive-predicate type-name predicate)
+     (vector-set! primitive-tags
+                 (microcode-type/name->code type-name)
+                 (predicate->tag predicate)))
+
+   (define-primitive-predicate 'bignum exact-integer?)
+   (define-primitive-predicate 'bytevector bytevector?)
+   (define-primitive-predicate 'cell cell?)
+   (define-primitive-predicate 'character char?)
+   (define-primitive-predicate 'compiled-code-block compiled-code-block?)
+   (define-primitive-predicate 'ephemeron ephemeron?)
+   (define-primitive-predicate 'extended-procedure procedure?)
+   (define-primitive-predicate 'false boolean?)
+   (define-primitive-predicate 'fixnum fix:fixnum?)
+   (define-primitive-predicate 'flonum flo:flonum?)
+   (define-primitive-predicate 'interned-symbol interned-symbol?)
+   (define-primitive-predicate 'pair pair?)
+   (define-primitive-predicate 'primitive primitive-procedure?)
+   (define-primitive-predicate 'procedure procedure?)
+   (define-primitive-predicate 'promise promise?)
+   (define-primitive-predicate 'ratnum exact-rational?)
+   (define-primitive-predicate 'recnum number?)
+   (define-primitive-predicate 'stack-environment stack-address?)
+   (define-primitive-predicate 'string string?)
+   (define-primitive-predicate 'uninterned-symbol uninterned-symbol?)
+   (define-primitive-predicate 'vector vector?)
+   (define-primitive-predicate 'vector-1b bit-string?)
+   (define-primitive-predicate 'weak-cons weak-pair?)))
+\f
+(add-boot-init!
+ (lambda ()
+   (define (define-primitive-predicate-method type-name method)
+     (let ((type-code (microcode-type/name->code type-name)))
+       (vector-set! primitive-tags type-code #f)
+       (vector-set! primitive-tag-methods type-code method)))
+
+   (define-primitive-predicate-method 'tagged-object
+     system-pair-car)
+
+   (define-primitive-predicate-method 'constant
+     (let* ((constant-tags
+            (list->vector
+             (map predicate->tag
+                  (list boolean?
+                        undefined-value?
+                        undefined-value?
+                        lambda-tag?
+                        lambda-tag?
+                        lambda-tag?
+                        eof-object?
+                        default-object?
+                        lambda-tag?
+                        null?))))
+           (n-tags (vector-length constant-tags)))
+       (lambda (object)
+        (let ((datum (object-datum object)))
+          (if (and (fix:fixnum? datum) (fix:< datum n-tags))
+              (vector-ref constant-tags datum)
+              (top-tag))))))
+
+   (define-primitive-predicate-method 'entity
+     (let ((apply-hook-tag (predicate->tag apply-hook?))
+          (entity-tag (predicate->tag entity?)))
+       (lambda (object)
+        (if (%entity-is-apply-hook? object)
+            apply-hook-tag
+            entity-tag))))
+
+   (define-primitive-predicate-method 'compiled-entry
+     (let ((procedure-tag (predicate->tag compiled-procedure?))
+          (return-tag (predicate->tag compiled-return-address?))
+          (expression-tag (predicate->tag compiled-expression?))
+          (default-tag (predicate->tag compiled-code-address?)))
+       (lambda (entry)
+        (case (system-hunk3-cxr0
+               ((ucode-primitive compiled-entry-kind 1) entry))
+          ((0) procedure-tag)
+          ((1) return-tag)
+          ((2) expression-tag)
+          (else default-tag)))))
+
+   (define-primitive-predicate-method 'record
+     (let ((default-tag (predicate->tag record?)))
+       (lambda (object)
+        default-tag)))))
\ No newline at end of file