mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Manipulate GOOPS vtable flags from Scheme, for speed

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-01-16 11:26:25 +01:00
parent c2b61cf49c
commit 761338f60c
3 changed files with 62 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

62
libguile/goops.c
View file

@ -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

4
libguile/goops.h
View file

@ -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);

50
module/oop/goops.scm
View file

@ -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 '()))
(<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)