From: Florian Ragwitz Date: Mon, 16 Mar 2009 17:55:46 +0000 (+0100) Subject: Start creating a simple c api for meta instances and attributes. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ef9f032cd428b39edef595ed575e0b4820fd473e;p=gitmo%2FClass-MOP.git Start creating a simple c api for meta instances and attributes. This will hopefully allow to make attribute access and instance construction quite a bit faster. --- diff --git a/cmop/mop_attr.c b/cmop/mop_attr.c new file mode 100644 index 0000000..7841b4b --- /dev/null +++ b/cmop/mop_attr.c @@ -0,0 +1,314 @@ +#include "mop.h" + +#undef ATTRFLAGS +#define ATTRFLAGS(attr) (attr->flags) + +typedef union { + SV *sv; + char *method; + svtype type; +} default_t; + +struct mop_attr_St { + U32 flags; + + SV *slot_sv; /* value of the slot (currently always slot name) */ + U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */ + + SV *init_arg_sv; /* maybe the sv + U32 for hash keys should be a type of its own */ + U32 init_arg_u32; + + default_t default_value; + CV *initializer; + + SV *perl_attr; +}; + +static void +initialize_slots (mop_attr_t *attr, SV *perl_attr) +{ + dSP; + I32 count; + SV *slot_sv; + const char *slot_pv; + STRLEN len; + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_attr); + PUTBACK; + + count = call_method ("slots", G_ARRAY); + + if (count != 1) { + croak ("currently only one slot per attr is supported"); + } + + SPAGAIN; + + slot_sv = POPs; + slot_pv = SvPV (slot_sv, len); + + PERL_HASH (attr->slot_u32, slot_pv, len); + attr->slot_sv = newSVpvn_share (slot_pv, len, attr->slot_u32); + + PUTBACK; + FREETMPS; + LEAVE; + sv_dump (attr->slot_sv); +} + +static void +initialize_init_arg (mop_attr_t *attr, SV *perl_attr) +{ + dSP; + I32 count; + SV *init_arg_sv; + + if (!mop_call_predicate (perl_attr, "has_init_arg")) { + return; + } + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_attr); + PUTBACK; + + count = call_method ("init_arg", G_SCALAR); + + if (count != 1) { + croak ("init_arg didn't return exactly one value"); + } + + SPAGAIN; + + init_arg_sv = POPs; + if (init_arg_sv != &PL_sv_undef) { + STRLEN len; + const char *init_arg_pv = SvPV (init_arg_sv, len); + PERL_HASH (attr->init_arg_u32, init_arg_pv, len); + attr->init_arg_sv = newSVpvn_share (init_arg_pv, len, attr->init_arg_u32); + ATTRFLAGS(attr) |= ATTR_INIT_ARG; + } + + PUTBACK; + FREETMPS; + LEAVE; +} + +static bool +is_simple_refgen (CV *cv, svtype *default_type) +{ + /* TODO: inspect cv root. see if it it only creates a new empty anonymous reference */ + return FALSE; +} + +static void +initialize_default_normal (mop_attr_t *attr, SV *perl_attr) +{ + dSP; + I32 count; + SV *default_sv; + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_attr); + PUTBACK; + + count = call_method ("default", G_SCALAR); + + if (count != 1) { + croak ("default didn't return exactly one value"); + } + + SPAGAIN; + + default_sv = POPs; + if (SvROK (default_sv)) { + svtype default_type; + + if (SvTYPE (SvRV (default_sv)) != SVt_PVCV) { + croak ("default value reference is not a coderef"); + } + + if (is_simple_refgen ((CV *)SvRV (default_sv), &default_type)) { + attr->default_value.type = default_type; + ATTRFLAGS (attr) |= (mop_attr_default_refgen << ATTR_DEFAULT_SHIFT); + } + else { + attr->default_value.sv = newSVsv (default_sv); + ATTRFLAGS (attr) |= (ATTR_DEFAULT_REFCOUNTED | (mop_attr_default_normal << ATTR_DEFAULT_SHIFT)); + } + } + else { + attr->default_value.sv = newSVsv (default_sv); + ATTRFLAGS (attr) |= (ATTR_DEFAULT_REFCOUNTED | (mop_attr_default_normal << ATTR_DEFAULT_SHIFT)); + } + + PUTBACK; + FREETMPS; + LEAVE; +} + +static void +initialize_default_builder (mop_attr_t *attr, SV *perl_attr) +{ + dSP; + I32 count; + const char *builder; + STRLEN len; + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_attr); + PUTBACK; + + count = call_method ("builder", G_SCALAR); + + if (count != 1) { + croak ("builder didn't return exactly one value"); + } + + SPAGAIN; + + builder = SvPV (POPs, len); + attr->default_value.method = strndup (builder, len); + ATTRFLAGS (attr) |= (mop_attr_default_builder << ATTR_DEFAULT_SHIFT); + + PUTBACK; + FREETMPS; + LEAVE; +} + +static void +initialize_default (mop_attr_t *attr, SV *perl_attr) +{ + if (mop_call_predicate (perl_attr, "has_default")) { + initialize_default_normal (attr, perl_attr); + } + else if (mop_call_predicate (perl_attr, "has_builder")) { + initialize_default_builder (attr, perl_attr); + } +} + +static void +initialize_initializer (mop_attr_t *attr, SV *perl_attr) +{ + dSP; + I32 count; + SV *initializer; + + if (!mop_call_predicate (perl_attr, "has_initializer")) { + return; + } + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_attr); + PUTBACK; + + count = call_method ("initializer", G_SCALAR); + + if (count != 1) { + croak ("initializer didn't return exactly one value"); + } + + SPAGAIN; + + initializer = POPs; + + if (!SvROK (initializer) || (SvTYPE (SvRV (initializer)) != SVt_PVCV)) { + croak ("initializer is not a code reference"); + } + + attr->initializer = (CV *)SvRV (initializer); + SvREFCNT_inc ((SV *)attr->initializer); + ATTRFLAGS (attr) |= ATTR_INITIALIZER; + + PUTBACK; + FREETMPS; + LEAVE; +} + +mop_attr_t * +mop_attr_new_from_perl_attr (SV *perl_attr) +{ + /* TODO: break this up so constructing a mop_attr_t from c space is easy */ + mop_attr_t *attr; + dXCPT; + + Newxz (attr, 1, mop_attr_t); + attr->perl_attr = newSVsv (perl_attr); /* should we hold onto a reference or copy? */ + + XCPT_TRY_START { + initialize_slots (attr, perl_attr); + initialize_init_arg (attr, perl_attr); + initialize_default (attr, perl_attr); + initialize_initializer (attr, perl_attr); + } XCPT_TRY_END + + XCPT_CATCH { + mop_attr_destroy (attr); + XCPT_RETHROW; + } + + warn ("creating attr with slow value 0x%x", (unsigned int)attr->slot_sv); + + return attr; +} + +void +mop_attr_destroy (mop_attr_t *attr) +{ + warn ("destroying attr 0x%x", (unsigned int)attr); + + if (attr->slot_sv) { + SvREFCNT_dec (attr->slot_sv); + } + + if (ATTR_HAS_INIT_ARG (attr) && attr->init_arg_sv) { + SvREFCNT_dec (attr->init_arg_sv); + } + + if (ATTR_HAS_INITIALIZER (attr) && attr->initializer) { + SvREFCNT_dec ((SV *)attr->initializer); + } + + switch (ATTR_DEFAULT_TYPE (attr)) { + case mop_attr_default_builder: + free (attr->default_value.method); + break; + case mop_attr_default_normal: + if (ATTRFLAGS (attr) & ATTR_DEFAULT_REFCOUNTED) { + SvREFCNT_dec (attr->default_value.sv); + } + break; + default: /* refgen and none */ + break; + } + + SvREFCNT_dec (attr->perl_attr); + Safefree (attr); +} + +U32 +mop_attr_get_flags (mop_attr_t *attr) +{ + return attr->flags; +} + +SV * +mop_attr_get_perl_attr (mop_attr_t *attr) +{ + return attr->perl_attr; +} diff --git a/cmop/mop_instance.c b/cmop/mop_instance.c new file mode 100644 index 0000000..051d839 --- /dev/null +++ b/cmop/mop_instance.c @@ -0,0 +1,126 @@ +#include "mop.h" + +struct mop_instance_St { + mop_instance_type_t type; + HV *stash; + UV n_attrs; + mop_attr_t **attrs; +}; + +mop_instance_t * +mop_instance_new (mop_instance_type_t type, HV *stash) +{ + mop_instance_t *instance; + + Newx (instance, 1, mop_instance_t); + instance->type = type; + instance->stash = stash; + instance->n_attrs = 0; + instance->attrs = NULL; + + SvREFCNT_inc ((SV *)stash); + + return instance; +} + +static void +initialize_attrs_from_perl_instance (mop_instance_t *instance, SV *perl_instance) +{ + dSP; + I32 count; + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_instance); + PUTBACK; + + count = call_method ("get_all_attributes", G_ARRAY); + + SPAGAIN; + + while (count--) { + SV *perl_attr = POPs; + mop_instance_add_attribute (instance, mop_attr_new_from_perl_attr (perl_attr)); + } + + PUTBACK; + FREETMPS; + LEAVE; +} + +mop_instance_t * +mop_instance_new_from_perl_instance (SV *perl_instance) +{ + mop_instance_t *instance; + dSP; + I32 count; + SV *class; + + if (!sv_derived_from (perl_instance, "Class::MOP::Instance")) { + croak ("not a Class::MOP::Instance"); + } + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + XPUSHs (perl_instance); + PUTBACK; + + count = call_method ("_class_name", G_SCALAR); + + if (count != 1) { + croak ("_class_name returned %d values, expected 1", (int)count); + } + + SPAGAIN; + + class = POPs; + + /* TODO: don't hardcode type_hash */ + instance = mop_instance_new (mop_instance_type_hash, gv_stashsv (class, 0)); + + PUTBACK; + FREETMPS; + LEAVE; + + initialize_attrs_from_perl_instance (instance, perl_instance); + + return instance; +} + +void +mop_instance_destroy (mop_instance_t *instance) +{ + U32 i; + + for (i = 0; i < instance->n_attrs; i++) { + mop_attr_destroy (instance->attrs[i]); + } + + Safefree (instance->attrs); + SvREFCNT_dec ((SV *)instance->stash); + Safefree (instance); +} + +mop_instance_type_t +mop_instance_get_type (mop_instance_t *instance) +{ + return instance->type; +} + +HV * +mop_instance_get_stash (mop_instance_t *instance) +{ + return instance->stash; +} + +void +mop_instance_add_attribute (mop_instance_t *instance, mop_attr_t *attr) +{ + Renew (instance->attrs, instance->n_attrs + 1, mop_attr_t *); + instance->attrs[instance->n_attrs] = attr; + instance->n_attrs++; +} diff --git a/include/mop.h b/include/mop.h index e32aace..217ed8b 100644 --- a/include/mop.h +++ b/include/mop.h @@ -12,6 +12,9 @@ #define NEED_sv_2pv_nolen #include "ppport.h" +#include "mop_attr.h" +#include "mop_instance.h" + #define MOP_CALL_BOOT(name) mop_call_xs(aTHX_ name, cv, mark); void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark); diff --git a/include/mop_attr.h b/include/mop_attr.h new file mode 100644 index 0000000..144022f --- /dev/null +++ b/include/mop_attr.h @@ -0,0 +1,40 @@ +#ifndef __MOP_ATTR_H__ +#define __MOP_ATTR_H__ + +typedef enum { + mop_attr_default_none = 1 << 0, + mop_attr_default_normal = 1 << 1, + mop_attr_default_builder = 1 << 2, + mop_attr_default_refgen = 1 << 3 +} mop_attr_default_type_t; + +#define ATTRFLAGS(attr) mop_attr_get_flags(attr) + +#define ATTR_WRITING_MASK 0x000000ff +#define ATTR_READING_MASK 0x0000ff00 +#define ATTR_INSTANCE_MASK 0xff000000 + +#define ATTR_WRITING_FLAGS(attr) (ATTRFLAGS (attr) & ATTR_WRITING_MASK) +#define ATTR_READING_FLAGS(attr) (ATTRFLAGS (attr) & ATTR_READING_MASK) +#define ATTR_INSTANCE_FLAGS(attr) (ATTRFLAGS (attr) & ATTR_INSTANCE_MASK) + +#define ATTR_DEFAULT_MASK 0x700 +#define ATTR_DEFAULT_SHIFT 8 +#define ATTR_DEFAULT_REFCOUNTED 0x1000 + +#define ATTR_DEFAULT_TYPE(attr) ((mop_attr_default_type_t)((ATTR_READING_FLAGS (attr) & ATTR_DEFAULT_MASK) >> ATTR_DEFAULT_SHIFT)) + +#define ATTR_INIT_ARG 0x20000 +#define ATTR_INITIALIZER 0x40000 + +#define ATTR_HAS_INIT_ARG(attr) (ATTRFLAGS (attr) & ATTR_INIT_ARG) +#define ATTR_HAS_INITIALIZER(attr) (ATTRFLAGS (attr) & ATTR_INITIALIZER) + +typedef struct mop_attr_St mop_attr_t; + +mop_attr_t *mop_attr_new_from_perl_attr (SV *perl_attr); +void mop_attr_destroy (mop_attr_t *attr); +U32 mop_attr_get_flags (mop_attr_t *attr); +SV *mop_attr_get_perl_attr (mop_attr_t *attr); + +#endif diff --git a/include/mop_instance.h b/include/mop_instance.h new file mode 100644 index 0000000..1bed007 --- /dev/null +++ b/include/mop_instance.h @@ -0,0 +1,17 @@ +#ifndef __MOP_INSTANCE_H__ +#define __MOP_INSTANCE_H__ + +typedef enum { + mop_instance_type_hash +} mop_instance_type_t; + +typedef struct mop_instance_St mop_instance_t; + +mop_instance_t *mop_instance_new_from_perl_instance (SV *perl_instance); +void mop_instance_destroy (mop_instance_t *instance); + +mop_instance_type_t mop_instance_get_type (mop_instance_t *instance); +HV *mop_instance_get_stash (mop_instance_t *instance); +void mop_instance_add_attribute (mop_instance_t *instance, mop_attr_t *attr); + +#endif diff --git a/xs/Instance.xs b/xs/Instance.xs new file mode 100644 index 0000000..a2f6e36 --- /dev/null +++ b/xs/Instance.xs @@ -0,0 +1,17 @@ +#include "mop.h" + +MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance + +PROTOTYPES: DISABLE + +void +create_c_instance (self) + SV *self + PREINIT: + mop_instance_t *instance; + CODE: + instance = mop_instance_new_from_perl_instance (self); + __asm__ __volatile__ ("int $03"); + if (instance) { + mop_instance_destroy (instance); + } diff --git a/xs/MOP.xs b/xs/MOP.xs index f92a1cc..2de0e8d 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -16,6 +16,7 @@ EXTERN_C XS(boot_Class__MOP__Package); EXTERN_C XS(boot_Class__MOP__Class); EXTERN_C XS(boot_Class__MOP__Attribute); EXTERN_C XS(boot_Class__MOP__Method); +EXTERN_C XS(boot_Class__MOP__Instance); MODULE = Class::MOP PACKAGE = Class::MOP @@ -32,6 +33,7 @@ BOOT: MOP_CALL_BOOT (boot_Class__MOP__Class); MOP_CALL_BOOT (boot_Class__MOP__Attribute); MOP_CALL_BOOT (boot_Class__MOP__Method); + MOP_CALL_BOOT (boot_Class__MOP__Instance); # use prototype here to be compatible with get_code_info from Sub::Identify void