BrowserUk has asked for the wisdom of the Perl Monks concerning the following question:

Update: The long and short of it is that I was doing it myself. When the thread ends, my DESTROY() function is called; which was freeing up the memory. The corruption was the free memory tags used by the allocator!

The fact that the object still "worked" after it memory was all freed is just luck.

I have an XS module that presents as class; by returning a pointer to the internal C struct wrapped up in a blessed RV->IV using sv_setref_pv().

In single threaded code this works perfectly.

And if I return the object reference from a thread, once I get it back in the main thread, it still "works". That is, invoking methods on the returned (cloned) blessed reference invokes the appropriate code, and the wrapped over C pointer still points to the appropriate data.

However, some corruption has crept in to the referenced structure. Or rather, another structure (a C array of structs) referenced from within the referenced struct. (I know; as clear as mud; but please bear with me if you are likely to be able to help.)

The code at the bottom of the post produces this output, though I reformatted it here for discussion purposes.

The left-hand side is produced (Devel::Peek::Dump) from within the thread once the object has been populated. The right-hand side is produced back in the main thread once the bless ref has been passed back via join:

SV = RV(0x4b1e750) at 0x4b1e740                                       
+                SV = RV(0x4386f70) at 0x4386f60
  REFCNT = 1                                                          
+                  REFCNT = 1
  FLAGS = (PADMY,ROK)                                                 
+                  FLAGS = (PADMY,ROK)
  RV = 0x4b229c0                                                      
+                  RV = 0x2977b0
  SV = PVMG(0x4b032d8) at 0x4b229c0                                   
+                  SV = PVMG(0x424f3b8) at 0x2977b0
    REFCNT = 1                                                        
+                    REFCNT = 1
    FLAGS = (OBJECT,IOK,POK,pIOK,pPOK)                                
+                    FLAGS = (OBJECT,IOK,POK,pIOK,pPOK)
    IV = 49572896                                                     
+                    IV = 49572896
    NV = 0                                                            
+                    NV = 0
    PV = 0x4b5eb38 "49572896"\0                                       
+                    PV = 0x4b5ead8 "49572896"\0
    CUR = 8                                                           
+                    CUR = 8
    LEN = 16                                                          
+                    LEN = 16
    STASH = 0x442c448   "BiMap"                                       
+                    STASH = 0x297870    "BiMap"

[download]

Whilst most of the values have changed due to the cloning; the two salient parts: 1) the C pointer held in the IV field; 2) the package/class associated with the stash; have survived the cloning intact. And indeed, the cloned blessed ref still works as an object.

However, when I dump the contents of the object pre & post cloning; the content of the C data has been subtly corrupted; and in a way that utterly baffles me.

For reference, here are the two struct definitions involved:

typedef struct {
    U64 addr;
    char *name;
} PAIR;

typedef struct {
    PAIR **byInt;
    U32   *byStr;
    U32    size;
    U32    used;
    double factor;
} BIMAP;

[download]

The blessed reference contains a pointer to a BIMAP struct; which in turn contains two pointer to arrays; one of PAIR structs; the other of U32s.

And the dumps: again, the left-hand side comes from within the thread; the right-hand side back in the main thread:

Object:0000000002F46C20 byInt:0000000002F46C50 byStr:0000000002F46E60 
+size:32 used:26 Object:0000000002F46C20 byInt:0000000002F46C50 byStr:
+0000000002F46E60 size:32 used:26
   0: pair:[00000000000E6220] 0000000013 m          [ byStr:     29 ] 
+                   0: pair:[00000000000E89A0] 0049572176 αλ?        [
+ byStr:     29 ]
   1:[EMPTY SLOT]                                   [ byStr:      0 ] 
+                   1: pair:[00000000000E0158] 0000952736 X??        [
+ byStr:      0 ]
   2: pair:[00000000000E6280] 0000000016 p          [ byStr:      7 ] 
+                   2: pair:[00000000000E6280] 0000000036 p          [
+ byStr:      7 ]
   3:[EMPTY SLOT]                                   [ byStr:      0 ] 
+                   3:[EMPTY SLOT]                                   [
+ byStr:      0 ]
   4:[EMPTY SLOT]                                   [ byStr:      0 ] 
+                   4:[EMPTY SLOT]                                   [
+ byStr:      0 ]
   5: pair:[00000000000E60C0] 0000000002 b          [ byStr:      0 ] 
+                   5: pair:[00000000000E60C0] 0000000042 b          [
+ byStr:      0 ]
   6: pair:[00000000000E6200] 0000000012 l          [ byStr:     12 ] 
+                   6: pair:[00000000000E6200] 0000000014 l          [
+ byStr:     12 ]
   7: pair:[00000000000E6360] 0000000023 w          [ byStr:     20 ] 
+                   7: pair:[00000000000E6360] 0000000034 w          [
+ byStr:     20 ]
   8: pair:[00000000000E60E0] 0000000003 c          [ byStr:     16 ] 
+                   8: pair:[00000000000E60E0] 0000000056 c          [
+ byStr:     16 ]
   9: pair:[00000000000E60A0] 0000000001 a          [ byStr:      3 ] 
+                   9: pair:[00000000000E60A0] 0000000016 a          [
+ byStr:      3 ]
  10: pair:[00000000000E6100] 0000000004 d          [ byStr:     18 ] 
+                  10: pair:[00000000000E6100] 0000000012 d          [
+ byStr:     18 ]
  11: pair:[00000000000E6140] 0000000006 f          [ byStr:      9 ] 
+                  11: pair:[00000000000E6140] 0000000018 f          [
+ byStr:      9 ]
  12: pair:[00000000000E6160] 0000000007 g          [ byStr:     23 ] 
+                  12: pair:[00000000000E6160] 0000000022 g          [
+ byStr:     23 ]
  13: pair:[00000000000E61E0] 0000000011 k          [ byStr:      6 ] 
+                  13: pair:[00000000000E61E0] 0000000024 k          [
+ byStr:      6 ]
  14: pair:[00000000000E6260] 0000000015 o          [ byStr:     11 ] 
+                  14: pair:[00000000000E6260] 0000000032 o          [
+ byStr:     11 ]
  15: pair:[00000000000E6300] 0000000020 t          [ byStr:     15 ] 
+                  15: pair:[00000000000E6300] 0000000040 t          [
+ byStr:     15 ]
  16: pair:[00000000000E6340] 0000000022 v          [ byStr:     10 ] 
+                  16: pair:[00000000000E6340] 0000000050 v          [
+ byStr:     10 ]
  17: pair:[00000000000E63A0] 0000000025 y          [ byStr:     13 ] 
+                  17: pair:[00000000000E63A0] 0000000054 y          [
+ byStr:     13 ]
  18: pair:[00000000000E63C0] 0000000026 z          [ byStr:     21 ] 
+                  18: pair:[00000000000E63C0] 0000000060 z          [
+ byStr:     21 ]
  19: pair:[00000000000E62A0] 0000000017 q          [ byStr:     25 ] 
+                  19: pair:[00000000000E62A0] 0000000062 q          [
+ byStr:     25 ]
  20: pair:[00000000000E6120] 0000000005 e          [ byStr:     26 ] 
+                  20: pair:[00000000000E6120] 0000000044 e          [
+ byStr:     26 ]
  21: pair:[00000000000E61A0] 0000000009 i          [ byStr:      1 ] 
+                  21: pair:[00000000000E61A0] 0000000020 i          [
+ byStr:      1 ]
  22: pair:[00000000000E6240] 0000000014 n          [ byStr:     19 ] 
+                  22: pair:[00000000000E6240] 0000000028 n          [
+ byStr:     19 ]
  23: pair:[00000000000E61C0] 0000000010 j          [ byStr:      0 ] 
+                  23: pair:[00000000000E61C0] 0000000038 j          [
+ byStr:      0 ]
  24: pair:[00000000000E62C0] 0000000018 r          [ byStr:      0 ] 
+                  24: pair:[00000000000E62C0] 0000000030 r          [
+ byStr:      0 ]
  25: pair:[00000000000E62E0] 0000000019 s          [ byStr:     24 ] 
