in reply to Re^14: Perl crash during perl_clone
in thread Perl crash during perl_clone

Hi BrowserUk:

I got back in town and got your original and a modified version working (mostly changes like VOID to void * etc were needed). Ofcourse, this worked just as in your experience. So, didnt post that version here. However, I got two other versions that do not work and fail similar to my real project. I've posted them below. I really hope you will be able to shed some light. Thanks

cback_test.pl & cback_test.pm : In this variant, both CCBs are invoked from same thread. I tried to structure the files closer to how my project files are structured (i.e separate pm). Please see addl comments in the code too.

The 2nd version is posted further below 

#! perl -slw
use strict;
use cback_test;
use Inline C => Config => BUILD_NOISY => 1;
use Inline C => <<'END_C',  NAME => '_867652', CLEAN_AFTER_BUILD => 0;

PerlInterpreter *saved1;
SV *cback1;

PerlInterpreter *saved2;
SV *cback2;

void cbProc1( unsigned int time ) {
//this always returns "0"
    PerlInterpreter *temp = Perl_get_context();

    printf( "Time in C-Callback1: %u. Prior ctx %lud\n", time , temp);

    PERL_SET_CONTEXT( saved1 );
    {
        dSP;
        ENTER;
        SAVETMPS;
        PUSHMARK( SP );
        XPUSHs( sv_2mortal( newSVuv( (UV)time ) ) );
        PUTBACK;

        call_sv( cback1, G_DISCARD );

        FREETMPS;
        LEAVE;
    }
    PERL_SET_CONTEXT( temp );
    return;
}

void cbProc2( unsigned int time ) {
//this always returns "0"
    PerlInterpreter *temp = Perl_get_context();

    printf( "Time in C-Callback2: %u.  Prior ctx %lud\n", time , temp)
+;

    PERL_SET_CONTEXT( saved2 );
    {
        dSP;
        ENTER;
        SAVETMPS;
        PUSHMARK( SP );
        XPUSHs( sv_2mortal( newSVuv( (UV)time ) ) );
        PUTBACK;

//the error msg shows up after calling this
        call_sv( cback2, G_DISCARD );

        FREETMPS;
        LEAVE;
    }
    PERL_SET_CONTEXT( temp );
    return;
}

void* thread1( void *arg ) {
    int i=0;
    while( i++<5 ) {
         sleep( 5 );
         printf( "Here in thread1..calling CCB1\n" );
         cbProc1( time(NULL) );
     }
    i=0;
    while( i++<5 ) {
         sleep( 5 );
         printf( "Here in thread1..calling CCB2\n" );
         cbProc2( time(NULL) );
     }
}

void* thread2( void *arg ) {
    while( sleep( 7 ), 1 ) {
         printf( "Here in thread2\n" );
         cbProc2( time(NULL) );
     }
}

void setCallback1( SV* cv ) {
    pthread_t tid;
//my code did not have the dTHX here, but adding it made no difference
+ (i.e saved1 the same).
    //dTHX;
//saved1 and saved2 are always the same too.
    saved1 = Perl_get_context();
    cback1 = cv;

    printf("saved1 = %lud\n", saved1);
    // Start callback timer thread
    pthread_create( &tid, NULL, thread1, NULL );
    return;
}

void setCallback2( SV* cv ) {
    pthread_t tid;
//my code did not have the dTHX here, but adding it made no difference
+ (i.e saved2 is the same).
    //dTHX;
    saved2 = Perl_get_context();
    cback2 = cv;

    printf("saved2 = %lud\n", saved2);
    // Start callback timer thread
    //pthread_create( &tid, NULL, thread2, NULL );
    return;
}

END_C

$|++;

print "Setting callback1..\n";

#Registering cback rhis gives a coredump or one or several other error
+s
#when CCB calls PCB
#setCallback1(\&cback_test::callback1);

#this syntax works as expected in this program, but this doesnt
#work (the pcb ref is not valid or null) when my typemap using SWIG ru
+ns
setCallback1('cback_test::callback1');

