You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@lucy.apache.org by nw...@apache.org on 2017/04/16 10:50:45 UTC
[1/2] lucy-clownfish git commit: Allow Perl subclasses to use hashrefs
Repository: lucy-clownfish
Updated Branches:
refs/heads/master d601b8b8b -> 74c12c7ef
Allow Perl subclasses to use hashrefs
If a parent class without ivars is subclassed from Perl, don't store
the pointer to the Clownfish object in the SV, but use a hashref as
underlying Perl object. This allows Perl subclasses to store their own
ivars directly in the hashref without having to resort to inside-out
objects.
This requires to create a host object wrapper whenever an object is
constructed or a Clownfish method is invoked. A similar approach can
be used by other host languages without class-based inheritance.
The perl_to_cfish functions now use Class_fetch and an is_a check based
on the Clownfish parent class pointer instead of calling sv_derived_from.
I haven't checked whether there's a performance impact, but this might
actually be faster than the old code.
The old inside-out approach is still supported by overloading scalar
dereferencing for host object wrappers.
Project: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/repo
Commit: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/commit/0bfeb23e
Tree: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/tree/0bfeb23e
Diff: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/diff/0bfeb23e
Branch: refs/heads/master
Commit: 0bfeb23eccec3519d2bf72126c5c9aea7464c4c8
Parents: d601b8b
Author: Nick Wellnhofer <we...@aevum.de>
Authored: Mon Mar 6 13:26:59 2017 +0100
Committer: Nick Wellnhofer <we...@aevum.de>
Committed: Sat Mar 18 20:57:21 2017 +0100
----------------------------------------------------------------------
compiler/src/CFCBindCore.c | 8 +
runtime/c/src/clownfish.c | 5 +
runtime/core/Clownfish/Class.c | 14 +-
runtime/core/Clownfish/Class.cfh | 5 +
runtime/go/ext/clownfish.c | 5 +
.../perl/buildlib/Clownfish/Build/Binding.pm | 30 +-
runtime/perl/t/binding/010-class.t | 11 +-
runtime/perl/t/binding/019-obj.t | 30 +-
runtime/perl/xs/XSBind.c | 341 ++++++++++++++++---
runtime/perl/xs/XSBind.h | 6 +
runtime/python/cfext/CFBind.c | 5 +
runtime/test/Clownfish/Test/TestHost.c | 26 +-
runtime/test/Clownfish/Test/TestHost.cfh | 21 ++
13 files changed, 431 insertions(+), 76 deletions(-)
----------------------------------------------------------------------
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/compiler/src/CFCBindCore.c
----------------------------------------------------------------------
diff --git a/compiler/src/CFCBindCore.c b/compiler/src/CFCBindCore.c
index 35f107b..cfe9d09 100644
--- a/compiler/src/CFCBindCore.c
+++ b/compiler/src/CFCBindCore.c
@@ -199,6 +199,12 @@ S_write_parcel_h(CFCBindCore *self, CFCParcel *parcel) {
" void *klass;\n"
"} cfish_Dummy;\n"
"\n"
+ "typedef struct cfish_HostObjWrapper {\n"
+ " CFISH_OBJ_HEAD\n"
+ " void *klass;\n"
+ " void *wrapped;\n"
+ "} cfish_HostObjWrapper;\n"
+ "\n"
"/* Access the function pointer for a given method from the object.\n"
" */\n"
"static CFISH_INLINE cfish_method_t\n"
@@ -287,6 +293,8 @@ S_write_parcel_h(CFCBindCore *self, CFCParcel *parcel) {
"/* Flags for internal use. */\n"
"#define CFISH_fREFCOUNTSPECIAL 0x00000001\n"
"#define CFISH_fFINAL 0x00000002\n"
+ "#define CFISH_fEMPTY 0x00000004\n"
+ "#define CFISH_fHOST 0x00000008\n"
;
const char *cfish_defs_2 =
"#ifdef CFISH_USE_SHORT_NAMES\n"
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/c/src/clownfish.c
----------------------------------------------------------------------
diff --git a/runtime/c/src/clownfish.c b/runtime/c/src/clownfish.c
index 239a796..5f4f7a4 100644
--- a/runtime/c/src/clownfish.c
+++ b/runtime/c/src/clownfish.c
@@ -165,6 +165,11 @@ Class_find_parent_class(String *class_name) {
UNREACHABLE_RETURN(String*);
}
+void
+Class_adjust_host_subclass(Class *klass) {
+ UNUSED_VAR(klass);
+}
+
/**** Method ***************************************************************/
String*
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/core/Clownfish/Class.c
----------------------------------------------------------------------
diff --git a/runtime/core/Clownfish/Class.c b/runtime/core/Clownfish/Class.c
index c5bbd34..5eaedb2 100644
--- a/runtime/core/Clownfish/Class.c
+++ b/runtime/core/Clownfish/Class.c
@@ -153,6 +153,9 @@ Class_bootstrap(const cfish_ParcelSpec *parcel_spec) {
if (spec->flags & cfish_ClassSpec_FINAL) {
klass->flags |= CFISH_fFINAL;
}
+ if (klass->obj_alloc_size == sizeof(Obj)) {
+ klass->flags |= CFISH_fEMPTY;
+ }
if (parent) {
// Copy parent vtable.
@@ -290,7 +293,7 @@ Class_init_registry() {
}
static Class*
-S_simple_subclass(Class *parent, String *name) {
+S_subclass_from_host(Class *parent, String *name) {
if (parent->flags & CFISH_fFINAL) {
THROW(ERR, "Can't subclass final class %o", Class_Get_Name(parent));
}
@@ -310,6 +313,13 @@ S_simple_subclass(Class *parent, String *name) {
memcpy(subclass->vtable, parent->vtable,
parent->class_alloc_size - offsetof(Class, vtable));
+ if ((subclass->flags & (CFISH_fHOST | CFISH_fEMPTY)) == CFISH_fEMPTY) {
+ // Subclassing an empty class for the first time.
+ subclass->flags |= CFISH_fHOST;
+ subclass->obj_alloc_size = sizeof(cfish_HostObjWrapper);
+ Class_adjust_host_subclass(subclass);
+ }
+
return subclass;
}
@@ -336,7 +346,7 @@ Class_singleton(String *class_name, Class *parent) {
}
}
- singleton = S_simple_subclass(parent, class_name);
+ singleton = S_subclass_from_host(parent, class_name);
// Allow host methods to override.
fresh_host_methods = Class_fresh_host_methods(class_name);
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/core/Clownfish/Class.cfh
----------------------------------------------------------------------
diff --git a/runtime/core/Clownfish/Class.cfh b/runtime/core/Clownfish/Class.cfh
index 3ac602c..f717a60 100644
--- a/runtime/core/Clownfish/Class.cfh
+++ b/runtime/core/Clownfish/Class.cfh
@@ -90,6 +90,11 @@ public final class Clownfish::Class inherits Clownfish::Obj {
inert incremented Vector*
fresh_host_methods(String *class_name);
+ /** Perform final adjustments to a host subclass.
+ */
+ inert void
+ adjust_host_subclass(Class *klass);
+
/** Replace a function pointer in the Class's vtable.
*/
public void
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/go/ext/clownfish.c
----------------------------------------------------------------------
diff --git a/runtime/go/ext/clownfish.c b/runtime/go/ext/clownfish.c
index 28f95b5..d05e4b7 100644
--- a/runtime/go/ext/clownfish.c
+++ b/runtime/go/ext/clownfish.c
@@ -169,6 +169,11 @@ Class_find_parent_class(String *class_name) {
UNREACHABLE_RETURN(String*);
}
+void
+Class_adjust_host_subclass(Class *klass) {
+ UNUSED_VAR(klass);
+}
+
void*
Class_To_Host_IMP(Class *self, void *vcache) {
UNUSED_VAR(self);
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/buildlib/Clownfish/Build/Binding.pm
----------------------------------------------------------------------
diff --git a/runtime/perl/buildlib/Clownfish/Build/Binding.pm b/runtime/perl/buildlib/Clownfish/Build/Binding.pm
index 9fa4942..9805d5b 100644
--- a/runtime/perl/buildlib/Clownfish/Build/Binding.pm
+++ b/runtime/perl/buildlib/Clownfish/Build/Binding.pm
@@ -82,11 +82,11 @@ PPCODE:
cfish_String *str = CFISH_Obj_To_String(obj);
CFISH_DECREF(str);
-int
-refcount(obj)
- cfish_Obj *obj;
+U32
+refcount(sv)
+ SV *sv;
CODE:
- RETVAL = (int)CFISH_REFCOUNT_NN(obj);
+ RETVAL = SvREFCNT(SvROK(sv) ? SvRV(sv) : sv);
OUTPUT: RETVAL
END_XS_CODE
@@ -750,27 +750,7 @@ void
DESTROY(sv)
SV *sv
PPCODE:
- if (sv_derived_from(sv, "Clownfish::Obj")) {
- /*
- * During global destruction, DESTROY is called in random order on
- * objects remaining because of refcount leaks or circular references.
- * This can cause memory corruption with Clownfish objects, so better
- * leak instead of corrupting memory.
- *
- * Unfortunately, Perl's global destruction is still severely broken
- * as of early 2017. Global "our" variables are destroyed in random
- * order even without circular references. The following check will
- * skip some objects that could be safely destroyed, but it's the
- * best we can do.
- *
- * See https://rt.perl.org/Ticket/Display.html?id=32714
- */
- SV *inner = SvRV(sv);
- if (!PL_dirty || SvREFCNT(inner) <= 1) {
- cfish_Obj *self = INT2PTR(cfish_Obj*, SvIV(inner));
- CFISH_Obj_Destroy(self);
- }
- }
+ XSBind_destroy(aTHX_ sv);
SV*
get_class(self)
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/t/binding/010-class.t
----------------------------------------------------------------------
diff --git a/runtime/perl/t/binding/010-class.t b/runtime/perl/t/binding/010-class.t
index 21872ff..a3cc619 100644
--- a/runtime/perl/t/binding/010-class.t
+++ b/runtime/perl/t/binding/010-class.t
@@ -30,7 +30,7 @@ my $storage = Clownfish::Hash->new;
{
my $subclassed_obj = MyObj->new;
- $stringified = $subclassed_obj->to_string;
+ $stringified = "$subclassed_obj";
isa_ok( $subclassed_obj, "MyObj", "Perl isa reports correct subclass" );
@@ -43,12 +43,13 @@ my $storage = Clownfish::Hash->new;
my $resurrected = $storage->fetch("test");
isa_ok( $resurrected, "MyObj", "subclass name survived Perl destruction" );
-is( $resurrected->to_string, $stringified,
- "It's the same Hash from earlier (though a different Perl object)" );
+is( "$resurrected", $stringified, "It's the same hashref from earlier" );
is( $resurrected->get_class_name,
"MyObj", "subclassed object still performs correctly at the C level" );
-my $methods = Clownfish::Class::_fresh_host_methods('MyObj');
-is_deeply( $methods->to_perl, ['oodle'], "fresh_host_methods" );
+my $methods = Clownfish::Class::_fresh_host_methods('MyObj')->to_perl;
+# Remove overload methods starting with '('.
+$methods = [ grep { $_ !~ /^\(/ } @$methods ];
+is_deeply( $methods, ['oodle'], "fresh_host_methods" );
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/t/binding/019-obj.t
----------------------------------------------------------------------
diff --git a/runtime/perl/t/binding/019-obj.t b/runtime/perl/t/binding/019-obj.t
index ee1be19..7e8ef0a 100644
--- a/runtime/perl/t/binding/019-obj.t
+++ b/runtime/perl/t/binding/019-obj.t
@@ -16,7 +16,8 @@
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 33;
+use Scalar::Util qw( refaddr reftype );
use Clownfish::Test;
package TestObj;
@@ -61,6 +62,15 @@ use base qw( Clownfish::Test::TestHost );
package SubclassFinalTestObj;
use base qw( Clownfish::Vector );
+package CtorDtorTestObj;
+use base qw( Clownfish::Test::TestHost );
+{
+ our $num_do_init_calls;
+ our $num_do_destroy_calls;
+ sub do_init { $num_do_init_calls += 1; }
+ sub do_destroy { $num_do_destroy_calls += 1; }
+}
+
package main;
use Storable qw( freeze thaw );
use Clownfish::Test;
@@ -71,8 +81,10 @@ ok( defined $TestObj::version,
);
my $object = TestObj->new;
-isa_ok( $object, "Clownfish::Obj",
- "Clownfish objects can be subclassed" );
+isa_ok( $object, "Clownfish::Obj", "Subclassed Clownfish object" );
+is( reftype($object), "HASH",
+ "Subclassed objects without ivars are hashrefs" );
+is( $$object, refaddr($object), "Overloaded scalar deref works" );
SKIP: {
skip( "Exception thrown within STORABLE hook leaks", 1 )
@@ -128,6 +140,8 @@ is( Clownfish::Test::refcount($object),
$object = SonOfTestObj->new;
like( $object->to_string, qr/STRING:.*?SonOfTestObj/,
"overridden XS bindings can be called via SUPER" );
+is( $$object, refaddr($object),
+ "Overloaded scalar deref works with Perl subclasses" );
SKIP: {
skip( "Exception thrown within callback leaks", 2 )
@@ -196,3 +210,13 @@ SKIP: {
pass( "Created LeakyObj" );
}
+$CtorDtorTestObj::num_do_init_calls = 0;
+$CtorDtorTestObj::num_do_destroy_calls = 0;
+{
+ my $ctor_dtor_test = CtorDtorTestObj->new;
+ is( reftype($ctor_dtor_test), "HASH",
+ "ctor_dtor_test uses wrapper objects" );
+}
+is ( $CtorDtorTestObj::num_do_init_calls, 1, "do_init was called" );
+is ( $CtorDtorTestObj::num_do_destroy_calls, 1, "do_destroy was called" );
+
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/xs/XSBind.c
----------------------------------------------------------------------
diff --git a/runtime/perl/xs/XSBind.c b/runtime/perl/xs/XSBind.c
index ffc5d20..274bf69 100644
--- a/runtime/perl/xs/XSBind.c
+++ b/runtime/perl/xs/XSBind.c
@@ -35,6 +35,14 @@
#include "Clownfish/Util/Atomic.h"
#include "Clownfish/Util/Memory.h"
+// Support older Perls.
+#ifndef XS_INTERNAL
+ #define XS_INTERNAL XS
+#endif
+#ifndef HvNAMELEN
+ #define HvNAMELEN(hv) strlen(HvNAME(hv))
+#endif
+
#define XSBIND_REFCOUNT_FLAG 1
#define XSBIND_REFCOUNT_SHIFT 1
@@ -47,6 +55,22 @@ typedef struct {
cfish_PtrHash *seen;
} cfish_ConversionCache;
+// Indicate whether the class is a descendent of `ancestor`.
+static bool
+S_class_is_a(cfish_Class *klass, cfish_Class *ancestor);
+
+// Create a new host object wrapper.
+static cfish_Obj*
+S_new_wrapper(cfish_Class *klass, SV *sv);
+
+// Defer a decref on the wrapper.
+static void
+S_mortalize_wrapper(pTHX_ cfish_Obj *obj);
+
+// Destroy host object wrapper.
+static void
+S_destroy_wrapper(cfish_HostObjWrapper *wrapper);
+
static bool
S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment,
void *allocation, cfish_ConversionCache *cache,
@@ -62,39 +86,70 @@ S_perl_hash_to_cfish_hash(pTHX_ HV *phash, cfish_ConversionCache *cache);
static cfish_Vector*
S_perl_array_to_cfish_array(pTHX_ AV *parray, cfish_ConversionCache *cache);
+static bool
+S_class_is_a(cfish_Class *klass, cfish_Class *ancestor) {
+ while (klass != NULL) {
+ if (klass == ancestor) {
+ return true;
+ }
+ klass = klass->parent;
+ }
+
+ return false;
+}
+
cfish_Obj*
XSBind_new_blank_obj(pTHX_ SV *either_sv) {
- cfish_Class *klass;
+ HV *stash = NULL;
+ const char *class_name_ptr;
+ STRLEN class_name_len;
// Get a Class.
- if (sv_isobject(either_sv)
- && sv_derived_from(either_sv, "Clownfish::Obj")
- ) {
+ if (sv_isobject(either_sv)) {
// Use the supplied object's Class.
- IV iv_ptr = SvIV(SvRV(either_sv));
- cfish_Obj *self = INT2PTR(cfish_Obj*, iv_ptr);
- klass = self->klass;
+ stash = SvSTASH(SvRV(either_sv));
+ class_name_ptr = HvNAME(stash);
+ class_name_len = HvNAMELEN(stash);
}
else {
// Use the supplied class name string to find a Class.
- STRLEN len;
- char *ptr = SvPVutf8(either_sv, len);
- cfish_String *class_name = CFISH_SSTR_WRAP_UTF8(ptr, len);
- klass = cfish_Class_singleton(class_name, NULL);
+ class_name_ptr = SvPVutf8(either_sv, class_name_len);
}
+ cfish_String *class_name
+ = CFISH_SSTR_WRAP_UTF8(class_name_ptr, class_name_len);
+ cfish_Class *klass = cfish_Class_singleton(class_name, NULL);
+
// Use the Class to allocate a new blank object of the right size.
- return CFISH_Class_Make_Obj(klass);
+ cfish_Obj *obj = CFISH_Class_Make_Obj(klass);
+
+ if (klass->flags & CFISH_fHOST) {
+ // Mortalize host object wrapper so it will be destroyed after
+ // the Perl SV was extracted and returned.
+ S_mortalize_wrapper(aTHX_ obj);
+ }
+
+ return obj;
}
+// Used to thaw Lucy objects.
cfish_Obj*
XSBind_foster_obj(pTHX_ SV *sv, cfish_Class *klass) {
cfish_Obj *obj
= (cfish_Obj*)cfish_Memory_wrapped_calloc(klass->obj_alloc_size, 1);
- SV *inner_obj = SvRV((SV*)sv);
+ SV *inner_obj = SvRV(sv);
obj->klass = klass;
- sv_setiv(inner_obj, PTR2IV(obj));
- obj->ref.host_obj = inner_obj;
+
+ if (klass->flags & CFISH_fHOST) {
+ obj->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG;
+ cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj;
+ wrapper->wrapped = inner_obj;
+ }
+ else {
+ sv_setiv(inner_obj, PTR2IV(obj));
+ obj->ref.host_obj = inner_obj;
+ }
+
return obj;
}
@@ -150,16 +205,34 @@ S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment,
void *allocation, cfish_ConversionCache *cache,
cfish_Obj **obj_ptr) {
if (sv_isobject(sv)) {
- cfish_String *class_name = CFISH_Class_Get_Name(klass);
- // Assume that the class name is always NULL-terminated. Somewhat
- // dangerous but should be safe.
- if (sv_derived_from(sv, CFISH_Str_Get_Ptr8(class_name))) {
- // Unwrap a real Clownfish object.
- IV tmp = SvIV(SvRV(sv));
- cfish_Obj *obj = INT2PTR(cfish_Obj*, tmp);
- if (increment) {
- obj = CFISH_INCREF(obj);
+ // Get the Class of the SV.
+ SV *inner = SvRV(sv);
+ HV *stash = SvSTASH(inner);
+ cfish_String *sv_class_name
+ = CFISH_SSTR_WRAP_UTF8(HvNAME(stash), HvNAMELEN(stash));
+ cfish_Class *sv_class = cfish_Class_fetch_class(sv_class_name);
+
+ if (S_class_is_a(sv_class, klass)) {
+ cfish_Obj *obj;
+
+ if (sv_class->flags & CFISH_fHOST) {
+ // Create wrapper object.
+ obj = S_new_wrapper(sv_class, inner);
+ if (increment) {
+ SvREFCNT_inc_simple_void_NN(inner);
+ }
+ else {
+ S_mortalize_wrapper(aTHX_ obj);
+ }
+ }
+ else {
+ // Unwrap a real Clownfish object.
+ obj = INT2PTR(cfish_Obj*, SvIV(inner));
+ if (increment) {
+ obj = CFISH_INCREF(obj);
+ }
}
+
*obj_ptr = obj;
return true;
}
@@ -232,6 +305,42 @@ S_maybe_perl_to_cfish(pTHX_ SV *sv, cfish_Class *klass, bool increment,
return false;
}
+static cfish_Obj*
+S_new_wrapper(cfish_Class *klass, SV *sv) {
+ cfish_HostObjWrapper *wrapper
+ = (cfish_HostObjWrapper*)CFISH_CALLOCATE(klass->obj_alloc_size, 1);
+ wrapper->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG;
+ wrapper->klass = klass;
+ wrapper->wrapped = sv;
+ return (cfish_Obj*)wrapper;
+}
+
+static void
+S_mortalize_wrapper(pTHX_ cfish_Obj *obj) {
+ cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj;
+
+ // Create a mortalized SV. Its class must not be the actual host subclass.
+ // Otherwise, XSBind_destroy would invoke the destructor of the host
+ // subclass instead of the wrapper destructor. Since wrapper objects are
+ // never passed to Perl and the "ref.host_obj" slot is only used for
+ // refcounting, it's OK to simply bless into Clownfish::Obj.
+ SV *mortalized = newSV(0);
+ sv_setref_pv(mortalized, "Clownfish::Obj", wrapper);
+ wrapper->ref.host_obj = mortalized;
+ sv_2mortal(mortalized);
+
+ // The wrapper dtor will decref the wrapped SV, so compensate.
+ SvREFCNT_inc_simple_void_NN(wrapper->wrapped);
+}
+
+static void
+S_destroy_wrapper(cfish_HostObjWrapper *wrapper) {
+ dTHX;
+ SvREFCNT_dec(wrapper->wrapped);
+ // Don't call SUPER_DESTROY, free wrapper directly.
+ CFISH_FREEMEM(wrapper);
+}
+
const char*
XSBind_hash_key_to_utf8(pTHX_ HE *entry, STRLEN *size_ptr) {
const char *key_str = NULL;
@@ -552,6 +661,52 @@ XSBind_bootstrap(pTHX_ size_t num_classes,
}
}
+void
+XSBind_destroy(pTHX_ SV *sv) {
+ if (!sv_isobject(sv)) { return; }
+ SV *inner = SvRV(sv);
+
+ // During global destruction, DESTROY is called in random order on
+ // objects remaining because of refcount leaks or circular references.
+ // This can cause memory corruption with Clownfish objects, so better
+ // leak instead of corrupting memory.
+ //
+ // Unfortunately, Perl's global destruction is still severely broken
+ // as of early 2017. Global "our" variables are destroyed in random
+ // order even without circular references. The following check will
+ // skip some objects that could be safely destroyed, but it's the
+ // best we can do.
+ //
+ // See https://rt.perl.org/Ticket/Display.html?id=32714
+ if (PL_dirty && SvREFCNT(inner) > 1) { return; }
+
+ // Find Class.
+ HV *stash = SvSTASH(inner);
+ cfish_String *class_name
+ = CFISH_SSTR_WRAP_UTF8(HvNAME(stash), HvNAMELEN(stash));
+ cfish_Class *klass = cfish_Class_fetch_class(class_name);
+ if (!klass) { return; }
+
+ if (klass->flags & CFISH_fHOST) {
+ cfish_Obj *wrapper = S_new_wrapper(klass, inner);
+
+ // Find the real destructor which will also take care of
+ // freeing the wrapper.
+ for (klass = klass->parent; klass; klass = klass->parent) {
+ if (!(klass->flags & CFISH_fHOST)) {
+ CFISH_Obj_Destroy_t dtor
+ = CFISH_METHOD_PTR(klass, CFISH_Obj_Destroy);
+ dtor(wrapper);
+ break;
+ }
+ }
+ }
+ else {
+ cfish_Obj *self = INT2PTR(cfish_Obj*, SvIV(inner));
+ CFISH_Obj_Destroy(self);
+ }
+}
+
/***************************************************************************
* The routines below are declared within the Clownfish core but left
* unimplemented and must be defined for each host language.
@@ -705,19 +860,33 @@ cfish_dec_refcount(void *vself) {
SV*
XSBind_cfish_obj_to_sv_inc(pTHX_ cfish_Obj *obj) {
if (obj == NULL) { return newSV(0); }
+#if PERL_VERSION <= 8
+ SV *inner;
+#endif
SV *perl_obj;
- if (obj->ref.count & XSBIND_REFCOUNT_FLAG) {
- perl_obj = S_lazy_init_host_obj(aTHX_ obj, true);
+ if (obj->klass->flags & CFISH_fHOST) {
+ cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj;
+ perl_obj = newRV_inc((SV*)wrapper->wrapped);
+#if PERL_VERSION <= 8
+ inner = (SV*)wrapper->wrapped;
+#endif
}
else {
- perl_obj = newRV_inc((SV*)obj->ref.host_obj);
+ if (obj->ref.count & XSBIND_REFCOUNT_FLAG) {
+ perl_obj = S_lazy_init_host_obj(aTHX_ obj, true);
+ }
+ else {
+ perl_obj = newRV_inc((SV*)obj->ref.host_obj);
+ }
+#if PERL_VERSION <= 8
+ inner = (SV*)obj->ref.host_obj;
+#endif
}
// Enable overloading for Perl 5.8.x
#if PERL_VERSION <= 8
- HV *stash = SvSTASH((SV*)obj->ref.host_obj);
- if (Gv_AMG(stash)) {
+ if (Gv_AMG(SvSTASH(inner))) {
SvAMAGIC_on(perl_obj);
}
#endif
@@ -728,19 +897,33 @@ XSBind_cfish_obj_to_sv_inc(pTHX_ cfish_Obj *obj) {
SV*
XSBind_cfish_obj_to_sv_noinc(pTHX_ cfish_Obj *obj) {
if (obj == NULL) { return newSV(0); }
+#if PERL_VERSION <= 8
+ SV *inner;
+#endif
SV *perl_obj;
- if (obj->ref.count & XSBIND_REFCOUNT_FLAG) {
- perl_obj = S_lazy_init_host_obj(aTHX_ obj, false);
+ if (obj->klass->flags & CFISH_fHOST) {
+ cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj;
+ perl_obj = newRV_noinc((SV*)wrapper->wrapped);
+#if PERL_VERSION <= 8
+ inner = (SV*)wrapper->wrapped;
+#endif
}
else {
- perl_obj = newRV_noinc((SV*)obj->ref.host_obj);
+ if (obj->ref.count & XSBIND_REFCOUNT_FLAG) {
+ perl_obj = S_lazy_init_host_obj(aTHX_ obj, false);
+ }
+ else {
+ perl_obj = newRV_noinc((SV*)obj->ref.host_obj);
+ }
+#if PERL_VERSION <= 8
+ inner = (SV*)obj->ref.host_obj;
+#endif
}
// Enable overloading for Perl 5.8.x
#if PERL_VERSION <= 8
- HV *stash = SvSTASH((SV*)obj->ref.host_obj);
- if (Gv_AMG(stash)) {
+ if (Gv_AMG(SvSTASH(inner))) {
SvAMAGIC_on(perl_obj);
}
#endif
@@ -763,6 +946,32 @@ CFISH_Class_Make_Obj_IMP(cfish_Class *self) {
= (cfish_Obj*)cfish_Memory_wrapped_calloc(self->obj_alloc_size, 1);
obj->klass = self;
obj->ref.count = (1 << XSBIND_REFCOUNT_SHIFT) | XSBIND_REFCOUNT_FLAG;
+
+ if (self->flags & CFISH_fHOST) {
+ dTHX;
+
+ // Bless an empty hashref. sv_bless only works through an RV, so
+ // bless manually.
+ SV *sv = (SV*)newHV();
+ SvOBJECT_on(sv);
+#if PERL_VERSION <= 16
+ PL_sv_objcount++;
+#endif
+ SvUPGRADE(sv, SVt_PVMG);
+ HV *stash = gv_stashpvn(CFISH_Str_Get_Ptr8(self->name),
+ CFISH_Str_Get_Size(self->name), GV_ADD);
+ SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
+#if PERL_VERSION >= 10 && PERL_VERSION <= 16
+ // Enable overloading.
+ if (Gv_AMG(stash)) {
+ SvFLAGS(sv) |= SVf_AMAGIC;
+ }
+#endif
+
+ cfish_HostObjWrapper *wrapper = (cfish_HostObjWrapper*)obj;
+ wrapper->wrapped = sv;
+ }
+
return obj;
}
@@ -831,6 +1040,59 @@ cfish_Class_find_parent_class(cfish_String *class_name) {
return parent_class;
}
+XS_INTERNAL(XS_HostObjWrapper__nil) {
+ dXSARGS;
+ CFISH_UNUSED_VAR(items);
+ XSRETURN_EMPTY;
+}
+
+XS_INTERNAL(XS_HostObjWrapper__deref_scalar) {
+ dXSARGS;
+ SP -= items;
+ if (items != 3) {
+ XSBind_invalid_args_error(aTHX_ cv, "self, other, swap");
+ }
+
+ // Return address of the inner HV wrapped in an RV.
+ ST(0) = newRV_noinc(newSViv(PTR2IV(SvRV(ST(0)))));
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+}
+
+void
+cfish_Class_adjust_host_subclass(cfish_Class *klass) {
+ // Override Destroy with the wrapper dtor.
+ CFISH_Class_Override(klass, (cfish_method_t)S_destroy_wrapper,
+ CFISH_Obj_Destroy_OFFSET);
+
+ // Overload scalar dereferencing to keep deprecated inside-out objects
+ // working. How to install overload magic from C seems to be undocumented.
+ // The following is based on the code xsubpp generates if it finds an
+ // OVERLOAD keyword.
+
+ dTHX;
+#if PERL_VERSION <= 8
+ PL_amagic_generation++;
+#endif
+ cfish_String *class_name = CFISH_Class_Get_Name(klass);
+ cfish_String *name;
+ const char *name_ptr;
+
+ name = cfish_Str_newf("%o::()", class_name);
+ name_ptr = CFISH_Str_Get_Ptr8(name);
+ // fallback => 1
+ sv_setsv(get_sv(name_ptr, GV_ADD), &PL_sv_yes);
+ // A sub named '()' must be present.
+ newXS(name_ptr, XS_HostObjWrapper__nil, __FILE__);
+ CFISH_DECREF(name);
+
+ // The internal name for overload methods starts with a '('.
+ name = cfish_Str_newf("%o::(${}", class_name);
+ name_ptr = CFISH_Str_Get_Ptr8(name);
+ newXS(name_ptr, XS_HostObjWrapper__deref_scalar, __FILE__);
+ CFISH_DECREF(name);
+}
+
/*************************** Clownfish::Method ******************************/
cfish_String*
@@ -967,12 +1229,11 @@ cfish_Err_trap(CFISH_Err_Attempt_t routine, void *context) {
else {
SV *dollar_at = get_sv("@", FALSE);
if (SvTRUE(dollar_at)) {
- if (sv_isobject(dollar_at)
- && sv_derived_from(dollar_at,"Clownfish::Err")
- ) {
- IV error_iv = SvIV(SvRV(dollar_at));
- error = INT2PTR(cfish_Err*, error_iv);
- CFISH_INCREF(error);
+ cfish_Obj *obj;
+ bool success = S_maybe_perl_to_cfish(aTHX_ dollar_at, CFISH_ERR,
+ true, NULL, NULL, &obj);
+ if (success) {
+ error = (cfish_Err*)obj;
}
else {
STRLEN len;
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/perl/xs/XSBind.h
----------------------------------------------------------------------
diff --git a/runtime/perl/xs/XSBind.h b/runtime/perl/xs/XSBind.h
index 32a9e69..60c1a10 100644
--- a/runtime/perl/xs/XSBind.h
+++ b/runtime/perl/xs/XSBind.h
@@ -222,6 +222,11 @@ cfish_XSBind_bootstrap(pTHX_ size_t num_classes,
const cfish_XSBind_XSubSpec *xsub_specs,
const char *file);
+/** Destroy a Clownfish SV.
+ */
+CFISH_VISIBLE void
+cfish_XSBind_destroy(pTHX_ SV *sv);
+
#define XSBIND_PARAM(key, required) \
{ key, (int16_t)sizeof("" key) - 1, (char)required }
@@ -252,6 +257,7 @@ cfish_XSBind_bootstrap(pTHX_ size_t num_classes,
#define XSBind_invalid_args_error cfish_XSBind_invalid_args_error
#define XSBind_undef_arg_error cfish_XSBind_undef_arg_error
#define XSBind_bootstrap cfish_XSBind_bootstrap
+#define XSBind_destroy cfish_XSBind_destroy
/* Strip the prefix from some common ClownFish symbols where we know there's
* no conflict with Perl. It's a little inconsistent to do this rather than
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/python/cfext/CFBind.c
----------------------------------------------------------------------
diff --git a/runtime/python/cfext/CFBind.c b/runtime/python/cfext/CFBind.c
index e1ded4e..d08d5b2 100644
--- a/runtime/python/cfext/CFBind.c
+++ b/runtime/python/cfext/CFBind.c
@@ -992,6 +992,11 @@ cfish_Class_find_parent_class(cfish_String *class_name) {
return NULL;
}
+void
+cfish_Class_adjust_host_subclass(cfish_Class *klass) {
+ CFISH_UNUSED_VAR(klass);
+}
+
/**** Method ***************************************************************/
cfish_String*
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/test/Clownfish/Test/TestHost.c
----------------------------------------------------------------------
diff --git a/runtime/test/Clownfish/Test/TestHost.c b/runtime/test/Clownfish/Test/TestHost.c
index 6da0efa..8c137ca 100644
--- a/runtime/test/Clownfish/Test/TestHost.c
+++ b/runtime/test/Clownfish/Test/TestHost.c
@@ -23,7 +23,31 @@
TestHost*
TestHost_new() {
- return (TestHost*)Class_Make_Obj(TESTHOST);
+ TestHost *self = (TestHost*)Class_Make_Obj(TESTHOST);
+ return TestHost_init(self);
+}
+
+TestHost*
+TestHost_init(TestHost *self) {
+ Obj_init((Obj*)self);
+ TestHost_Do_Init(self);
+ return self;
+}
+
+void
+TestHost_Do_Init_IMP(TestHost *self) {
+ UNUSED_VAR(self);
+}
+
+void
+TestHost_Destroy_IMP(TestHost *self) {
+ TestHost_Do_Destroy(self);
+ SUPER_DESTROY(self, TESTHOST);
+}
+
+void
+TestHost_Do_Destroy_IMP(TestHost *self) {
+ UNUSED_VAR(self);
}
Obj*
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/0bfeb23e/runtime/test/Clownfish/Test/TestHost.cfh
----------------------------------------------------------------------
diff --git a/runtime/test/Clownfish/Test/TestHost.cfh b/runtime/test/Clownfish/Test/TestHost.cfh
index 92bc272..1deb46e 100644
--- a/runtime/test/Clownfish/Test/TestHost.cfh
+++ b/runtime/test/Clownfish/Test/TestHost.cfh
@@ -22,6 +22,16 @@ class Clownfish::Test::TestHost {
inert incremented TestHost*
new();
+ /** Invokes the (possibly overridden) method [](.Do_Init).
+ */
+ inert TestHost*
+ init(TestHost *self);
+
+ /** Called from constructor.
+ */
+ void
+ Do_Init(TestHost *self);
+
Obj*
Test_Obj_Pos_Arg(TestHost *self, Obj *arg);
@@ -76,6 +86,17 @@ class Clownfish::Test::TestHost {
incremented String*
Invoke_Aliased_From_C(TestHost* self);
+
+ /** A destructor that invokes the (possibly overridden) method
+ * [](.Do_Destroy).
+ */
+ public void
+ Destroy(TestHost* self);
+
+ /** Called from destructor.
+ */
+ void
+ Do_Destroy(TestHost *self);
}
[2/2] lucy-clownfish git commit: Don't create callbacks for excluded
methods
Posted by nw...@apache.org.
Don't create callbacks for excluded methods
Ideally, there should be a way to only omit the callback function
definition in order to allow custom implementations.
Project: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/repo
Commit: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/commit/74c12c7e
Tree: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/tree/74c12c7e
Diff: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/diff/74c12c7e
Branch: refs/heads/master
Commit: 74c12c7ef8a3a3d66d959c8a3b9f8b30efc61b77
Parents: 0bfeb23
Author: Nick Wellnhofer <we...@aevum.de>
Authored: Fri Mar 24 14:48:46 2017 +0100
Committer: Nick Wellnhofer <we...@aevum.de>
Committed: Sun Apr 16 12:17:19 2017 +0200
----------------------------------------------------------------------
compiler/src/CFCBindSpecs.c | 2 +-
compiler/src/CFCPerl.c | 4 +++-
2 files changed, 4 insertions(+), 2 deletions(-)
----------------------------------------------------------------------
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/74c12c7e/compiler/src/CFCBindSpecs.c
----------------------------------------------------------------------
diff --git a/compiler/src/CFCBindSpecs.c b/compiler/src/CFCBindSpecs.c
index b8c609a..19a03b4 100644
--- a/compiler/src/CFCBindSpecs.c
+++ b/compiler/src/CFCBindSpecs.c
@@ -339,7 +339,7 @@ S_add_novel_meth(CFCBindSpecs *self, CFCMethod *method, CFCClass *klass,
const char *sep = meth_index == 0 ? "" : ",\n";
char *full_override_sym;
- if (!CFCMethod_final(method)) {
+ if (!CFCMethod_final(method) && !CFCMethod_excluded_from_host(method)) {
full_override_sym = CFCMethod_full_override_sym(method, klass);
}
else {
http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/74c12c7e/compiler/src/CFCPerl.c
----------------------------------------------------------------------
diff --git a/compiler/src/CFCPerl.c b/compiler/src/CFCPerl.c
index f43bc47..73c8d35 100644
--- a/compiler/src/CFCPerl.c
+++ b/compiler/src/CFCPerl.c
@@ -311,7 +311,9 @@ S_write_host_c(CFCPerl *self, CFCParcel *parcel) {
CFCMethod *method = fresh_methods[meth_num];
// Define callback.
- if (CFCMethod_novel(method) && !CFCMethod_final(method)) {
+ if (CFCMethod_novel(method)
+ && !CFCMethod_final(method)
+ && !CFCMethod_excluded_from_host(method)) {
char *cb_def = CFCPerlMethod_callback_def(method, klass);
cb_defs = CFCUtil_cat(cb_defs, cb_def, "\n", NULL);
FREEMEM(cb_def);