From: Andy Wingo Date: Fri, 16 Jan 2015 10:26:25 +0000 (+0100) Subject: Manipulate GOOPS vtable flags from Scheme, for speed X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/761338f60c3b61d210c1e2a85a00668843012681 Manipulate GOOPS vtable flags from Scheme, for speed * libguile/goops.h: Remove unimplemented declarations of scm_make_next_method, scm_sys_invalidate_method_cache_x, and stklos_version. (scm_sys_invalidate_class_x): Remove helper definition. This was exported in the past but shouldn't have been. * libguile/goops.c (scm_sys_make_vtable_vtable): Rename from scm_sys_make_root_class, and don't do anything about flags. (scm_sys_bless_applicable_struct_vtables_x, scm_class_p) (scm_sys_invalidate_class_x): Remove; we do these in Scheme now. (scm_init_goops_builtins): Define Scheme values for vtable flags. * module/oop/goops.scm (vtable-flag-goops-metaclass) (class-add-flags!, class-clear-flags!, class-has-flags?) (class?, instance?): New definitions. (): Add GOOPS metaclass flags from Scheme. (, ): Add flags from Scheme. (make, initialize): Add class flags as appropriate. (class-redefinition): Clear the "valid" flag on the old class. (check-slot-args): Use instance? instead of a CPL check. --- diff --git a/libguile/goops.c b/libguile/goops.c index f2ca98194..42b7a1b33 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -156,10 +156,7 @@ SCM scm_module_goops; static SCM scm_make_unbound (void); static SCM scm_unbound_p (SCM obj); -static SCM scm_class_p (SCM obj); -static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable, - SCM setter); -static SCM scm_sys_make_root_class (SCM layout); +static SCM scm_sys_make_vtable_vtable (SCM layout); static SCM scm_sys_init_layout_x (SCM class, SCM layout); static SCM scm_sys_clear_fields_x (SCM obj); static SCM scm_sys_goops_early_init (void); @@ -168,30 +165,12 @@ static SCM scm_sys_goops_loaded (void); -SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 1, 0, 0, +SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0, (SCM layout), "") -#define FUNC_NAME s_scm_sys_make_root_class +#define FUNC_NAME s_scm_sys_make_vtable_vtable { - SCM z; - - z = scm_i_make_vtable_vtable (layout); - SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); - - return z; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0, - (SCM applicable, SCM setter), - "") -#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x -{ - SCM_VALIDATE_CLASS (1, applicable); - SCM_VALIDATE_CLASS (2, setter); - SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); - SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE); - return SCM_UNSPECIFIED; + return scm_i_make_vtable_vtable (layout); } #undef FUNC_NAME @@ -357,15 +336,6 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_class_p, "class?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a class.") -#define FUNC_NAME s_scm_class_p -{ - return scm_from_bool (SCM_CLASSP (obj)); -} -#undef FUNC_NAME - int scm_is_generic (SCM x) { @@ -617,17 +587,6 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, - (SCM class), - "") -#define FUNC_NAME s_scm_sys_invalidate_class -{ - SCM_VALIDATE_CLASS (1, class); - SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - /* When instances change class, they finally get a new body, but * before that, they go through purgatory in hell. Odd as it may * seem, this data structure saves us from eternal suffering in @@ -1143,6 +1102,19 @@ scm_init_goops_builtins (void *unused) hell_mutex = scm_make_mutex (); #include "libguile/goops.x" + + scm_c_define ("vtable-flag-vtable", + scm_from_int (SCM_VTABLE_FLAG_VTABLE)); + scm_c_define ("vtable-flag-applicable-vtable", + scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE)); + scm_c_define ("vtable-flag-setter-vtable", + scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE)); + scm_c_define ("vtable-flag-validated", + scm_from_int (SCM_VTABLE_FLAG_VALIDATED)); + scm_c_define ("vtable-flag-goops-class", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS)); + scm_c_define ("vtable-flag-goops-valid", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID)); } void diff --git a/libguile/goops.h b/libguile/goops.h index ca9c41bf0..e83bf093b 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -93,7 +93,6 @@ SCM_API SCM scm_ensure_accessor (SCM name); SCM_API SCM scm_class_of (SCM obj); /* Low level functions exported */ -SCM_API SCM scm_make_next_method (SCM methods, SCM args, SCM gf); SCM_INTERNAL SCM scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots); @@ -125,13 +124,10 @@ SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name); SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name); SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst); SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls); -SCM_API SCM scm_sys_invalidate_class (SCM cls); -SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf); SCM_API SCM scm_generic_capability_p (SCM proc); SCM_API SCM scm_enable_primitive_generic_x (SCM subrs); SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic); SCM_API SCM scm_primitive_generic_generic (SCM subr); -SCM_API SCM stklos_version (void); SCM_API SCM scm_make (SCM args); SCM_API void scm_change_object_class (SCM, SCM, SCM); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 41b422686..4464daa29 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -216,6 +216,36 @@ tail)))))) (fold-class-slots macro-fold-left define-class-index (begin))) +;;; +;;; Structs that are vtables have a "flags" slot, which corresponds to +;;; class-index-flags. `vtable-flag-vtable' indicates that instances of +;;; a vtable are themselves vtables, and `vtable-flag-validated' +;;; indicates that the struct's layout has been validated. goops.c +;;; defines a couple of additional flags: one to indicate that a vtable +;;; is actually a class, and one to indicate that the class is "valid", +;;; meaning that it hasn't been redefined. +;;; +(define vtable-flag-goops-metaclass + (logior vtable-flag-vtable vtable-flag-goops-class)) + +(define-inlinable (class-add-flags! class flags) + (struct-set! class class-index-flags + (logior flags (struct-ref class class-index-flags)))) + +(define-inlinable (class-clear-flags! class flags) + (struct-set! class class-index-flags + (logand (lognot flags) (struct-ref class class-index-flags)))) + +(define-inlinable (class-has-flags? class flags) + (eqv? flags + (logand (struct-ref class class-index-flags) flags))) + +(define-inlinable (class? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass)) + +(define-inlinable (instance? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-class)) + ;;; ;;; Now that we know the slots that must be present in classes, and ;;; their offsets, we can create the root of the class hierarchy. @@ -249,7 +279,9 @@ ((_ (name class) tail) (cons (list 'name) tail))))) (let* ((layout (fold-class-slots macro-fold-right cons-layout "")) (slots (fold-class-slots macro-fold-right cons-slot '())) - ( (%make-root-class layout))) + ( (%make-vtable-vtable layout))) + (class-add-flags! (logior vtable-flag-goops-class + vtable-flag-goops-valid)) (struct-set! class-index-name ') (struct-set! class-index-nfields (length slots)) (struct-set! class-index-direct-supers '()) @@ -593,12 +625,16 @@ subclasses of @var{c}." ;;; (define-standard-class ()) + (define-standard-class ()) +(class-add-flags! + vtable-flag-applicable-vtable) + (define-standard-class ()) -(%bless-applicable-struct-vtables! - ) +(class-add-flags! + vtable-flag-setter-vtable) (define-standard-class ()) (define-standard-class ( ) @@ -764,6 +800,8 @@ followed by its associated value. If @var{l} does not hold a value for (#:body body ()) (#:make-procedure make-procedure #f)))) ((memq (class-precedence-list class)) + (class-add-flags! z (logior vtable-flag-goops-class + vtable-flag-goops-valid)) (for-each (match-lambda ((kw slot default) (slot-set! z slot (get-keyword kw args default)))) @@ -817,7 +855,7 @@ followed by its associated value. If @var{l} does not hold a value for (unless (class? class) (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f)) - (unless (is-a? obj ) + (unless (instance? obj) (scm-error 'wrong-type-arg #f "Not an instance: ~S" (list obj) #f)) (unless (symbol? slot-name) @@ -2239,7 +2277,7 @@ followed by its associated value. If @var{l} does not hold a value for ;; Invalidate class so that subsequent instances slot accesses invoke ;; change-object-class (struct-set! new class-index-redefined old) - (%invalidate-class new) ;must come after slot-set! + (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set! old) @@ -2544,6 +2582,8 @@ var{initargs}." (next-method) (let ((dslots (get-keyword #:slots initargs '())) (supers (get-keyword #:dsupers initargs '()))) + (class-add-flags! class (logior vtable-flag-goops-class + vtable-flag-goops-valid)) (let ((name (get-keyword #:name initargs '???))) (struct-set! class class-index-name name)) (struct-set! class class-index-nfields 0)