while ($cback_test::cb1_cnt != 4)
{
  print "Waiting for callback1 to finish..\n";
  sleep(1);
}

print "Setting callback2..\n";
setCallback2(\&cback_test::callback2);

while ($cback_test::cb2_cnt != 4)
{
  print "Waiting for callback2 to finish..\n";
  sleep(1);
}

sleep (15);

__END__

[download]


package cback_test;

$cb1_cnt = 0;
sub callback1 {
    print "Timer value in callback1 is: $_[0]";
    $cb1_cnt++;
    return;
}

$cb2_cnt = 0;
sub callback2 {
    print "Timer value in callback2 is: $_[0]";
    $cb2_cnt++;
    return;
}

1;

[download]

Here in thread1..calling CCB2
Time in C-Callback2: 1289205658.  Prior ctx 0d
Use of inherited AUTOLOAD for non-method main::1289205658() is depreca
+ted at cback_test3.pl line 137.
Segmentation fault

[download]

myModule.xs and test.pl : These are from the a "fake" module I created using  h2xs -AX myModule. I then had to  ln -s lib/myModule.pm . and  ln -s blib/arch/auto/myModule/myModule.so . to successfully run the test.pl (I'm sure there is a better way, but this worked). 

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#include <pthread.h>
static PerlInterpreter *orig_perl=NULL;

SV* cb_ptr1 = NULL;
SV* cb_ptr2 = NULL;

void InvokeCB ()
{
   static int val = 0;
   SV * sv;

   val++;
   Perl_set_context(orig_perl);
   printf("curr_ctx is %lud\n", Perl_get_context());
   dSP;
   ENTER;
   SAVETMPS;
   PUSHMARK(SP);

   if (val >= 5)
      sv = cb_ptr2;
   else
      sv = cb_ptr1;

   printf("invoking %lud\n", sv);
   XPUSHs(sv_2mortal(newSViv(val)));
                                                                      
+             PUTBACK;
   call_sv(sv, G_DISCARD);

   FREETMPS;
   LEAVE;
}

void * BGThread(void * dontcare)
{
   while (1)
   {
      sleep(5);
      InvokeCB();
   }
}


MODULE = myModule               PACKAGE = myModule

int
RegisterCB1 (SV *SubRef)
    CODE:
       orig_perl = Perl_get_context();
       printf("orig_ctx is %lud\n", orig_perl);
       pthread_t tid;
       pthread_create(&tid, NULL, BGThread, NULL);
       orig_perl = PERL_GET_CONTEXT;
       cb_ptr1 = SubRef;
       printf("registered %lud\n", cb_ptr1);
       RETVAL = 1;
    OUTPUT:
       RETVAL

int
RegisterCB2 (SV *SubRef)
    CODE:
       cb_ptr2 = SubRef;
       printf("registered %lud\n", cb_ptr1);
       RETVAL = 1;
    OUTPUT:
       RETVAL

[download]

#! /usr/local/bin/perl

use myModule;
use warnings;

$cb_done1 = 0;
$cb_done2 = 0;
@results = ();

sub cb_one
{
  ($value) = @_;
   print "cb_onr called. val received : ", $value, "\n";
   $results[scalar(@results)] = $value;

   if ($value == 5)
   {
      print "cb_done changed to one.\n";
      $cb_done1 = 1;
   }
}

sub cb_two
{
  ($value) = @_;
   print "cb_two called. val received : ", $value, "\n";
   $results[scalar(@results)] = $value;

   if ($value == 10)
   {
      print "cb_done2 changed to one.\n";
      $cb_done2 = 1;
   }
}

print "Registering CB1...\n";

$status = myModule::RegisterCB1(\&main::cb_one);
do
{
   print "Waiting for CB1 to be done...\n";
   sleep (1);
} until ($cb_done1 == 1);

print "CB1 was invoked : $cb_done1\n";
print "results are : @results \n";

$status = myModule::RegisterCB2(\&main::cb_two);
do
{
   print "Waiting for CB2 to be done...\n";
   sleep (1);
} until ($cb_done2 == 1);

print "CB2 was invoked : $cb_done2\n";
print "results are : @results \n";

[download]
Registering CB1...
orig_ctx is 151171080d
registered 151189632d
Waiting for CB1 to be done...
Waiting for CB1 to be done...
Waiting for CB1 to be done...
Waiting for CB1 to be done...
Waiting for CB1 to be done...
curr_ctx is 151171080d
invoking 151189632d
Undefined subroutine &main::1 called at test.pl line 42.
make: *** [test_dynamic] Error 255

[download]

Replies are listed 'Best First'.
Re^16: Perl crash during perl_clone
by BrowserUk (Patriarch) on Nov 08, 2010 at 13:12 UTC

    As best I can tell, this does everything your samples do. I've discarded everything that doesn't seem to be needed.

    This sets up 4 different callbacks, from a different package than where the callbacks are set up. They are called back randomly.

    Each CCB passes through a value from C->perl. Each PCB accepts and displays that value; and modifies a closed over variable.

    This runs perfectly, flat out using all four of my cores for as long as I choose to leave it.

    The errors during global destruction--when the perl thread ends--are simply because the C-threads are still running and continue trying to call back to perl as it is throwing everything away.

    If I try to pass the callback addresses by code-reference instead of name, I too get traps. I don't know why, so don't do that.

    I don't think there is much more I can do for you. If the below (suitably adapted to your platform), doesn't work for you, then it will require more expertise than I have in one more of: XS, *nix, perlguts.

    Update: Had to put back the ENTER/SAVETMPS/FRETMPS/LEAVE brackets otherwise it leaked memory. 

    #! perl -slw
use strict;
use Inline C => Config => BUILD_NOISY => 1;
use Inline C => <<'END_C',  NAME => '_867652', CLEAN_AFTER_BUILD => 0;


PerlInterpreter *saved;
SV *callbacks[ 4 ];

VOID CALLBACK cbProc( int cbn, DWORD time ) {
    printf( "CCB[%d]: %u\n", cbn, time );

    PERL_SET_CONTEXT( saved );
    {
        dSP;
        ENTER;
        SAVETMPS;
        PUSHMARK( SP );
        XPUSHs( sv_2mortal( newSVuv( (UV)time ) ) );
        PUTBACK;
        call_sv( callbacks[ cbn ], G_DISCARD );
        FREETMPS;
        LEAVE;
    }
    return;
}

void __cdecl thread( VOID *arg ) {
    while( Sleep( 1 ), 1 ) { // This is Win32 Sleep The argument is in
+ milliseconds!
         cbProc( rand() & 3, GetTickCount() );
     }
}

void setCallback( SV *cb1, SV* cb2, SV *cb3, SV *cb4 ) {
    saved = Perl_get_context();
    callbacks[0] = cb1;
    callbacks[1] = cb2;
    callbacks[2] = cb3;
    callbacks[3] = cb4;
    _beginthread( &thread, 0, NULL );
    return;
}

END_C
$|++;

{
    package fred;
    my @c = (0) x 4;

    sub callback1 { ++$c[0]; print "PCB1: $_[0] ($c[0])"; return; }
    sub callback2 { ++$c[1]; print "PCB2: $_[0] ($c[1])"; return; }
    sub callback3 { ++$c[2]; print "PCB3: $_[0] ($c[2])"; return; }
    sub callback4 { ++$c[3]; print "PCB4: $_[0] ($c[3])"; return; }
}

setCallback( 'fred::callback1', 'fred::callback2', 'fred::callback3', 
+'fred::callback4' );

sleep 10;

__END__
C:\test>867652
CCB[1]: 828337244
PCB2: 828337244 (1)
CCB[3]: 828337244
PCB4: 828337244 (1)
CCB[2]: 828337244
PCB3: 828337244 (1)
CCB[0]: 828337260
PCB1: 828337260 (1)
CCB[1]: 828337260
PCB2: 828337260 (2)
CCB[0]: 828337260
PCB1: 828337260 (2)
CCB[2]: 828337275
PCB3: 828337275 (2)
CCB[2]: 828337275
PCB3: 828337275 (3)
CCB[2]: 828337291
PCB3: 828337291 (4)
CCB[0]: 828337291
PCB1: 828337291 (3)
CCB[1]: 828337291
PCB2: 828337291 (3)
...
PCB4: 828283221 (2033)
CCB[0]: 828283221
PCB1: 828283221 (2039)
CCB[3]: 828283221
Use of uninitialized value in null operation during global destruction
+.
Use of inherited AUTOLOAD for non-method main::() is deprecated during
+ global destruction.
Use of uninitialized value $pkg in substitution (s///) at C:/Perl64/li
+b/AutoLoader.pm line 73 during global destruction.
Use of uninitialized value $pkg in substitution (s///) at C:/Perl64/li
+b/AutoLoader.pm line 7m line 74 during global destruction.
Use of uninitialized value $pkg in concatenation (.) or string at C:/P
+erl64/lib/AutoLoader.pm line 74 during global destruction.

    [download]
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
Re^16: Perl crash during perl_clone
by BrowserUk (Patriarch) on Nov 08, 2010 at 13:42 UTC

    This version takes it one stage further and runs two concurrent C-threads sharing the same 4 callbacks. As the threads are calling back into the same Perl code, if they both randomly pick the same callback on different cores at the same time, then two threads are trying to access Perl's internals concurrently and things go pear-shaped.

    To prevent this I've added a (very simplistic) user space mutex to ensure that only one thread enters a callback at any given time. This uses the global integer sem, increments and decrements and free-running while loops. Its processor intensive, probably full of race conditions and too broad a granularity--I should use 1 per callback not one for all callbacks--but it is surprisingly effective and serves to demonstrate the solution. You should probably use proper pthreads condition vars.

    Update: putback the scoping brackets and switched to using proper mutexes. 

    #! perl -slw
use strict;
use Inline C => Config => BUILD_NOISY => 1;
use Inline C => <<'END_C',  NAME => '_867652', CLEAN_AFTER_BUILD => 0;

//int sem = 0; // crude simulation.
PerlInterpreter *saved;
SV *callbacks[ 4 ];
SRWLOCK locks[ 4 ]; // one per callback

VOID CALLBACK cbProc( int cbn, DWORD time ) {
    printf( "CCB[%d]: %u\n", cbn, time );

    PERL_SET_CONTEXT( saved );
    {
        dSP;
        ENTER;
        SAVETMPS;
        PUSHMARK( SP );
        XPUSHs( sv_2mortal( newSVuv( (UV)time ) ) );
        PUTBACK;
        call_sv( callbacks[ cbn ], G_DISCARD );
        FREETMPS;
        LEAVE;
    }
    return;
}

void __cdecl thread2( VOID *arg ) {
    while( Sleep( 1 ), 1 ) {
        AcquireSRWLockExclusive( &locks[ choice ] );
        cbProc( rand() & 3, GetTickCount() );
        ReleaseSRWLockExclusive( &locks[ choice ] );
     }
}

void __cdecl thread1( VOID *arg ) {
    while( Sleep( 1 ), 1 ) {
        AcquireSRWLockExclusive( &locks[ choice ] );
        cbProc( rand() & 3, GetTickCount() );
        ReleaseSRWLockExclusive( &locks[ choice ] );
     }
}

void setCallback( SV *cb1, SV* cb2, SV *cb3, SV *cb4 ) {
    int i;
    saved = Perl_get_context();
    callbacks[0] = cb1;
    callbacks[1] = cb2;
    callbacks[2] = cb3;
    callbacks[3] = cb4;
    for( i=1; i < 4; ++i ) 
        InitializeSRWLock( &locks[ i ] );
    _beginthread( &thread1, 0, NULL );
    _beginthread( &thread2, 0, NULL );
    return;
}

END_C
$|++;

{
    package fred;
    my @c = (0) x 4;

    sub callback1 { ++$c[0]; print "PCB1: $_[0] ($c[0])"; return; }
    sub callback2 { ++$c[1]; print "PCB2: $_[0] ($c[1])"; return; }
    sub callback3 { ++$c[2]; print "PCB3: $_[0] ($c[2])"; return; }
    sub callback4 { ++$c[3]; print "PCB4: $_[0] ($c[3])"; return; }
}

setCallback( 
    'fred::callback1', 
    'fred::callback2', 
    'fred::callback3', 
    'fred::callback4' 
);

sleep 100;

__END__

    [download]
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
[select]
      Hi BrowserUk,

      Thanks again for the response. I will try tomorrow, but I'm also fairly positive, these versions will work for me too..Fundamentally, there seems no issue with callbacks perse, as long as I comply with your comment that.

      If I try to pass the callback addresses by code-reference instead of name, I too get traps. I don't know why, so don't do that.

      Although, it is strange why the code-ref way works, reliably, for one of my callbacks registered this way.

      I had tried, but the SWIG typemaps I have currently did not allow the 'modulename:subname' format to register the callbacks. I'll have to dig into that more. Will hopefully have good news to share tomorrow!

[reply]
        I had tried, but the SWIG typemaps I have currently did not allow the 'modulename:subname' format to register the callbacks.

        I don't understand this. The SWIG stuff wraps the registering of the CCB, not the PCB.

        So you "register" the PCB--by storing the SV* you pass into your code. You then call that stored SV* (using call_sv()) when the SWIG stuff calls back you CCB.

        I agree that call_sv() should handle coderefs (according to the documentation; I even think I've done it in the past on 5.8x era perls), but every time I've tried it recently, it falls in a heap with coderefs (with or without threads involved), and works as advertised with a function name. So I stick with the latter. It does mean you have to name the callbacks rather than use anonymous subs or blocks, but that is an acceptable limitation (for me).

        I having trouble understanding why you cannot do the same?

        Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
        "Science is about questioning the status quo. Questioning authority".
        In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
Re^16: Perl crash during perl_clone
by perlmonk1729 (Acolyte) on Nov 08, 2010 at 11:47 UTC
    It seems the issue is dependent on how the call-back reference is obtained while registering the perl-sub. Insterestly, the callback mechanism works fine in only ONE of the callbacks I've defined and used. In several others callbacks, I get an error similar to the above post, or a "not a CODE ref" error. I cannot yet decipher what is different between how I get the references to the other subs..

    They are use the "\&modname::subname" syntax & a few variants like storing the reference in a scalar and passing it later to the registration subroutine.

    Note: I edited out specific strings/literals in the output below to anonymize. 

    
SV = RV(0xae2f0ec) at 0xae2f0e0
  REFCNT = 1
  FLAGS = (PADMY,ROK)
  RV = 0xae2c0b8
    SV = PVCV(0xae0c270) at 0xae2c0b8
      REFCNT = 2
      FLAGS = ()
      COMP_STASH = 0xa1b1d30    "module-name"
      START = 0xa3324d0 ===> 0
      ROOT = 0xa3afcf0
      GVGV::GV = 0xae2f140      "module-name" :: "subname"
      FILE = "lib//module-name.pm"
      DEPTH = 0
      FLAGS = 0x0
      OUTSIDE_SEQ = 8538
      PADLIST = 0xae2c3f8
        PADNAME = 0xae2c418(0xa458a78) PAD = 0xae2c438(0xa6337a8)
             1. 0xae2c458<1> (8538,8561) "$event"
             2. 0xae2c498<1> (8538,8561) "$pdata"
             6. 0xae2c558<1> (8539,8561) "@details"
<...several other rows, one each for what seems to be a local/my varia
+ble in the subroutine...>
      OUTSIDE = 0xa19fe18 (UNIQUE)

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom