From 874d5754cc0891436312031250de6165cb7aa554 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 12 Jan 2018 21:03:03 -0800 Subject: [PATCH] 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. --- src/compiler/base/utils.scm | 12 ++++++++- src/compiler/rtlgen/opncod.scm | 30 ++++++++++++++-------- src/microcode/list.c | 30 ++++++++++++++++++++++ src/microcode/object.h | 8 +++--- src/microcode/vector.c | 40 ++++++++++++++++++++++-------- src/runtime/boot.scm | 22 ++++++++++++++++ src/runtime/predicate-metadata.scm | 5 ++-- src/runtime/predicate-tagging.scm | 34 +++++++------------------ src/runtime/record.scm | 25 +++---------------- src/runtime/runtime.pkg | 16 +++++++----- src/sf/gconst.scm | 6 ++++- 11 files changed, 146 insertions(+), 82 deletions(-) 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!) -- 2.25.1