summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-01-16 11:26:25 +0100
committerAndy Wingo <wingo@pobox.com>2015-01-23 16:16:03 +0100
commit761338f60c3b61d210c1e2a85a00668843012681 (patch)
treecbe3b333a047e75fa4768b20c88c11d822540870
parentc2b61cf49ce56da2dce3d6da4c08c5a77c6a4cc5 (diff)
downloadguile-761338f60c3b61d210c1e2a85a00668843012681.tar.gz
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. (<class>): Add GOOPS metaclass flags from Scheme. (<applicable-struct-class>, <applicable-struct-with-setter-class>): 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.
-rw-r--r--libguile/goops.c62
-rw-r--r--libguile/goops.h4
-rw-r--r--module/oop/goops.scm50
3 files changed, 62 insertions, 54 deletions
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
@@ -217,6 +217,36 @@
(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 '()))
- (<class> (%make-root-class layout)))
+ (<class> (%make-vtable-vtable layout)))
+ (class-add-flags! <class> (logior vtable-flag-goops-class
+ vtable-flag-goops-valid))
(struct-set! <class> class-index-name '<class>)
(struct-set! <class> class-index-nfields (length slots))
(struct-set! <class> class-index-direct-supers '())
@@ -593,12 +625,16 @@ subclasses of @var{c}."
;;;
(define-standard-class <procedure-class> (<class>))
+
(define-standard-class <applicable-struct-class>
(<procedure-class>))
+(class-add-flags! <applicable-struct-class>
+ vtable-flag-applicable-vtable)
+
(define-standard-class <applicable-struct-with-setter-class>
(<applicable-struct-class>))
-(%bless-applicable-struct-vtables! <applicable-struct-class>
- <applicable-struct-with-setter-class>)
+(class-add-flags! <applicable-struct-with-setter-class>
+ vtable-flag-setter-vtable)
(define-standard-class <applicable> (<top>))
(define-standard-class <applicable-struct> (<object> <applicable>)
@@ -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> (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 <object>)
+ (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)