Implement tagged-object primitives and open-code them in compiler.

Also push record and tagged-object primitives into "boot" so they are available
early in the cold load.

diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm
index f5e0a36cdaa6cb769d2dbd053d0532fd9b32575c..087e4b1e4f2a743f8c1d58f1a55b923e2b0ff7e8 100644 (file)
--- a/src/compiler/base/utils.scm
+++ b/src/compiler/base/utils.scm
@@ -283,10 +283,12 @@ USA.
 
 (define boolean-valued-function-primitives
   (list (ucode-primitive %record?)
+       (ucode-primitive %tagged-vector? 1)
        (ucode-primitive &<)
        (ucode-primitive &=)
        (ucode-primitive &>)
        (ucode-primitive bit-string?)
+       (ucode-primitive bytevector? 1)
        (ucode-primitive char?)
        (ucode-primitive eq?)
        (ucode-primitive equal-fixnum?)
@@ -320,7 +322,10 @@ USA.
        (ucode-primitive zero?)))
 
 (define additional-side-effect-free-primitives
-  (list (ucode-primitive %record)
+  (list (ucode-primitive %make-record 2)
+       (ucode-primitive %make-tagged-vector 2)
+       (ucode-primitive %record)
+       (ucode-primitive allocate-bytevector 1)
        (ucode-primitive cons)
        (ucode-primitive floating-vector-cons)
        (ucode-primitive get-interrupt-enables)
@@ -333,6 +338,8 @@ USA.
 (define additional-function-primitives
   (list (ucode-primitive %record-length)
        (ucode-primitive %record-ref)
+       (ucode-primitive %tagged-vector-datum 1)
+       (ucode-primitive %tagged-vector-tag 1)
        (ucode-primitive &*)
        (ucode-primitive &+)
        (ucode-primitive &-)
@@ -340,6 +347,9 @@ USA.
        (ucode-primitive -1+)
        (ucode-primitive 1+)
        (ucode-primitive bit-string-length)
+       (ucode-primitive bit-string-length)
+       (ucode-primitive bytevector-length 1)
+       (ucode-primitive bytevector-u8-ref 2)
        (ucode-primitive car)
        (ucode-primitive cdr)
        (ucode-primitive char->integer)

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index 5a7b021f0bc2a99a3541b9e021fc5d1eb3ea2301..85a984ccc9e2761fab20712944c547b2e63677a4 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -682,15 +682,16 @@ USA.
         (lambda (name type)
           (define-open-coder/predicate name
             (simple-open-coder (open-code/type-test type) '(0) false)))))
-    (simple-type-test 'CHAR?    (ucode-type character))
-    (simple-type-test 'PAIR?    (ucode-type pair))
-    (simple-type-test 'STRING?  (ucode-type string))
-    (simple-type-test 'VECTOR?  (ucode-type vector))
-    (simple-type-test '%RECORD? (ucode-type record))
-    (simple-type-test 'FIXNUM?  (ucode-type fixnum))
-    (simple-type-test 'FLONUM?  (ucode-type flonum))
-    (simple-type-test 'BIT-STRING? (ucode-type vector-1b))
-    (simple-type-test 'BYTEVECTOR? (ucode-type bytevector))))
+    (simple-type-test '%record?        (ucode-type record))
+    (simple-type-test '%tagged-object? (ucode-type tagged-object))
+    (simple-type-test 'bit-string?     (ucode-type vector-1b))
+    (simple-type-test 'bytevector?     (ucode-type bytevector))
+    (simple-type-test 'char?           (ucode-type character))
+    (simple-type-test 'fixnum?         (ucode-type fixnum))
+    (simple-type-test 'flonum?         (ucode-type flonum))
+    (simple-type-test 'pair?           (ucode-type pair))
+    (simple-type-test 'string?         (ucode-type string))
+    (simple-type-test 'vector?         (ucode-type vector))))
 
 (define-open-coder/predicate 'EQ?
   (simple-open-coder
@@ -912,7 +913,12 @@ USA.
     (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1) false))
 
   (define-open-coder/value 'SYSTEM-PAIR-CONS
-    (filter/type-code open-code/pair-cons 0 '(1 2) false)))
+    (filter/type-code open-code/pair-cons 0 '(1 2) false))
+
+  (define-open-coder/value '%make-tagged-object
+    (simple-open-coder (open-code/pair-cons (ucode-type tagged-object))
+                      '(0 1)
+                      false)))
 
 (define-open-coder/value 'VECTOR
   (lambda (operands primitive block)
@@ -1032,7 +1038,9 @@ USA.
            (ucode-type flonum)
            0)
   (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0)
-  (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1))
+  (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1)
+  (user-ref '%tagged-object-tag rtl:make-fetch (ucode-type tagged-object) 0)
+  (user-ref '%tagged-object-datum rtl:make-fetch (ucode-type tagged-object) 1))
 
 (let ((system-ref
        (lambda (name make-fetch index)

diff --git a/src/microcode/list.c b/src/microcode/list.c
index d99a210c29acb1cdb732483336a7bfa181d3ae8f..f207425b6696f77dc8cad8a26ce826abe7fb865b 100644 (file)
--- a/src/microcode/list.c
+++ b/src/microcode/list.c
@@ -239,3 +239,33 @@ DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0)
   }
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+\f
+DEFINE_PRIMITIVE ("%TAGGED-OBJECT?", Prim_tagged_object_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (TAGGED_OBJECT_P (ARG_REF (1))));
+}
+
+DEFINE_PRIMITIVE ("%MAKE-TAGGED-OBJECT", Prim_make_tagged_object, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  Primitive_GC_If_Needed (2);
+  SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_TAGGED_OBJECT, Free));
+  (*Free++) = (ARG_REF (1));
+  (*Free++) = (ARG_REF (2));
+  PRIMITIVE_RETURN (result);
+}
+
+DEFINE_PRIMITIVE ("%TAGGED-OBJECT-TAG", Prim_tagged_object_tag, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, TAGGED_OBJECT_P);
+  PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 0));
+}
+
+DEFINE_PRIMITIVE ("%TAGGED-OBJECT-DATUM", Prim_tagged_object_datum, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, TAGGED_OBJECT_P);
+  PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 1));
+}

diff --git a/src/microcode/object.h b/src/microcode/object.h
index fcc36ee0a4be78ed897aea75e1300f6a8eebd179..197d3da622dc6581a7b412f01de3952cd3665777 100644 (file)
--- a/src/microcode/object.h
+++ b/src/microcode/object.h
@@ -182,6 +182,7 @@ extern SCHEME_OBJECT * memory_base;
 #define CELL_P(object) ((OBJECT_TYPE (object)) == TC_CELL)
 #define PAIR_P(object) ((OBJECT_TYPE (object)) == TC_LIST)
 #define WEAK_PAIR_P(object) ((OBJECT_TYPE (object)) == TC_WEAK_CONS)
+#define TAGGED_OBJECT_P(object) ((OBJECT_TYPE (object)) == TC_TAGGED_OBJECT)
 #define VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR)
 #define RECORD_P(object) ((OBJECT_TYPE (object)) == TC_RECORD)
 #define BOOLEAN_P(object) (((object) == SHARP_T) || ((object) == SHARP_F))
@@ -280,7 +281,8 @@ extern bool string_p (SCHEME_OBJECT);
    except that they have a zero byte at the end that isn't included in
    the string's length. */
 
-#define STRING_LENGTH_TO_GC_LENGTH(n_chars) (BYTEVECTOR_LENGTH_TO_GC_LENGTH ((n_chars) + 1))
+#define STRING_LENGTH_TO_GC_LENGTH(n_chars)                            \
+  (BYTEVECTOR_LENGTH_TO_GC_LENGTH ((n_chars) + 1))
 #define STRING_LENGTH BYTEVECTOR_LENGTH
 
 #define SET_STRING_LENGTH(s, n_chars) do                                \
@@ -310,8 +312,8 @@ extern bool string_p (SCHEME_OBJECT);
 #define BITS_LENGTH 4
 #define MIT_ASCII_LENGTH 25
 
-#define CHAR_BITS_META                 0x1
-#define CHAR_BITS_CONTROL      0x2
+#define CHAR_BITS_META         0x1
+#define CHAR_BITS_CONTROL      0x2
 #define CHAR_BITS_SUPER                0x4
 #define CHAR_BITS_HYPER                0x8
 

diff --git a/src/microcode/vector.c b/src/microcode/vector.c
index b2ad7f2cf2b6323427cedaa7c2c801ca09079dc2..a7193bf7dea92ab6f63144b24e16d5c8f7ca41c2 100644 (file)
--- a/src/microcode/vector.c
+++ b/src/microcode/vector.c
@@ -80,26 +80,34 @@ allocate_marked_vector (unsigned int type,
 }
 
 SCHEME_OBJECT
-make_vector (unsigned long length, SCHEME_OBJECT contents, bool gc_check_p)
+make_marked_vector (unsigned int type,
+                   unsigned long length,
+                   SCHEME_OBJECT fill_value,
+                   bool gc_check_p)
 {
   if (gc_check_p)
     Primitive_GC_If_Needed (length + 1);
-  {
-    SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
-    (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
-    while ((length--) > 0)
-      (*Free++) = contents;
-    return (result);
-  }
+  SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (type, Free));
+  (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
+  while ((length--) > 0)
+    (*Free++) = fill_value;
+  return (result);
+}
+
+SCHEME_OBJECT
+make_vector (unsigned long length, SCHEME_OBJECT filler, bool gc_check_p)
+{
+  return (make_marked_vector (TC_VECTOR, length, filler, gc_check_p));
 }
 \f
 DEFINE_PRIMITIVE ("ALLOCATE-NM-VECTOR", Prim_allocate_nm_vector, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
   PRIMITIVE_RETURN
-    (allocate_non_marked_vector ((arg_ulong_index_integer (1, N_TYPE_CODES)),
-                                 (arg_ulong_index_integer (2, (1UL << DATUM_LENGTH))),
-                                 true));
+    (allocate_non_marked_vector
+     ((arg_ulong_index_integer (1, N_TYPE_CODES)),
+      (arg_ulong_index_integer (2, (1UL << DATUM_LENGTH))),
+      true));
 }
 
 DEFINE_PRIMITIVE ("VECTOR-CONS", Prim_vector_cons, 2, 2, 0)
@@ -124,6 +132,16 @@ DEFINE_PRIMITIVE ("VECTOR", Prim_vector, 0, LEXPR, 0)
   }
 }
 
+DEFINE_PRIMITIVE ("%MAKE-RECORD", Prim_make_record, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (make_marked_vector (TC_RECORD,
+                        (arg_ulong_index_integer (1, (1UL << DATUM_LENGTH))),
+                        (ARG_REF (2)),
+                        true));
+}
+
 DEFINE_PRIMITIVE ("%RECORD", Prim_record, 0, LEXPR, 0)
 {
   PRIMITIVE_HEADER (LEXPR);

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 7d35ad1a6cdbba940f36d9b5cad8c1c40cb293d7..6c9333fde16bc6a005c69cd1742bb772820a5efc 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -29,6 +29,28 @@ USA.
 
 (declare (usual-integrations))
 \f
+;;; These primitives are the building blocks for many other types.
+(define-primitives
+  (%make-tagged-object 2)
+  (%record -1)
+  (%record-length 1)
+  (%record-ref 2)
+  (%record-set! 3)
+  (%record? 1)
+  (%tagged-object-datum 1)
+  (%tagged-object-tag 1)
+  (%tagged-object? 1))
+
+(define (%make-record tag length #!optional init-value)
+  (let ((record
+        ((ucode-primitive %make-record 2)
+         length
+         (if (default-object? init-value)
+             #f
+             init-value))))
+    (%record-set! record 0 tag)
+    record))
+
 ;;;; Interrupt control
 
 (define interrupt-bit/stack     #x0001)

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index a592d8a8503aff092e817e106653cb35d49916ae..93b5de164cc90111daa95d1ff39312352fb69f91 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -166,7 +166,9 @@ USA.
 (add-boot-init!
  (lambda ()
    (register-predicate! predicate? 'predicate)
-   (register-predicate! tag-name? 'tag-name)))
+   (register-predicate! tag-name? 'tag-name)
+   (register-predicate! %record? '%record)
+   (register-predicate! %tagged-object? 'tagged-object)))
 
 ;;; Registration of standard predicates
 (add-boot-init!
@@ -279,7 +281,6 @@ USA.
                        '<= named-structure?)
    (register-predicate! population? 'population)
    (register-predicate! promise? 'promise)
-   (register-predicate! %record? '%record)
    (register-predicate! record? 'record
                        '<= %record?
                        '<= named-structure?)

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index f1d918a70aedfc41405118e530c4ae6a8bd1a668..815882bc11df5fffa20a233e51c815c70d5c0133 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -29,25 +29,12 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define-integrable (tagged-object? object)
-  (object-type? (ucode-type tagged-object) object))
-(register-predicate! tagged-object? 'tagged-object)
-
-(define-integrable (%make-tagged-object tag datum)
-  (system-pair-cons (ucode-type tagged-object) tag datum))
-
-(define-integrable (%tagged-object-tag object)
-  (system-pair-car object))
-
-(define-integrable (%tagged-object-datum object)
-  (system-pair-cdr object))
-
 (define (tagged-object-tag object)
-  (guarantee tagged-object? object 'tagged-object-tag)
+  (guarantee %tagged-object? object 'tagged-object-tag)
   (%tagged-object-tag object))
 
 (define (tagged-object-datum object)
-  (guarantee tagged-object? object 'tagged-object-datum)
+  (guarantee %tagged-object? object 'tagged-object-datum)
   (%tagged-object-datum object))
 
 (define (object->predicate object)
@@ -60,10 +47,10 @@ USA.
        (error "Unknown type code:" code))))
 
 (define (object->datum object)
-  (if (tagged-object? object)
+  (if (%tagged-object? object)
       (%tagged-object-datum object)
       object))
-\f
+
 ;;;; Tagging strategies
 
 (define (tagging-strategy:never predicate make-tag)
@@ -80,19 +67,16 @@ USA.
 (define (tagging-strategy:optional datum-test make-tag)
 
   (define (predicate object)
-    (or (tagged-object-test object)
+    (if (%tagged-object? object)
+       (tag<= (%tagged-object-tag object) tag)
         (datum-test object)))
 
-  (define (tagged-object-test object)
-    (and (tagged-object? object)
-        (tag<= (%tagged-object-tag object) tag)
-        (datum-test (%tagged-object-datum object))))
-
   (define (tagger datum #!optional tagger-name)
-    (guarantee datum-test datum tagger-name)
     (if (tag<= (object->tag datum) tag)
         datum
-        (%make-tagged-object tag datum)))
+       (begin
+         (guarantee datum-test datum tagger-name)
+         (%make-tagged-object tag datum))))
 
   (define tag
     (make-tag predicate tagger))

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 1af46d0e554ef2edb92d5bfcbd1d6e7c083139c8..ae78d5a041a90a8ea724096e0008c6b56fcde747 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -31,29 +31,10 @@ USA.
 ;;; conforms to R4RS proposal
 
 (declare (usual-integrations))
-
+\f
 (define-primitives
-  (%record -1)
-  (%record? 1)
-  (%record-length 1)
-  (%record-ref 2)
-  (%record-set! 3)
-  (primitive-object-ref 2)
-  (primitive-object-set! 3)
-  (primitive-object-set-type 2)
   (vector-cons 2))
 
-(define (%make-record tag length #!optional init-value)
-  (let ((record
-        ((ucode-primitive object-set-type)
-         (ucode-type record)
-         (vector-cons length
-                      (if (default-object? init-value)
-                          #f
-                          init-value)))))
-    (%record-set! record 0 tag)
-    record))
-
 (define-integrable (%record-tag record)
   (%record-ref record 0))
 
@@ -68,7 +49,7 @@ USA.
          ((fix:= index length))
        (%record-set! result index (%record-ref record index)))
       result)))
-\f
+
 (define record-type-type-tag)
 
 (define (initialize-record-type-type!)
@@ -85,7 +66,7 @@ USA.
     (%record-set! type 0 record-type-type-tag)
     (%record-set! type 1 record-type-type-tag))
   (initialize-structure-type-type!))
-
+\f
 (define (make-record-type type-name field-names
                          #!optional
                          default-inits unparser-method entity-unparser-method)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 32fdf1b7ba7c7aed02271c680925a9033019f7e7..d1dd8052a82db59c379b748e151c029c209fd480 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -135,6 +135,16 @@ USA.
   (files "boot")
   (parent (runtime))
   (export ()
+         %make-record
+         %make-tagged-object
+         %record
+         %record-length
+         %record-ref
+         %record-set!
+         %record?
+         %tagged-object-datum
+         %tagged-object-tag
+         %tagged-object?
          bracketed-unparser-method
          bytes-per-object
          default-object
@@ -3715,13 +3725,7 @@ USA.
          set-record-type-unparser-method!)
   (export ()
          %copy-record
-         %make-record
-         %record
-         %record-length
-         %record-ref
-         %record-set!
          %record-tag
-         %record?
          condition-type:no-such-slot
          condition-type:slot-error
          condition-type:uninitialized-slot

diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index 6e55375bea24aea37396476f12f9870051000b5f..e1cd2ed3df69c65204d94117ac4bf6d42a70b9ee 100644 (file)
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -41,11 +41,15 @@ USA.
     UNSPECIFIC))
 
 (define global-primitives
-  '((%RECORD %RECORD)
+  '((%MAKE-TAGGED-OBJECT %MAKE-TAGGED-OBJECT 2)
+    (%RECORD %RECORD)
     (%RECORD-LENGTH %RECORD-LENGTH)
     (%RECORD-REF %RECORD-REF)
     (%RECORD-SET! %RECORD-SET!)
     (%RECORD? %RECORD?)
+    (%TAGGED-OBJECT-DATUM %TAGGED-OBJECT-DATUM 1)
+    (%TAGGED-OBJECT-TAG %TAGGED-OBJECT-TAG 1)
+    (%TAGGED-OBJECT? %TAGGED-OBJECT? 1)
     (BIT-STRING->UNSIGNED-INTEGER BIT-STRING->UNSIGNED-INTEGER)
     (BIT-STRING-ALLOCATE BIT-STRING-ALLOCATE)
     (BIT-STRING-AND! BIT-STRING-AND!)