From 20f68a318d9588914f62ddafcc6c24a903a2613c Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 17 Mar 2018 16:38:30 -0700 Subject: [PATCH] Allow a record to be both applicable and fasdumpable. --- src/microcode/fixobj.h | 6 ++--- src/microcode/object.h | 4 +++ src/microcode/utabmd.c | 5 ++++ src/microcode/vector.c | 37 ++++++++++++++----------- src/runtime/record.scm | 61 ++++++++++++++++++++++++------------------ 5 files changed, 68 insertions(+), 45 deletions(-) diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h index e1269bc52..5df8b48ec 100644 --- a/src/microcode/fixobj.h +++ b/src/microcode/fixobj.h @@ -51,7 +51,7 @@ USA. #define FIXOBJ_RECORD_APP_INDEX 0x12 /* Index of record applicator. */ #define DUMMY_HISTORY 0x13 /* Empty history structure. */ #define Bignum_One 0x14 /* Cache for bignum one. */ -/* #define UNUSED 0x15 */ +#define FIXOBJ_PROXIED_RECORD_TYPES 0x15 #define Termination_Vector 0x16 /* Names for terminations. */ #define Termination_Proc_Vector 0x17 /* Handlers for terminations. */ /* #define UNUSED 0x18 */ @@ -141,7 +141,7 @@ USA. /* 0x12 */ "record-applicator-index", \ /* 0x13 */ "dummy-history", \ /* 0x14 */ "bignum-one", \ - /* 0x15 */ 0, \ + /* 0x15 */ "proxied-record-types", \ /* 0x16 */ "microcode-terminations-vector", \ /* 0x17 */ "microcode-terminations-procedures", \ /* 0x18 */ 0, \ @@ -184,7 +184,7 @@ USA. /* 0x3D */ "pc-sample/prob-comp-table", \ /* 0x3E */ "pc-sample/ufo-table", \ /* 0x3F */ "compiled-code-bkpt-handler", \ - /* 0x40 */ 0 , \ + /* 0x40 */ 0, \ /* 0x41 */ "callback-handler", \ /* 0x42 */ 0, \ /* 0x43 */ 0, \ diff --git a/src/microcode/object.h b/src/microcode/object.h index 063830c4d..ccaa59f02 100644 --- a/src/microcode/object.h +++ b/src/microcode/object.h @@ -500,6 +500,8 @@ extern bool string_p (SCHEME_OBJECT); 8 #!aux 9 '() 10 weak #f + ... + 0x100 -> 0x1FF reserved for fasdumpable records */ #define SHARP_F MAKE_OBJECT (TC_FALSE, 0) @@ -507,6 +509,8 @@ extern bool string_p (SCHEME_OBJECT); #define UNSPECIFIC MAKE_OBJECT (TC_CONSTANT, 1) #define DEFAULT_OBJECT MAKE_OBJECT (TC_CONSTANT, 7) #define EMPTY_LIST MAKE_OBJECT (TC_CONSTANT, 9) +#define FASDUMP_RECORD_MARKER_START 0x100 +#define FASDUMP_RECORD_MARKER_END 0x200 #define BROKEN_HEART_ZERO MAKE_OBJECT (TC_BROKEN_HEART, 0) /* Last immediate reference trap. */ diff --git a/src/microcode/utabmd.c b/src/microcode/utabmd.c index f91a31589..a24b20463 100644 --- a/src/microcode/utabmd.c +++ b/src/microcode/utabmd.c @@ -175,6 +175,11 @@ initialize_fixed_objects_vector (void) STORE_FIXOBJ (ARITY_DISPATCHER_TAG, (char_pointer_to_symbol ("#[(microcode)arity-dispatcher-tag]"))); + STORE_FIXOBJ (FIXOBJ_PROXIED_RECORD_TYPES, + (make_vector ((FASDUMP_RECORD_MARKER_END + - FASDUMP_RECORD_MARKER_START), + SHARP_F, + false))); #ifdef __WIN32__ NT_initialize_fov (fixed_objects); diff --git a/src/microcode/vector.c b/src/microcode/vector.c index 526dacb81..3661c587b 100644 --- a/src/microcode/vector.c +++ b/src/microcode/vector.c @@ -393,6 +393,8 @@ DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0) PRIMITIVE_RETURN (UNSPECIFIC); } +static SCHEME_OBJECT record_marker (SCHEME_OBJECT); + /* An applicable record is one whose tag is FIXOBJ_RECORD_TAG and which has an applicator at FIXOBJ_RECORD_APP_INDEX within that tag. It is applied just like an entity: the record is passed as the @@ -402,21 +404,24 @@ DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0) SCHEME_OBJECT record_applicator (SCHEME_OBJECT record) { - SCHEME_OBJECT metatag = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_TAG)); - SCHEME_OBJECT index_object - = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_APP_INDEX)); + SCHEME_OBJECT marker = (record_marker (record)); + return ((RECORD_P (marker)) + && ((VECTOR_REF (marker, 0)) + == (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_TAG)))) + ? (VECTOR_REF (marker, + (FIXNUM_TO_ULONG (VECTOR_REF (fixed_objects, + FIXOBJ_RECORD_APP_INDEX))))) + : SHARP_F; +} - if ((RECORD_P (metatag)) - && (FIXNUM_P (index_object)) - && (FIXNUM_TO_ULONG_P (index_object))) - { - unsigned long index = (FIXNUM_TO_ULONG (index_object)); - SCHEME_OBJECT tag = (VECTOR_REF (record, 0)); - if (RECORD_P (tag) - && ((VECTOR_REF (tag, 0)) == metatag) - && (index < (VECTOR_LENGTH (tag)))) { - return (VECTOR_REF (tag, index)); - } - } - return SHARP_F; +static SCHEME_OBJECT +record_marker (SCHEME_OBJECT record) +{ + SCHEME_OBJECT marker = (VECTOR_REF (record, 0)); + return (((OBJECT_TYPE (marker)) == TC_CONSTANT) + && ((OBJECT_DATUM (marker)) >= FASDUMP_RECORD_MARKER_START) + && ((OBJECT_DATUM (marker)) < FASDUMP_RECORD_MARKER_END)) + ? (VECTOR_REF ((VECTOR_REF (fixed_objects, FIXOBJ_PROXIED_RECORD_TYPES)), + ((OBJECT_DATUM (marker)) - FASDUMP_RECORD_MARKER_START))) + : marker; } diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 0821af908..7fa99276f 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -82,15 +82,19 @@ USA. (define (%valid-default-inits? default-inits n-fields) (fix:= n-fields (length default-inits))) +(defer-boot-action 'record-procedures + (lambda () + (set! %valid-default-inits? + (named-lambda (%valid-default-inits? default-inits n-fields) + (and (fix:= n-fields (length default-inits)) + (every (lambda (init) + (or (not init) + (thunk? init))) + default-inits)))) + unspecific)) + (define (initialize-record-procedures!) - (set! %valid-default-inits? - (named-lambda (%valid-default-inits? default-inits n-fields) - (and (fix:= n-fields (length default-inits)) - (every (lambda (init) - (or (not init) - (thunk? init))) - default-inits)))) - (%initialize-applicator-context!)) + (run-deferred-boot-actions 'record-procedures)) (define %record-metatag) (define record-type?) @@ -159,8 +163,6 @@ USA. (guarantee record-type? record-type 'set-record-type-applicator!) (if applicator (guarantee procedure? applicator 'set-record-type-applicator!)) - (if (%record-type-fasdumpable? record-type) - (error "Record types can't be applicable and fasdumpable:" record-type)) (%set-record-type-applicator! record-type applicator)) (define (record? object) @@ -191,18 +193,25 @@ USA. (register-predicate! %record-type-proxy? 'record-type-proxy) (define (set-record-type-fasdumpable! type proxy) - (guarantee record-type? type 'set-record-type-fasdumpable!) - (guarantee %record-type-proxy? proxy 'set-record-type-fasdumpable!) - (if (%record-type-applicator type) - (error "Record types can't be applicable and fasdumpable:" type)) - (without-interrupts - (lambda () - (if (%record-type-fasdumpable? type) - (error "Record type already fasdumpable:" type)) - (if (%proxy->record-type proxy) - (error "Record-type proxy already in use:" proxy)) - (%set-proxied-record-type! proxy type) - (%set-record-type-instance-marker! type proxy)))) + (defer-boot-action 'record-procedures + (lambda () + (set-record-type-fasdumpable! type proxy)))) + +(defer-boot-action 'record-procedures + (lambda () + (set! set-record-type-fasdumpable! + (named-lambda (set-record-type-fasdumpable! type proxy) + (guarantee record-type? type 'set-record-type-fasdumpable!) + (guarantee %record-type-proxy? proxy 'set-record-type-fasdumpable!) + (without-interrupts + (lambda () + (if (%record-type-fasdumpable? type) + (error "Record type already fasdumpable:" type)) + (if (%proxy->record-type proxy) + (error "Record-type proxy already in use:" proxy)) + (%set-proxied-record-type! proxy type) + (%set-record-type-instance-marker! type proxy))))) + unspecific)) (define-integrable (%record-type-proxy->index marker) (fix:- (object-new-type (ucode-type fixnum) marker) #x100)) @@ -217,10 +226,10 @@ USA. (vector-set! %proxied-record-types (%record-type-proxy->index proxy) type)) (define %proxied-record-types) -(add-boot-init! - (lambda () - (set! %proxied-record-types (make-vector #x100 #f)) - unspecific)) +(defer-boot-action 'record-procedures + (lambda () + (set! %proxied-record-types (fixed-objects-item 'proxied-record-types)) + unspecific)) (define record-type-proxy:pathname (%index->record-type-proxy 0)) (define record-type-proxy:host (%index->record-type-proxy 1)) -- 2.25.1