+                  25: pair:[00000000000E62E0] 0000000046 s          [
+ byStr:     24 ]
  26: pair:[00000000000E6180] 0000000008 h          [ byStr:     28 ] 
+                  26: pair:[00000000000E6180] 0000000048 h          [
+ byStr:     28 ]
  27: pair:[00000000000E6320] 0000000021 u          [ byStr:     22 ] 
+                  27: pair:[00000000000E6320] 0000000026 u          [
+ byStr:     22 ]
  28: pair:[00000000000E6380] 0000000024 x          [ byStr:     27 ] 
+                  28: pair:[00000000000E6380] 0000000052 x          [
+ byStr:     27 ]
  29:[EMPTY SLOT]                                   [ byStr:     17 ] 
+                  29:[EMPTY SLOT]                                   [
+ byStr:     17 ]
  30:[EMPTY SLOT]                                   [ byStr:      8 ] 
+                  30:[EMPTY SLOT]                                   [
+ byStr:      8 ]
  31:[EMPTY SLOT]                                   [ byStr:     14 ] 
+                  31:[EMPTY SLOT]                                   [
+ byStr:     14 ]

[download]

Things to note:

The question is simple: What the ..... HELP!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Probably not helpful, but here's a (hand constructed) memory map of the layout of the data:

<Reveal this spoiler or all spoilers in this node or all in this thread>

The code:

#! perl -slw
package BiMap; use strict; #use Config;
use Inline C => Config => BUILD_NOISY => 1; #, ccflags => $Config{ccfl
+ags} . '-D_CRT_SECURE_NO_WARNINGS';
use Inline C => <<'END_C',  NAME => 'BiMap_t', CLEAN_AFTER_BUILD =>0, 
+TYPEMAPS => '/test/BiMap.typemap';;

#undef malloc
#undef calloc
#undef free
# define TAG printf( "%s[%u]\n", __FILE__, __LINE__ )

#define CLASS "BiMap"
#define HASH_SEED 0xc0d1f1ed
#define U64_HIBIT 0x8000000000000000ull


U32 __inline hash( const unsigned char *str, const STRLEN len) {
    const unsigned char * const end = (const unsigned char *)str + len
+;
    U32 hash = HASH_SEED;

    while (str < end) {
        hash += *str++;
        hash += (hash << 10);
        hash ^= (hash >> 6);
    }
    hash += (hash << 3);
    hash ^= (hash >> 11);
    hash += (hash << 15);
    return hash;
}

U32 __inline nextPowerOfTwo( U32 v ) {
    v--;
    v |= v >> 1; v |= v >> 2; v |= v >> 4; v |= v >> 8; v |= v >> 16;
    v += (v == 0);
    return ++v;
}

typedef unsigned __int64 U64;

typedef struct {
    U64 addr;
    char *name;
} PAIR;

typedef struct {
    PAIR **byInt;
    U32   *byStr;
    U32    size;
    U32    used;
    double factor;
} BIMAP;

void dump( BIMAP *bm, int dumpBody ) {
    U32 i;
    printf( "\n\nObject:%8p byInt:%8p byStr:%8p size:%u used:%u\n", bm
+, bm->byInt, bm->byStr, bm->size, bm->used );
    if( dumpBody )
        for( i = 0; i < bm->size; ++i ) {
            PAIR *pair = bm->byInt[ i ];
            if( !pair ) printf( "%4u:[EMPTY SLOT]                     
+              ", i );
            else {
                char *name = ( (U64)pair->name & U64_HIBIT ? (char*)&p
+air->name : pair->name );
                U64 addr = pair->addr;

                printf( "%4d: pair:[%p] %10.10I64u %-10s ", i ,pair, a
+ddr, name );
            }
            printf( "[ byStr: %6u ]\n",  bm->byStr[ i ] );
        }
}

BIMAP *new( U32 initSize, double factor ) {
    BIMAP *bm = (BIMAP*)malloc( sizeof( BIMAP ) );
    initSize  = nextPowerOfTwo( initSize );
    bm->byInt = (PAIR**)calloc( initSize, sizeof( PAIR ) );
    bm->byStr = (U32*)calloc( initSize, sizeof( U32 ) );
    bm->size  = initSize;
    bm->used  = 0;
    bm->factor = factor;
    return bm;
}

U32 used( BIMAP *bm ) { return bm->used; }
U32 size( BIMAP *bm ) { return bm->size; }
double factor( BIMAP *bm ) { return bm->factor; }
U32 addPair( BIMAP *bm, PAIR *pair );
U32 add( BIMAP *bm, U64 i, SV *sv );


void resize( BIMAP *bm, U32 newSize ) {
    BIMAP *newBm = new( newSize, bm->factor );
    U32 i;

//    printf( "Resize: from %u(%u) to %u\n", bm->size, bm->used, newSi
+ze );

    for( i = 0; i < bm->size; ++i ) {
        if( bm->byInt[ i ] ) {
            addPair( newBm, bm->byInt[ i ] );
        }
    }
    free( bm->byInt );
    free( bm->byStr );
    bm->byInt = newBm->byInt;
    bm->byStr = newBm->byStr;
    bm->size  = newBm->size;
    bm->used  = newBm->used;
    free( newBm );
    return;
}

