From bb9ba6cf16e19bc55693df6e42535e6b0b6150a7 Mon Sep 17 00:00:00 2001 From: Vincent Danjean Date: Wed, 22 Apr 2009 22:11:50 +0200 Subject: [PATCH] Correctly manage callbacks gsl_function and gsl_monte_function are handled in this patch. This implementation do not mess with the memory. We put on the C stack during all the function using the callback a structure (gsl_[monte_]function_perl) that has all what we need. We use the 'params' parameter in the original C structure to track the adress of this structure and our C callback (call_gsl_[monte_]function) use params to get back the info and call the perl callback. When a gsl_function is required, the corresponding Perl parameter must be either a function (ref to code or routine name string) or a reference to a array of a function (ref to code or routine name string), [an integer for gsl_monte_function, ]and a scalar that will be passed "as it is" to the callback perl function. --- swig/Deriv.i | 61 ++++---------- swig/gsl_typemaps.i | 224 ++++++++++++++++++++++++++++++++++++++++------------ t/Deriv.t | 18 ++++- 3 files changed, 203 insertions(+), 100 deletions(-) rewrite swig/Deriv.i (77%) diff --git a/swig/Deriv.i b/swig/Deriv.i dissimilarity index 77% index f5bab55..3c12cea 100644 --- a/swig/Deriv.i +++ b/swig/Deriv.i @@ -1,47 +1,14 @@ -%module "Math::GSL::Deriv" -// Danger Will Robinson, for realz! - -%include "typemaps.i" -%include "gsl_typemaps.i" -%typemap(argout) (const gsl_function *f, - double x, double h, - double *result, double *abserr) { - SV ** sv; - - sv = hv_fetch(Callbacks, (char*)&$input, sizeof($input), FALSE ); - if (sv == (SV**)NULL) - croak("Math::GSL(argout) : Missing callback!\n"); - dSP; - - PUSHMARK(SP); - // these are the arguments passed to the callback - XPUSHs(sv_2mortal(newSViv((int)$2))); - // shouldnt we be doing something with $3 ? - PUTBACK; - - /* This actually calls the perl subroutine, in scalar context */ - call_sv(*sv, G_SCALAR); - - $result = sv_newmortal(); - sv_setnv($result, (double) *$4); - argvi++; - sv_setnv($result, (double) *$5); - argvi++; - - if (argvi >= items) { - EXTEND(SP,1); - } - -} -// this is rarely prudent but seems to work -%typemap(in) void * { - $1 = (double *) $input; -}; -%{ - #include "gsl/gsl_math.h" - #include "gsl/gsl_deriv.h" -%} - -%include "gsl/gsl_math.h" -%include "gsl/gsl_deriv.h" -%include "../pod/Deriv.pod" +%module "Math::GSL::Deriv" +// Danger Will Robinson, for realz! + +%include "typemaps.i" +%include "gsl_typemaps.i" + +%{ + #include "gsl/gsl_math.h" + #include "gsl/gsl_deriv.h" +%} + +%include "gsl/gsl_math.h" +%include "gsl/gsl_deriv.h" +%include "../pod/Deriv.pod" diff --git a/swig/gsl_typemaps.i b/swig/gsl_typemaps.i index 6f8784e..e143c1d 100644 --- a/swig/gsl_typemaps.i +++ b/swig/gsl_typemaps.i @@ -8,6 +8,8 @@ typedef int size_t; %{ #include "gsl/gsl_nan.h" + #include "gsl/gsl_math.h" + #include "gsl/gsl_monte.h" %} %typemap(in) double const [] { @@ -46,6 +48,7 @@ typedef int size_t; double *abserr, double *result }; %{ +<<<<<<< HEAD:swig/gsl_typemaps.i static HV * Callbacks = (HV*)NULL; // Hash of callbacks, stored by memory address SV * Last_Call = (SV*)NULL; // last used callback, used as fudge for systems with MULTIPLICITY @@ -53,88 +56,209 @@ typedef int size_t; double callthis(double x , int func, void *params){ SV ** sv; +======= + + struct gsl_function_perl { + gsl_function C_gsl_function; + SV * function; + SV * params; + }; + struct gsl_monte_function_perl { + gsl_monte_function C_gsl_monte_function; + SV * f; + SV * dim; + SV * params; + }; + + + /* this function returns the value + of evaluating the function pointer + stored in func with argument x + */ + double call_gsl_function(double x , void *params){ + struct gsl_function_perl *F=(struct gsl_function_perl*)params; unsigned int count; double y; dSP; //fprintf(stderr, "LOOKUP CALLBACK\n"); - sv = hv_fetch(Callbacks, (char*)func, sizeof(func), FALSE ); - if (sv == (SV**)NULL) { - fprintf(stderr, 'not found in Callbacks'); - if (Last_Call != (SV*)NULL) { - fprintf(stderr, 'retrieving last_call'); - SvSetSV((SV*) sv, (SV*)Last_Call ); // Ya don't have to go home, but ya can't stay here - } else { - fprintf(stderr, "Math::GSL(callthis): %s (%d) not in Callbacks!\n", (char*) func, func); - return GSL_NAN; - } - } + ENTER; + SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVnv((double)x))); + XPUSHs(F->params); PUTBACK; /* make local stack pointer global */ - count = call_sv(*sv, G_SCALAR); + count = call_sv(F->function, G_SCALAR); SPAGAIN; if (count != 1) croak("Expected to call subroutine in scalar context!"); + y = POPn; + PUTBACK; /* make local stack pointer global */ + FREETMPS; + LEAVE; + + return y; + } + double call_gsl_monte_function(double *x_array , size_t dim, void *params){ + struct gsl_monte_function_perl *F=(struct gsl_monte_function_perl*)params; + unsigned int count; + unsigned int i; + AV* perl_array; + double y; + dSP; + + //fprintf(stderr, "LOOKUP CALLBACK\n"); + ENTER; + SAVETMPS; + + PUSHMARK(SP); + perl_array=newAV(); + sv_2mortal((SV*)perl_array); + XPUSHs(sv_2mortal(newRV((SV *)perl_array))); + for(i=0; iparams); + PUTBACK; /* make local stack pointer global */ + + count = call_sv(F->f, G_SCALAR); + SPAGAIN; + + if (count != 1) + croak("Expected to call subroutine in scalar context!"); y = POPn; + + PUTBACK; /* make local stack pointer global */ + FREETMPS; + LEAVE; + return y; } - double callmonte(double x[], size_t dim, void *params ){ - fprintf(stderr, "callmonte!!!"); - } %} -%typemap(in) gsl_monte_function * { - gsl_monte_function MF; - int count; - double x; - if (!SvROK($input)) { - croak("Math::GSL : $$1_name is not a reference value!"); + +%typemap(in) gsl_monte_function * (struct gsl_monte_function_perl w_gsl_monte_function) { + SV * f = 0; + SV * dim = 0; + SV * params = 0; + size_t C_dim; + + if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) { + AV* array=(AV*)SvRV($input); + SV ** p_f = 0; + if (av_len(array)<0) { + croak("Math::GSL : $$1_name is an empty array!"); + } + if (av_len(array)>2) { + croak("Math::GSL : $$1_name is an array with more than 3 elements!"); + } + p_f = av_fetch(array, 0, 0); + f = *p_f; + if (av_len(array)>0) { + SV ** p_dim = 0; + p_dim = av_fetch(array, 1, 0); + dim = *p_dim; + } + if (av_len(array)>1) { + SV ** p_params = 0; + p_params = av_fetch(array, 1, 0); + params = *p_params; + } + } else { + f = $input; } - if (Callbacks == (HV*)NULL) - Callbacks = newHV(); - fprintf(stderr,"STORE $$1_name gsl_monte_function CALLBACK: %d\n", (int)$input); - if (Last_Call == (SV*)NULL) // initialize Last_Call the first time it is called - Last_Call = newSV(sizeof($input)); + if (!f || !(SvPOK(f) || (SvROK(f) && (SvTYPE(SvRV(f)) == SVt_PVCV)))) { + croak("Math::GSL : $$1_name is not a reference to code!"); + } - hv_store( Callbacks, (char*)&$input, sizeof($input), newSVsv($input), 0 ); - SvSetSV( (SV*) Last_Call, newSVsv($input) ); + f = newSVsv(f); + + if (! dim) { + dim=&PL_sv_undef; + C_dim=0; + } else { + if (!SvIOK(dim)) { + croak("Math::GSL : $$1_name is not an integer for dim!"); + } + C_dim=SvIV(dim); + } + dim = newSVsv(dim); - MF.params = &$input; - MF.dim = 1; // XXX - MF.f = &callmonte; - $1 = &MF; + if (! params) { + params=&PL_sv_undef; + } + params = newSVsv(params); + + w_gsl_monte_function.f = f; + w_gsl_monte_function.dim = dim; + w_gsl_monte_function.params = params; + w_gsl_monte_function.C_gsl_monte_function.f = &call_gsl_monte_function; + w_gsl_monte_function.C_gsl_monte_function.dim = C_dim; + w_gsl_monte_function.C_gsl_monte_function.params = &w_gsl_monte_function; + $1 = &w_gsl_monte_function.C_gsl_monte_function; }; -%typemap(in) gsl_function * { - gsl_function F; - int count; - double x; +%typemap(in) gsl_function * (struct gsl_function_perl w_gsl_function) { + SV * function = 0; + SV * params = 0; - if (!SvROK($input)) { - croak("Math::GSL : $$1_name is not a reference value!"); + if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) { + AV* array=(AV*)SvRV($input); + SV ** p_function = 0; + if (av_len(array)<0) { + croak("Math::GSL : $$1_name is an empty array!"); + } + if (av_len(array)>1) { + croak("Math::GSL : $$1_name is an array with more than 2 elements!"); + } + p_function = av_fetch(array, 0, 0); + function = *p_function; + if (av_len(array)>0) { + SV ** p_params = 0; + p_params = av_fetch(array, 1, 0); + params = *p_params; + } + } else { + function = $input; } - if (Callbacks == (HV*)NULL) - Callbacks = newHV(); - //fprintf(stderr,"STORE CALLBACK hv: %d\n", (int)$input); - hv_store( Callbacks, (char*)&$input, sizeof($input), newSVsv($input) , 0 ); - //fprintf(stderr,"STORE CALLBACK sv: %d\n", (int)$input); - if (Last_Call == (SV*)NULL) // initialize Last_Call the first time it is called - Last_Call = newSV(sizeof($input)); + if (!function || !(SvPOK(function) || (SvROK(function) && (SvTYPE(SvRV(function)) == SVt_PVCV)))) { + croak("Math::GSL : $$1_name is not a reference to code!"); + } - SvSetSV( (SV*) Last_Call, newSVsv($input) ); // Store the last used callback, in case we cannot find it by address - //fprintf(stderr,"STORE CALLBACK post-sv: %d\n", (int)$input); + function = newSVsv(function); + + if (! params) { + params=&PL_sv_undef; + } + params = newSVsv(params); + + w_gsl_function.params = params; + w_gsl_function.function = function; + w_gsl_function.C_gsl_function.params = &w_gsl_function; + w_gsl_function.C_gsl_function.function = &call_gsl_function; + $1 = &w_gsl_function.C_gsl_function; +}; + +%typemap(freearg) gsl_monte_function * { + struct gsl_monte_function_perl *p=(struct gsl_monte_function_perl *) $1->params; + SvREFCNT_dec(p->f); + SvREFCNT_dec(p->dim); + SvREFCNT_dec(p->params); +}; - F.params = &$input; - F.function = &callthis; - $1 = &F; +%typemap(freearg) gsl_function * { + struct gsl_function_perl *p=(struct gsl_function_perl *) $1->params; + SvREFCNT_dec(p->function); + SvREFCNT_dec(p->params); }; %typemap(in) gsl_function_fdf * { diff --git a/t/Deriv.t b/t/Deriv.t index 0bf78b0..e150e2e 100644 --- a/t/Deriv.t +++ b/t/Deriv.t @@ -1,6 +1,6 @@ package Math::GSL::Deriv::Test; use base 'Test::Class'; -use Test::More tests => 9; +use Test::More tests => 13; use Math::GSL qw/:all/; use Math::GSL::Test qw/:all/; use Math::GSL::Deriv qw/:all/; @@ -25,11 +25,23 @@ sub TEST_FUNCTION_STRUCT : Tests(1) { isa_ok( $self->{gsl_func},'Math::GSL::Deriv::gsl_function_struct'); } -sub TEST_DERIV_CENTRAL_DIES : Tests(1) { +sub TEST_DERIV_CENTRAL_DIES : Tests(5) { my ($x,$h)=(10,0.01); throws_ok( sub { gsl_deriv_central( 'IAMNOTACODEREF', $x, $h); - },qr/not a reference value/, 'gsl_deriv_central borks when first arg is not a coderef'); + },qr/Undefined subroutine/, 'gsl_deriv_central borks when first arg is not a existing routine'); + throws_ok( sub { + gsl_deriv_central( undef, $x, $h); + },qr/not a reference to code/, 'gsl_deriv_central borks when first arg is undef'); + throws_ok( sub { + gsl_deriv_central( {}, $x, $h); + },qr/not a reference to code/, 'gsl_deriv_central borks when first arg is hash ref'); + throws_ok( sub { + gsl_deriv_central( [], $x, $h); + },qr/is an empty array/, 'gsl_deriv_central borks when first arg is an empty array ref'); + throws_ok( sub { + gsl_deriv_central( 'IAMNOTACODEREF', $x, $h); + },qr/Undefined subroutine/, 'gsl_deriv_central borks when first arg is not a existing routine'); } sub TEST_DERIV_CENTRAL : Tests(2) { -- 2.11.4.GIT