From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 13 Jan 2018 05:03:03 +0000 (-0800)
Subject: Implement tagged-object primitives and open-code them in compiler.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~375
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=874d5754cc0891436312031250de6165cb7aa554;p=mit-scheme.git

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 f5e0a36cd..087e4b1e4 100644
--- 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 5a7b021f0..85a984ccc 100644
--- 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 d99a210c2..f207425b6 100644
--- 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);
 }
+
+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 fcc36ee0a..197d3da62 100644
--- 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 b2ad7f2cf..a7193bf7d 100644
--- 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));
 }
 
 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 7d35ad1a6..6c9333fde 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -29,6 +29,28 @@ USA.
 
 (declare (usual-integrations))
 
+;;; 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 a592d8a85..93b5de164 100644
--- 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 f1d918a70..815882bc1 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -29,25 +29,12 @@ USA.
 
 (declare (usual-integrations))
 
-(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))
-
+
 ;;;; 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 1af46d0e5..ae78d5a04 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -31,29 +31,10 @@ USA.
 ;;; conforms to R4RS proposal
 
 (declare (usual-integrations))
-
+
 (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)))
-
+
 (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!))
-
+
 (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 32fdf1b7b..d1dd8052a 100644
--- 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 6e55375be..e1cd2ed3d 100644
--- 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!)