U32 __inline addPair( BIMAP *bm, PAIR *pair ) {
    U32 nameLen = (U32)strlen( (U64)pair->name & U64_HIBIT ? (char*)&p
+air->name : pair->name );
    register U32 mask = bm->size - 1;
    register U32 iHash = hash( (char*)&pair->addr, 8 ) & mask,
                 sHash = hash( (U64)pair->name & U64_HIBIT ? (char*)&p
+air->name : pair->name, nameLen ) & mask;
    U32 iIters = 0, sIters = 0;

    if( bm->used > (U32)( bm->size * bm->factor ) ) {
        resize( bm, bm->size * 2 );
        mask = bm->size - 1;
        iHash = hash( (char*)&pair->addr, 8 ) & mask;
        sHash = hash( (U64)pair->name & U64_HIBIT ? (char*)&pair->name
+ : pair->name, nameLen ) & mask;
    }

    while( bm->byInt[ iHash ] ) {
        ++iIters;
        iHash = ( iHash + 1 ) & mask;
    }
    while( bm->byStr[ sHash ] ) {
        ++sIters;
        sHash = ( sHash + 1 ) & mask;
    }

    bm->byInt[ iHash ] = pair;
    bm->byStr[ sHash ] = iHash+1;
    bm->used++;

    return iIters + sIters;
}

U32 add( BIMAP *bm, U64 i, SV *sv ) {
    STRLEN l;
    char *s = SvPV( sv, l );
    PAIR *pair = (PAIR*)calloc( 1, sizeof( PAIR ) );

    pair->addr = i;

    if( l < 7 ) {
        strncpy( (char*)(&pair->name), s, l );
        (U64)pair->name |= U64_HIBIT;
    }
    else {
        pair->name = _strdup( s );
    }
    return addPair( bm, pair );
}

U64 findByStr( BIMAP *bm, char *s ) {
    U32 sLen = (U32)strlen( s );
    register U32 mask = bm->size - 1, sIters = 0;
    register U32 sHash = hash( s, sLen ) & mask;
    register PAIR **byInt = bm->byInt;
    register U32   *byStr = bm->byStr;
    register char *name;

    if( !byStr[ sHash ] ) return -1;

    name = (U64)byInt[ byStr[ sHash ]-1 ]->name & U64_HIBIT
         ? (char*)&(U64)byInt[ byStr[ sHash ]-1 ]->name
         : byInt[ byStr[ sHash ]-1 ]->name;

    while( strcmp( name, s ) ) {
        sHash = ( sHash + 1 ) & mask;
        if( !byStr[ sHash ] || !byInt[ byStr[ sHash ]-1 ] ) return -1;
        name = (U64)byInt[ byStr[ sHash ]-1 ]->name & U64_HIBIT
             ? (char*)&(U64)byInt[ byStr[ sHash ]-1 ]->name
             : byInt[ byStr[ sHash ]-1 ]->name;
    }
    return byInt[ byStr[ sHash ]-1 ]->addr;
}

char *findByInt( BIMAP *bm, U64 i ) {
    register U32 mask = bm->size - 1;
    register U32 iHash = hash( (char*)&i, 8 ) & mask;
    register PAIR **byInt = bm->byInt;

    if( !byInt[ iHash ] ) return "$^&* NOT FOUND ON FIRST TRY *&^$";

    while( byInt[ iHash ]->addr != i ) {
        if( ! byInt[ iHash = ( iHash + 1 ) & mask ] ) return "$^&* NOT
+ FOUND AT ALL *&^$";
    }
    return (U64)( byInt[ iHash ]->name ) & U64_HIBIT ? (char*)&byInt[ 
+iHash ]->name : byInt[ iHash ]->name;
}

void DESTROY ( BIMAP *bm ) {
    U32 i;

    for( i=0; i < bm->size; ++i ) {
        if( bm->byInt[ i ] ) {
            if( !( (U64)bm->byInt[ i ]->name & ~U64_HIBIT ) ) free( bm
+->byInt[ i ]->name );
            free( bm->byInt[ i ] );
        }
    }
    free( bm->byInt );
    free( bm->byStr );
    free( bm );
}

END_C

sub CLONE { print "CLONE called [@_]"; }
sub CLONE_SKIP { print "CLONE_SKIP called [@_]"; 0 }

package main;
use threads;
use threads::shared;
use Time::HiRes qw[ time ];
use Data::Dump qw[ pp ];
use List::Util qw[ sum ];
use Devel::Peek;

$|++;
our $S //= 4;
our $F //= 0.9;
our $I //= 26**$S;

my $flag :shared = 0;

my $t = async {
    my $bm = BiMap::new( $I, $F );
    pp $bm;

    my $i = 1;
    $bm->add( $i++, $_ ) for 'a' x $S .. 'z' x $S;

#    printf "$_ : %I64x\n", $bm->findByStr( $_ ) for 'a'x$S .. 'z'x$S;

    $bm->dump( 1 );
    $flag = 1;
    Dump( $bm );
    return $bm;
};

sleep 1 until $flag;

my $bm = $t->join;
pp $bm; Dump( $bm );
$bm->dump( 1 );

#printf "$_ : %I64x\n", $bm->findByStr( $_ ) for 'a'x$S .. 'z'x$S;

[download]
With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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". I'm with torvalds on this
In the absence of evidence, opinion is indistinguishable from prejudice. Agile (and TDD) debunked

Replies are listed 'Best First'.
Re: [XS] Cloning is corrupting my privates.
by dave_the_m (Monsignor) on Jan 31, 2015 at 18:01 UTC
    Why don't you just set a watchpoint on one of the corrupted addresses and so see where and when its being changed?

    Dave.

[reply]

      According to perlmod:

      This provides a simple mechanism for making a module threadsafe; just add sub CLONE_SKIP { 1 } at the top of the class, and DESTROY() will now only be called once per object. Of course, if the child thread needs to make use of the objects, then a more sophisticated approach is needed.

      Are you aware of a "more sophisticated approach"?

      Ie. Is there some technique or trick to allow a module to discover which of its blessed refs have been cloned (and which not) so as to allow it to ignore/defer DESTROY requests until the last copy goes out of scope?

      Seems that if CLONE_SKIP was called each time a reference for a package it cloned -- and passed in a copy of the reference -- it would be possible for packages to do their own reference counting and thus avoid corrupting the internals of cloned objects -- by freeing memory associated with a cloned reference when one copy of it goes out of scope (when a thread ends) -- as I did.

      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      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". I'm with torvalds on this
      In the absence of evidence, opinion is indistinguishable from prejudice. Agile (and TDD) debunked
[reply]

      Because that would require I had a source-level debugger that works with Perl under windows; and I don't.

      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      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". I'm with torvalds on this
      In the absence of evidence, opinion is indistinguishable from prejudice. Agile (and TDD) debunked
[reply]
        Because that would require I had a source-level debugger that works with Perl under windows; and I don't
        You're writing XS code and can't run it under C debugger????!!!!

        Dave.

[reply]

Back to Seekers of Perl Wisdom