You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@lucy.apache.org by ma...@apache.org on 2011/07/29 02:36:13 UTC
[lucy-commits] svn commit: r1152060 - in /incubator/lucy/trunk/clownfish: lib/Clownfish.xs
lib/Clownfish/Binding/Perl/Method.pm src/CFCPerlMethod.c src/CFCPerlMethod.h
Author: marvin
Date: Fri Jul 29 00:36:13 2011
New Revision: 1152060
URL: http://svn.apache.org/viewvc?rev=1152060&view=rev
Log:
Finish porting CFCPerlMethod to C.
Modified:
incubator/lucy/trunk/clownfish/lib/Clownfish.xs
incubator/lucy/trunk/clownfish/lib/Clownfish/Binding/Perl/Method.pm
incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c
incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h
Modified: incubator/lucy/trunk/clownfish/lib/Clownfish.xs
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/lib/Clownfish.xs?rev=1152060&r1=1152059&r2=1152060&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/lib/Clownfish.xs (original)
+++ incubator/lucy/trunk/clownfish/lib/Clownfish.xs Fri Jul 29 00:36:13 2011
@@ -1946,21 +1946,12 @@ DESTROY(self)
PPCODE:
CFCPerlMethod_destroy(self);
-void
-_set_or_get(self, ...)
+SV*
+xsub_def(self)
CFCPerlMethod *self;
-ALIAS:
- _get_method = 2
-PPCODE:
-{
- START_SET_OR_GET_SWITCH
- case 2: {
- CFCMethod *value = CFCPerlMethod_get_method(self);
- retval = S_cfcbase_to_perlref(value);
- }
- break;
- END_SET_OR_GET_SWITCH
-}
+CODE:
+ RETVAL = S_sv_eat_c_string(CFCPerlMethod_xsub_def(self));
+OUTPUT: RETVAL
MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Class
Modified: incubator/lucy/trunk/clownfish/lib/Clownfish/Binding/Perl/Method.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/lib/Clownfish/Binding/Perl/Method.pm?rev=1152060&r1=1152059&r2=1152060&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/lib/Clownfish/Binding/Perl/Method.pm (original)
+++ incubator/lucy/trunk/clownfish/lib/Clownfish/Binding/Perl/Method.pm Fri Jul 29 00:36:13 2011
@@ -33,192 +33,6 @@ sub new {
return _new( @args{qw( method alias )} );
}
-sub xsub_def {
- my $self = shift;
- if ( $self->use_labeled_params ) {
- return $self->_xsub_def_labeled_params;
- }
- else {
- return $self->_xsub_def_positional_args;
- }
-}
-
-# Build XSUB function body.
-sub _xsub_body {
- my $self = shift;
- my $method = $self->_get_method;
- my $full_func_sym = $method->full_func_sym;
- my $param_list = $method->get_param_list;
- my $arg_vars = $param_list->get_variables;
- my $name_list = $param_list->name_list;
- my $body = "";
-
- # Compensate for functions which eat refcounts.
- for my $arg_var (@$arg_vars) {
- my $arg_type = $arg_var->get_type;
- next unless $arg_type->is_object;
- next unless $arg_type->decremented;
- my $var_name = $arg_var->micro_sym;
- $body .= "LUCY_INCREF($var_name);\n ";
- }
-
- if ( $method->void ) {
- # Invoke method in void context.
- $body .= qq|$full_func_sym($name_list);\n| . qq| XSRETURN(0);|;
- }
- else {
- # Return a value for method invoked in a scalar context.
- my $return_type = $method->get_return_type;
- my $type_str = $return_type->to_c;
- my $retval_assignment
- = "ST(0) = " . to_perl( $return_type, 'retval' ) . ';';
- my $decrement = "";
- if ( $return_type->is_object and $return_type->incremented ) {
- $decrement = "\n LUCY_DECREF(retval);";
- }
- $body .= qq|$type_str retval = $full_func_sym($name_list);
- $retval_assignment$decrement
- sv_2mortal( ST(0) );
- XSRETURN(1);|
- }
-
- return $body;
-}
-
-sub _xsub_def_positional_args {
- my $self = shift;
- my $method = $self->_get_method;
- my $param_list = $method->get_param_list;
- my $arg_vars = $param_list->get_variables;
- my $arg_inits = $param_list->get_initial_values;
- my $num_args = $param_list->num_vars;
- my $c_name = $self->c_name;
- my $body = $self->_xsub_body;
-
- # Determine how many args are truly required and build an error check.
- my $min_required = $num_args;
- while ( defined $arg_inits->[ $min_required - 1 ] ) {
- $min_required--;
- }
- my @xs_arg_names;
- for ( my $i = 0; $i < $min_required; $i++ ) {
- push @xs_arg_names, $arg_vars->[$i]->micro_sym;
- }
- my $xs_name_list = join( ", ", @xs_arg_names );
- my $num_args_check;
- if ( $min_required < $num_args ) {
- $num_args_check
- = qq|if (items < $min_required) { |
- . qq|CFISH_THROW(CFISH_ERR, "Usage: %s(%s)", GvNAME(CvGV(cv)),|
- . qq| "$xs_name_list"); }|;
- }
- else {
- $num_args_check
- = qq|if (items != $num_args) { |
- . qq| CFISH_THROW(CFISH_ERR, "Usage: %s(%s)", GvNAME(CvGV(cv)), |
- . qq|"$xs_name_list"); }|;
- }
-
- # Var assignments.
- my @var_assignments;
- for ( my $i = 0; $i < @$arg_vars; $i++ ) {
- my $var = $arg_vars->[$i];
- my $val = $arg_inits->[$i];
- my $var_name = $var->micro_sym;
- my $var_type = $var->get_type;
- my $type_c = $var_type->to_c;
- my $statement;
- if ( $i == 0 ) { # $self
- $statement
- = _self_assign_statement( $var_type, $method->micro_sym );
- }
- else {
- if ( defined $val ) {
- $statement
- = "$type_c $var_name = "
- . "( items >= $i && XSBind_sv_defined(ST($i)) ) ? "
- . from_perl( $var_type, "ST($i)" )
- . " : $val;";
- }
- else {
- $statement = "$type_c $var_name = "
- . from_perl( $var_type, "ST($i)" ) . ';';
- }
- }
- push @var_assignments, $statement;
- }
- my $var_assignments = join "\n ", @var_assignments;
-
- return <<END_STUFF;
-XS($c_name);
-XS($c_name) {
- dXSARGS;
- CHY_UNUSED_VAR(cv);
- SP -= items;
- $num_args_check;
-
- /* Extract vars from Perl stack. */
- $var_assignments
-
- /* Execute */
- $body
-}
-END_STUFF
-}
-
-sub _xsub_def_labeled_params {
- my $self = shift;
- my $c_name = $self->c_name;
- my $param_list = $self->get_param_list;
- my $arg_inits = $param_list->get_initial_values;
- my $arg_vars = $param_list->get_variables;
- my $self_var = $arg_vars->[0];
- my $self_assign = _self_assign_statement( $self_var->get_type,
- $self->_get_method->micro_sym );
- my $allot_params = $self->build_allot_params;
- my $body = $self->_xsub_body;
-
- # Prepare error message for incorrect args.
- my $name_list = $self_var->micro_sym . ", ...";
- my $num_args_check
- = qq|if (items < 1) { |
- . qq|CFISH_THROW(CFISH_ERR, "Usage: %s(%s)", GvNAME(CvGV(cv)), |
- . qq|"$name_list"); }|;
-
- return <<END_STUFF;
-XS($c_name);
-XS($c_name) {
- dXSARGS;
- CHY_UNUSED_VAR(cv);
- $num_args_check;
- SP -= items;
-
- /* Extract vars from Perl stack. */
- $allot_params
- $self_assign
-
- /* Execute */
- $body
-}
-END_STUFF
-}
-
-# Create an assignment statement for extracting $self from the Perl stack.
-sub _self_assign_statement {
- my ( $type, $method_name ) = @_;
- my $type_c = $type->to_c;
- $type_c =~ /(\w+)\*$/ or die "Not an object type: $type_c";
- my $vtable = uc($1);
-
- # Make an exception for deserialize -- allow self to be NULL if called as
- # a class method.
- my $binding_func
- = $method_name eq 'deserialize'
- ? 'XSBind_maybe_sv_to_cfish_obj'
- : 'XSBind_sv_to_cfish_obj';
- return "$type_c self = ($type_c)$binding_func(ST(0), $vtable, NULL);";
-}
-
1;
__END__
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c?rev=1152060&r1=1152059&r2=1152060&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c Fri Jul 29 00:36:13 2011
@@ -14,18 +14,41 @@
* limitations under the License.
*/
+#include <string.h>
+#include <stdio.h>
+
#define CFC_NEED_PERLSUB_STRUCT_DEF 1
#include "CFCPerlSub.h"
#include "CFCPerlMethod.h"
#include "CFCUtil.h"
#include "CFCMethod.h"
+#include "CFCType.h"
#include "CFCParamList.h"
+#include "CFCPerlTypeMap.h"
+#include "CFCVariable.h"
struct CFCPerlMethod {
CFCPerlSub sub;
CFCMethod *method;
};
+// Return the main chunk of the code for the xsub.
+static char*
+S_xsub_body(CFCPerlMethod *self);
+
+// Create an assignment statement for extracting $self from the Perl stack.
+static char*
+S_self_assign_statement(CFCPerlMethod *self, CFCType *type,
+ const char *method_name);
+
+// Return code for an xsub which uses labeled params.
+static char*
+S_xsub_def_labeled_params(CFCPerlMethod *self);
+
+// Return code for an xsub which uses positional args.
+static char*
+S_xsub_def_positional_args(CFCPerlMethod *self);
+
CFCPerlMethod*
CFCPerlMethod_new(CFCMethod *method, const char *alias) {
CFCPerlMethod *self
@@ -56,8 +79,253 @@ CFCPerlMethod_destroy(CFCPerlMethod *sel
CFCPerlSub_destroy((CFCPerlSub*)self);
}
-CFCMethod*
-CFCPerlMethod_get_method(CFCPerlMethod *self) {
- return self->method;
+char*
+CFCPerlMethod_xsub_def(CFCPerlMethod *self) {
+ if (self->sub.use_labeled_params) {
+ return S_xsub_def_labeled_params(self);
+ }
+ else {
+ return S_xsub_def_positional_args(self);
+ }
+}
+
+static char*
+S_xsub_body(CFCPerlMethod *self) {
+ CFCMethod *method = self->method;
+ const char *full_func_sym = CFCMethod_implementing_func_sym(method);
+ CFCParamList *param_list = CFCMethod_get_param_list(method);
+ CFCVariable **arg_vars = CFCParamList_get_variables(param_list);
+ const char *name_list = CFCParamList_name_list(param_list);
+ char *body = CFCUtil_strdup("");
+
+ // Compensate for functions which eat refcounts.
+ for (int i = 0; arg_vars[i] != NULL; i++) {
+ CFCVariable *var = arg_vars[i];
+ CFCType *type = CFCVariable_get_type(var);
+ if (CFCType_is_object(type) && CFCType_decremented(type)) {
+ body = CFCUtil_cat(body, "LUCY_INCREF(",
+ CFCVariable_micro_sym(var), ");\n ", NULL);
+ }
+ }
+
+ if (CFCType_is_void(CFCMethod_get_return_type(method))) {
+ // Invoke method in void context.
+ body = CFCUtil_cat(body, full_func_sym, "(", name_list,
+ ");\n XSRETURN(0);", NULL);
+ }
+ else {
+ // Return a value for method invoked in a scalar context.
+ CFCType *return_type = CFCMethod_get_return_type(method);
+ const char *type_str = CFCType_to_c(return_type);
+ char *assignment = CFCPerlTypeMap_to_perl(return_type, "retval");
+ body = CFCUtil_cat(body, type_str, " retval = ", full_func_sym, "(",
+ name_list, ");\n ST(0) = ", assignment, ";",
+ NULL);
+ if (CFCType_is_object(return_type)
+ && CFCType_incremented(return_type)
+ ) {
+ body = CFCUtil_cat(body, "\n LUCY_DECREF(retval);", NULL);
+ }
+ body = CFCUtil_cat(body, "\n sv_2mortal( ST(0) );\n XSRETURN(1);",
+ NULL);
+ FREEMEM(assignment);
+ }
+
+ return body;
+}
+
+// Create an assignment statement for extracting $self from the Perl stack.
+static char*
+S_self_assign_statement(CFCPerlMethod *self, CFCType *type,
+ const char *method_name) {
+ const char *type_c = CFCType_to_c(type);
+ if (!CFCType_is_object(type)) {
+ CFCUtil_die("Not an object type: %s", type_c);
+ }
+ const char *vtable_var = CFCType_get_vtable_var(type);
+
+ // Make an exception for deserialize -- allow self to be NULL if called as
+ // a class method.
+ char *binding_func = strcmp(method_name, "deserialize") == 0
+ ? "XSBind_maybe_sv_to_cfish_obj"
+ : "XSBind_sv_to_cfish_obj";
+ char pattern[] = "%s self = (%s)%s(ST(0), %s, NULL);";
+ size_t size = sizeof(pattern)
+ + strlen(type_c) * 2
+ + strlen(binding_func)
+ + strlen(vtable_var)
+ + 10;
+ char *statement = (char*)MALLOCATE(size);
+ sprintf(statement, pattern, type_c, type_c, binding_func, vtable_var);
+
+ return statement;
+}
+
+static char*
+S_xsub_def_labeled_params(CFCPerlMethod *self) {
+ const char *c_name = self->sub.c_name;
+ CFCParamList *param_list = self->sub.param_list;
+ const char **arg_inits = CFCParamList_get_initial_values(param_list);
+ CFCVariable **arg_vars = CFCParamList_get_variables(param_list);
+ CFCVariable *self_var = arg_vars[0];
+ CFCType *self_type = CFCVariable_get_type(self_var);
+ const char *self_micro_sym = CFCVariable_micro_sym(self_var);
+ const char *micro_sym = CFCMethod_micro_sym(self->method);
+ char *self_assign = S_self_assign_statement(self, self_type, micro_sym);
+ char *allot_params = CFCPerlSub_build_allot_params((CFCPerlSub*)self);
+ char *body = S_xsub_body(self);
+
+ char pattern[] =
+ "XS(%s);\n"
+ "XS(%s) {\n"
+ " dXSARGS;\n"
+ " CHY_UNUSED_VAR(cv);\n"
+ " if (items < 1) { CFISH_THROW(CFISH_ERR, \"Usage: %%s(%%s)\", GvNAME(CvGV(cv)), \"%s, ...\"); };\n"
+ " SP -= items;\n"
+ "\n"
+ " /* Extract vars from Perl stack. */\n"
+ " %s\n"
+ " %s\n"
+ "\n"
+ " /* Execute */\n"
+ " %s\n"
+ "}\n";
+ size_t size = sizeof(pattern)
+ + strlen(c_name) * 2
+ + strlen(self_micro_sym)
+ + strlen(allot_params)
+ + strlen(self_assign)
+ + strlen(body)
+ + 40;
+ char *xsub_def = (char*)MALLOCATE(size);
+ sprintf(xsub_def, pattern, c_name, c_name, self_micro_sym, allot_params,
+ self_assign, body);
+
+ FREEMEM(self_assign);
+ FREEMEM(allot_params);
+ FREEMEM(body);
+ return xsub_def;
+}
+
+static char*
+S_xsub_def_positional_args(CFCPerlMethod *self) {
+ CFCMethod *method = self->method;
+ CFCParamList *param_list = CFCMethod_get_param_list(method);
+ CFCVariable **arg_vars = CFCParamList_get_variables(param_list);
+ const char **arg_inits = CFCParamList_get_initial_values(param_list);
+ unsigned num_vars = CFCParamList_num_vars(param_list);
+ char *body = S_xsub_body(self);
+
+ // Determine how many args are truly required and build an error check.
+ unsigned min_required = 0;
+ for (unsigned i = 0; i < num_vars; i++) {
+ if (arg_inits[i] == NULL) {
+ min_required = i + 1;
+ }
+ }
+ char *xs_name_list = num_vars > 0
+ ? CFCUtil_strdup(CFCVariable_micro_sym(arg_vars[0]))
+ : CFCUtil_strdup("");
+ for (unsigned i = 1; i < num_vars; i++) {
+ const char *var_name = CFCVariable_micro_sym(arg_vars[i]);
+ if (i < min_required) {
+ xs_name_list = CFCUtil_cat(xs_name_list, ", ", var_name, NULL);
+ }
+ else {
+ xs_name_list = CFCUtil_cat(xs_name_list, ", [", var_name, "]",
+ NULL);
+ }
+ }
+ const char num_args_pattern[] =
+ "if (items %s %u) { CFISH_THROW(CFISH_ERR, \"Usage: %%s(%%s)\", "
+ "GvNAME(CvGV(cv)), \"%s\"); }";
+ size_t num_args_check_size = sizeof(num_args_pattern)
+ + strlen(xs_name_list)
+ + 30;
+ char *num_args_check = (char*)MALLOCATE(num_args_check_size);
+ if (min_required < num_vars) {
+ sprintf(num_args_check, num_args_pattern, "<", min_required,
+ xs_name_list);
+ }
+ else {
+ sprintf(num_args_check, num_args_pattern, "!=", min_required,
+ xs_name_list);
+ }
+
+ // Var assignments.
+ char *var_assignments = CFCUtil_strdup("");
+ for (unsigned i = 0; i < num_vars; i++) {
+ CFCVariable *var = arg_vars[i];
+ const char *val = arg_inits[i];
+ const char *var_name = CFCVariable_micro_sym(var);
+ CFCType *var_type = CFCVariable_get_type(var);
+ const char *type_c = CFCType_to_c(var_type);
+
+ if (i == 0) { // self
+ const char *meth_micro_sym = CFCMethod_micro_sym(self->method);
+ char *statement
+ = S_self_assign_statement(self, var_type, meth_micro_sym);
+ var_assignments = CFCUtil_cat(var_assignments, statement, NULL);
+ FREEMEM(statement);
+ }
+ else {
+ char perl_stack_var[30];
+ sprintf(perl_stack_var, "ST(%u)", i);
+ char *conversion
+ = CFCPerlTypeMap_from_perl(var_type, perl_stack_var);
+ if (val) {
+ char pattern[] =
+ "\n %s %s = ( items >= %u && XSBind_sv_defined(ST(%u)) )"
+ " ? %s : %s;";
+ size_t size = sizeof(pattern)
+ + strlen(type_c)
+ + strlen(var_name)
+ + strlen(conversion)
+ + strlen(val)
+ + 100;
+ char *statement = (char*)MALLOCATE(size);
+ sprintf(statement, pattern, type_c, var_name, i, i,
+ conversion, val);
+ var_assignments
+ = CFCUtil_cat(var_assignments, statement, NULL);
+ FREEMEM(statement);
+ }
+ else {
+ var_assignments
+ = CFCUtil_cat(var_assignments, "\n ", type_c, " ",
+ var_name, " = ", conversion, ";", NULL);
+ }
+ FREEMEM(conversion);
+ }
+ }
+
+ char pattern[] =
+ "XS(%s);\n"
+ "XS(%s) {\n"
+ " dXSARGS;\n"
+ " CHY_UNUSED_VAR(cv);\n"
+ " SP -= items;\n"
+ " %s;\n"
+ "\n"
+ " /* Extract vars from Perl stack. */\n"
+ " %s\n"
+ "\n"
+ " /* Execute */\n"
+ " %s\n"
+ "}\n";
+ size_t size = sizeof(pattern)
+ + strlen(self->sub.c_name) * 2
+ + strlen(num_args_check)
+ + strlen(var_assignments)
+ + strlen(body)
+ + 20;
+ char *xsub = (char*)MALLOCATE(size);
+ sprintf(xsub, pattern, self->sub.c_name, self->sub.c_name, num_args_check,
+ var_assignments, body);
+
+ FREEMEM(num_args_check);
+ FREEMEM(var_assignments);
+ FREEMEM(body);
+ return xsub;
}
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h?rev=1152060&r1=1152059&r2=1152060&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h Fri Jul 29 00:36:13 2011
@@ -34,8 +34,8 @@ CFCPerlMethod_init(CFCPerlMethod *self,
void
CFCPerlMethod_destroy(CFCPerlMethod *self);
-struct CFCMethod*
-CFCPerlMethod_get_method(CFCPerlMethod *self);
+char*
+CFCPerlMethod_xsub_def(CFCPerlMethod *self);
#ifdef __cplusplus
}