Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

BrowserUk's scratchpad

by BrowserUk (Pope)
on Jun 01, 2004 at 22:28 UTC ( #358718=scratchpad: print w/ replies, xml ) Need Help??

For MidLifeXis Thought you might appreciate seeing just how helpful your iterator was to me (note the comments):

Iter *next( Iter *this ) { while( this->top ) { // while( +@stack ) { U64 slot = this->states[ --this->top ]; + // my $index = pop @stack; NHash *nh = (NHash*)this->states[ --this->top ]; + // my $tree = pop @stack; if( ++slot >= nh->size ) { // end o +f slots continue; // return to prev +ious level } if( !nh->slots[ slot ].key ) { // p +ush back and move on this->states[ this->top++ ] = (U64)nh; +// push @stack, $tree, $index+1; this->states[ this->top++ ] = slot; } else if( isNested( nh->slots[ slot ].key ) ) { + // if( ref( $tree->[$index] ) ) { (Nested) this->states[ this->top++ ] = (U64)nh; + // push @stack, $tree, $index+1, $tree->[$index], 0; this->states[ this->top++ ] = slot; this->states[ this->top++ ] = (U64)nestedAddr( nh->slots[ +slot ].key ); this->states[ this->top++ ] = -1; } else { // } elsif( $in +dex < @$tree ) { populated slot this->states[ this->top++ ] = (U64)nh; +// push @stack, $tree, $index+1; this->states[ this->top++ ] = slot; return this; // return $tr +ee->[$index]; } } free( this ); // free stac +k return NULL; // return; }

Apart from the need to skip over empty slots, its an almost direct translation of Tye's adaption of your algorithm. Thanks!


For syphilis. Some performance figures from my BiMap module (what I started this for).

The upper, slower figure is using normal I::C (without PERL_NO_GET_CONTEXT because I have some functions that need to take SVs).

The lower, faster figure is with my PERL_GET_CONTEXT using __readgsquadword(). Each line times 2*no of items calls across the perl/XS interface.

Fetch by Addr & Fetch by Name took 22.830025 seconds for 11881376 item +s in a 16777216 sized BiMap Fetch by Addr & Fetch by Name took 18.515575 seconds for 11881376 item +s in a 16777216 sized BiMap Fetch by Addr & Fetch by Name took 48.118981 seconds for 23762752 item +s in a 33554432 sized BiMap Fetch by Addr & Fetch by Name took 34.267198 seconds for 23762752 item +s in a 33554432 sized BiMap

Some background to what I'm doing.

Perl calls TlsAlloc() to allocate an index to a Thread Local Storage slot -- this reserves a TLS in every new OS thread that is started -- and stores it in the process global (static) PL_thr_key.

Then, when a new thread is started, it allocates a Perl_Inptereter Struct and uses TlsSetValue( PL_thr_key, &my_perl ).

PERL_GET_CONTEXT does TlsGetValue( PL_thr_key ) each time it needs access to the Interp struct for the current thread.

What the __readgsquadword() intrinsic does is bypass the TlsGetValue() system call (slow) and read the value directly from it offset in the Thread Environment Block (TEB).

Because TlsGetValue() has to be very generic, it contains some error checking and thus can cause LastError to be set. So, the (windows) call to TlsGetValue has to be bracketed in temp = getLastError & SetLastError = temp; further slowing PERL_GET_CONTEXT.

Windows keeps a pointer(*) to the TEB in the GS segment register (X64) or FS segment register (X86). *Actually an index into a LDT entry which holds the pointer.

Thus, to retrieve the value stored in the TLS slot indexed by PL_thr_key, a single instruction is all that is needed:

mov rax, qword ptr gs:[ ( offsetof(TEB, TlsSlots) + PL_thr_key ) * + 8 ]

And this is what I'm currently doing with __readgsquadword().

The next step

However, the way I am doing it at the moment means that I have to recalculate this bit ( offsetof(TEB, TlsSlots) + PL_thr_key ) * 8 every time.

Which is silly, because it is an invarient. The difference between the threads is the base location of the TEB; and that is already dealt with for us by the segment register/LDT pairing.

So, the idea is to simply add another process global (say; PL_the_context ); or even replace the value/meaning of PL_thr_key; if it was done as a patch to Perl; with the calculated value as soon as the TLS index is obtained from the OS (via TlsAlloc) very early in the startup,

Then PERL_GET_CONTEXT would really become a single instruction with a pre-calculated global value as its only argument:

mov rax, qword ptr gs:[ PL_thr_context ];

OKay, that's not true, it needs another instruction to obtain that argument. So:

mov rax, PL_thr_context; mov rax, qword ptr gs:[ rax ];

Which may even prove to be more efficient (overall) than passing it around ala xTHX_; which involves an extra push/pop around every function call for the extra parameter.

However, in order to prove it -- outside of a standalone C simulation of the process where it shows great promise -- I need to either patch perl -- daunting -- or patch ExtUtils::ParseXS; which is where I'm digging around in at the moment.


You have to comment out the PRE_HEAD to get the WITH CONTEXT timings and comment out my 4 #lines to get the standard, with context timings.

This only works for 64-bit as is, but the 32-bit just uses __readfsdword() and different constants.

I tested it with AS 5.10 and SP 5.18

#! perl -slw use strict; use Inline C => Config => BUILD_NOISY => 1, PRE_HEAD => "#define PERL_ +NO_GET_CONTEXT\n"; use Inline C => <<'END_C', NAME => 'GetContext', CLEAN_AFTER_BUILD => +0, TYPEMAPS => 'GetContext.typemap'; typedef unsigned __int64 U64; #ifdef _MSC_VER # pragma push_macro( "_WIN32_WINNT" ) # undef _WIN32_WINNT # define _WIN32_WINNT 0x10000000 // defeat MS disallow of header file + for versions earlier than 0x500 # include <winternl.h> # pragma pop_macro( "_WIN32_WINNT" ) # ifndef PERL_NO_GET_CONTEXT # undef PERL_GET_CONTEXT # define TLSSLOTS (offsetof( TEB, TlsSlots ) / sizeof( void * )) # define TLSEXPANSIONSLOTS (offsetof( TEB, TlsExpansionSlots )) # ifdef _WIN64 # define PERL_GET_CONTEXT (void*)__readgsqword( ( TLSSLOTS + PL_thr +_key ) * sizeof( void * ) ) # else # define PERL_GET_CONTEXT (void*)__readfsqword( ( TLSSLOTS + PL_thr +_key ) * sizeof( void * ) ) # endif # endif #endif U64 Test( U64 in ) { return in * in; } SV *Test2( SV *in ) { void *my_perl = PERL_GET_CONTEXT; U64 u = SvUV( in ); return newSVuv( u * u ); } END_C use Time::HiRes qw[ time ]; my $start = time; Test( $_ ) for 1 .. 1e7; printf "Took %.9f seconds\n", time() -$start; $start = time; Test2( $_ ) for 1 .. 1e7; printf "Took %.9f seconds\n", time() -$start; __END__ 5.10 (AS) With Perl's PERL_GET_CONTEXT: C:\test>GetContext.pl Took 3.564446926 seconds Took 3.500513077 seconds 5.10 (AS) With mine: C:\test>GetContext.pl Took 2.199206114 seconds Took 2.743381977 seconds 5.10 (AS) With NO_GET_CONTEXT and dHTX; C:\test>GetContext.pl Took 1.888668060 seconds Took 2.536082983 seconds 5.10 (AS) With NO_GET_CONTEXT and my my_perl; C:\test>GetContext.pl Took 1.769526005 seconds Took 2.477406979 seconds 5.18 (SP) Perl's PERL_GET_CONTEXT Finished Build Compile Stage Took 3.880853891 seconds Took 3.469649076 seconds 5.18 (SP) My get context Finished Build Compile Stage Took 1.712888956 seconds Took 2.280426025 seconds 5.18 (SP) PRE_HEAD => "#define PERL_NO_GET_CONTEXT\n" GetContext.xs: In function 'Test2': GetContext.xs:19:13: error: 'my_perl' undeclared (first use in this fu +nction) GetContext.xs:19:13: note: each undeclared identifier is reported only + once for each function it appears in dmake: Error code 129, while making 'GetContext.o' 5.18 (SP) PRE_HEAD => "#define PERL_NO_GET_CONTEXT\n" ** Just Test( U6 +4 in ) ** Finished Build Compile Stage Took 1.720699072 seconds Undefined subroutine &main::Test2 called at C:\test\GetContext.pl18 li +ne 29.

Typemap

TYPEMAP const char * T_PV U64 T_UV U8 T_UV U8 * T_PV

Looks like you are right about the PERL_NO_GET_CONTEXT thing working for strictly C functions. I grabbed the preprocessed output from your scratchpad example and reformatted it to something approaching readable. There is plenty of stuff going on before and after the call to bar(); but no calls to Perl_get_context() :)

Also, squinting inside Inline.pm; it looks like it uses the full MD5 for detecting changes. It only reduces that to 4 for autonaming purposes. (Though it looks like that could be variable between 2 & 6 characters under some circumstances that I didn't quite understand.)

Next time I hit the mystery of changes not showing up I'll try to look at it more closely. Perhaps try generating the full md5s from before and after the change (assuming I can use my editor to undo and redo the disappeared change. And assuming I notice something is weird before making other changes :)

static void XS_main_bar(register PerlInterpreter* my_perl , CV* cv); static void XS_main_bar(register PerlInterpreter* my_perl , CV* cv) { extern int Perl___notused ; SV **sp = (*Perl_Istack_sp_ptr(my_perl)); I32 ax = (*(*Perl_Imarkstack_ptr_ptr(my_perl))--); register SV **mark = (*Perl_Istack_base_ptr(my_perl)) + ax++; I32 items = (I32)(sp - mark); if (items != 1) Perl_croak_xs_usage(my_perl, cv,"x"); { double x = (double)((((*Perl_Istack_base_ptr(my_perl))[ax + (0) +])->sv_flags & 0x00000200) ? ((XPVNV*) ((*Perl_Istack_base_ptr(my_perl))[ax + (0)])->sv_a +ny)->xnv_u.xnv_nv : Perl_sv_2nv(my_perl, (*Perl_Istack_base_ptr(my_perl))[ax + ( +0)])) ; double RETVAL; SV * const targ = (((*Perl_Iop_ptr(my_perl))->op_private & 32) ? ((*Perl_Icurpad_ptr(my_perl))[(*Perl_Iop_ptr(my_perl))->op_t +arg]) : Perl_sv_newmortal(my_perl)); RETVAL = bar(x); (sp = (*Perl_Istack_base_ptr(my_perl)) + ax - 1); do { Perl_sv_setnv(my_perl, targ,(NV)((double)RETVAL)); do { do { if (((targ)->sv_flags & 0x00400000)) Perl_mg_set(my_perl, targ); } while (0); (*++sp = (targ)); } while (0); } while (0); } do { const IV tmpXSoff = (1); (*Perl_Istack_sp_ptr(my_perl)) = (*Perl_Istack_base_ptr(my_per +l)) + ax + (tmpXSoff - 1); return; } while (0); } void boot_fred(register PerlInterpreter* my_perl , CV* cv); void boot_fred(register PerlInterpreter* my_perl , CV* cv) { extern int Perl___notused ; SV **sp = (*Perl_Istack_sp_ptr(my_perl)); I32 ax = (*(*Perl_Imarkstack_ptr_ptr(my_perl))--); register SV **mark = (*Perl_Istack_base_ptr(my_perl)) + ax++; I32 items = (I32)(sp - mark); #line 204 "fred.c" const char* file = "fred.c"; #line 206 "fred.c" ((void)cv); ((void)items); do { SV *_sv; const char *vn = 0, *module = ((((*Perl_Istack_base_ptr(my_perl))[ax + (0)])-> +sv_flags & (0x00000400)) == 0x00000400 ? ((const char*)(0 + ((*Perl_Istack_base_ptr(my_perl)) +[ax + (0)])->sv_u.svu_pv)) : Perl_sv_2pv_flags(my_perl, (*Perl_Istack_base_ptr(my +_perl))[ax + (0)],0,2|32)); if (items >= 2) _sv = (*Perl_Istack_base_ptr(my_perl))[ax + (1)]; else { _sv = Perl_get_sv(my_perl, Perl_form(my_perl, "%s: +:%s", module, vn = "XS_VERSION"),(0)); if (!_sv || !((((svtype)((_sv)->sv_flags & 0xff)) +== SVt_BIND) ? ((((_sv)->sv_u.svu_rv))->sv_flags & (0x00000 +100|0x00000200|0x00000400|0x00000800| 0x00001000|0x00002000|0x0000400 +0|0x00008000)) : ((_sv)->sv_flags & (0x00000100|0x00000200|0x +00000400|0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) ) _sv = Perl_get_sv(my_perl, Perl_form(my_perl, +"%s::%s", module, vn = "VERSION"),(0)); } if (_sv) { SV *xssv = Perl_newSVpv(my_perl, "0.00", 0); xssv = Perl_new_version(my_perl, xssv); if ( !Perl_sv_derived_from(my_perl, _sv,"version") + ) _sv = Perl_new_version(my_perl, _sv); if ( Perl_vcmp(my_perl, _sv,xssv) ) Perl_croak(my_perl, "%s object version %""-p"" + does not match %s%s%s%s %""-p", module, ((void*)(Perl_vstringify(my_perl, xssv))), + vn ? "$" : "", vn ? module : "", vn ? ":: +" : "", vn ? vn : "bootstrap parameter", ((void*)(Perl +_vstringify(my_perl, _sv))) ); } } while (0); Perl_newXS(my_perl, "main::bar",XS_main_bar,file); if ((*Perl_Iunitcheckav_ptr(my_perl))) Perl_call_list(my_perl, (*Perl_Iscopestack_ix_ptr(my_perl)),(*P +erl_Iunitcheckav_ptr(my_perl))); #line 219 "fred.c" do { ((*Perl_Istack_base_ptr(my_perl))[ax + (0)] = &(*Perl_Isv_yes +_ptr(my_perl)) ); do { const IV tmpXSoff = (1); (*Perl_Istack_sp_ptr(my_perl)) = +(*Perl_Istack_base_ptr(my_perl)) + ax + (tmpXSoff - 1); return; } while (0); } while (0); }


PWIW: Here is the code. Run it (BiMap.pl -S=1), and the output shows the problem, though it wll certainly need some explanation:

#! 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 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 ); } 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, +addr, 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; //TAG; if( !byStr[ sHash ] ) return -1; //TAG; name = (U64)byInt[ byStr[ sHash ]-1 ]->name & U64_HIBIT ? (char*)&(U64)byInt[ byStr[ sHash ]-1 ]->name : byInt[ byStr[ sHash ]-1 ]->name; //TAG; 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; } //TAG; 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; } END_C 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; our $D //= 0; my $flag :shared = 0; sub mem{ `tasklist /nh /fi "PID eq $$"` =~ m[(\S+ K)$] } my $t = async { my $bm = BiMap::new( $I, $F ); pp $bm; my %counts; my $i = 1; if( $D ) { ++$counts{ $bm->add( $i++, $_ ) } for 'a' x $S .. 'z' x $S; } else { $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 ); <STDIN>; $bm->dump( 1 );

The typemap:

TYPEMAP const char * T_PV BIMAP * O_OBJECT U64 T_UV INPUT O_OBJECT if( sv_isobject($arg) && ( SvTYPE( SvRV($arg) ) == SVt_PVMG ) ) $var = INT2PTR( $type, SvIV( (SV*)SvRV( $arg ) ) ); else{ warn( \"${Package}::$func_name() -- $var is not a blessed +SV reference\" ); XSRETURN_UNDEF; } OUTPUT # The Perl object is blessed into 'CLASS', which should be a # char* having the name of the package for the blessing. O_OBJECT sv_setref_pv( $arg, (char *)CLASS, (void*)$var );

Basically, contrast the outputs from Devel::Peek::Dump( $bm ) & $bm->dump(1) produce within the thread; and the same produce after $bm has been returned to the main thread. Note the corruption in the first 4 quad words of the byInt array.


For syphilis: I did try just setting CCFLAGS to what I want: eg:
use Inline C => Config => BUILD_NOISY => 1, CCFLAGS => q[-c -I"C:/tes +t" -DDEBUG=0 -W3 /Ge /RTC1 /RTCc /RTCs /RTCu /Zi -DWIN32 -D_CONSOLE - +DNO_STRICT -DHAVE_DES_FCRYPT -DWIN64 -DUSE_SITECUSTOMIZE -DPRIVLIB_LA +ST_IN_INC -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -D +PERL_MSVCRT_READFIX -nologo "-IC:\Perl64\lib\CORE"];

But by the time the build runs, something somewhere has tacked on a few more (conflicting) options:

Starting "make" Stage Microsoft (R) Program Maintenance Utility Version 9.00.21022.08 Copyright (C) Microsoft Corporation. All rights reserved. C:\Perl64\bin\perl.exe C:\perl64\site\lib\ExtUtils\xsubpp -ty +pemap "C:\Perl64\lib\ExtUtils\typemap" -typemap "C:\test\SparseBitVec +tor.typemap" SparseBitVector.xs > SparseBitVector.xsc && C:\Perl64\b +in\perl.exe -MExtUtils::Command -e mv -- SparseBitVector.xsc SparseBi +tVector.c cl -c -I"C:/test" -c -I"C:/test" -DDEBUG=0 -W3 /Ge /RTC1 /R +TCc /RTCs /RTCu /Zi -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT +-DWIN64 -DUSE_SITECUSTOMIZE -DPRIVLIB_LAST_IN_INC -DPERL_IMPLICIT_CON +TEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READFIX -nologo +"-IC:\Perl64\lib\CORE" -MD -Zi -Ox -GL -fp:precise -DVERSION=\"0.0 +0\" -DXS_VERSION=\"0.00\" "-IC:\Perl64\lib\CORE" SparseBitVector. +c cl : Command line warning D9035 : option 'Ge' has been deprecated and +will be removed in a future release cl : Command line error D8016 : '/RTC1' and '/Ox' command-line options + are incompatible NMAKE : fatal error U1077: '"C:\Program Files (x86)\Microsoft Visual S +tudio 9.0\VC\Bin\amd64\cl.EXE"' : return code '0x2' Stop. A problem was encountered while attempting to compile and install your + Inline

I upgraded I::C and all its dependancies (except Win32::IPC where Module:NeverBuild fucked me in the arse; but I don't think that will affect anything).

Something, somewhere insists on adding these -MD -Zi -Ox -GL -fp:precise    -DVERSION=\"0.00\"  -DXS_VERSION=\"0.00\"  "-IC:\Perl64\lib\CORE" to whatever I specify, and that causes the conflict.

Thoughts?


For erix

#! perl -slw use strict; our $N //= 10e3; open O, '>', 'clusters.dat' or die $!; my( $n, %uniq ) = 0; while( $n < $N ) { my $fac = ('A'..'Z')[ rand 26 ]; my $seq = 'seq'.int(rand 25); my $pos = int( rand 10000 ); next if exists $uniq{ join $;, $fac, $seq, $pos }; undef $uniq{ join $;, $fac, $seq, $pos }; print O join ' ', $fac, $seq, $pos; ++$n; } close O; open O, '>', 'queries.dat' or die $!; for my $a ( 'A' .. 'Z' ){ for my $b ( 'A' .. 'Z' ){ for my $c ( 'A' .. 'Z' ){ print O join ' ', $a,$b,$c; } } } close O; __END__ copy clusters from 'clusters.dat' delimiter ' '; copy queries from 'queries.dat' delimiter ' ';

Can you suggest a better formulation of the following query? Or what indexes might be used to trim the extreme time and memory usage?

Table "public.clusters" Column | Type | Modifiers ----------+---------------+----------- factor | character(1) | not null sequence | character(10) | not null position | integer | not null Indexes: "clusters_pkey" PRIMARY KEY, btree (sequence, factor, "position") test=# \d queries Table "public.queries" Column | Type | Modifiers --------+--------------+----------- first | character(1) | second | character(1) | third | character(1) | test=# select * from clusters limit 10; factor | sequence | position --------+------------+---------- I | seq23 | 6801 K | seq17 | 6247 Q | seq0 | 8514 Z | seq12 | 5542 Q | seq9 | 6334 Q | seq13 | 5472 K | seq18 | 6167 F | seq20 | 9064 F | seq2 | 4083 U | seq7 | 340 (10 rows) test=# select count(*) from clusters; count ------- 10001 (1 row) test=# select * from queries limit 10; first | second | third -------+--------+------- A | A | A A | A | B A | A | C A | A | D A | A | E A | A | F A | A | G A | A | H A | A | I A | A | J (10 rows) test=# select count(*) from queries; count ------- 17576 (1 row) test=# explain select a.*, b.*,c.* from clusters as a, clusters as b, clusters as c, (select * from queries) as d where a.sequence = b.sequence and a.sequence = b.sequence and a.factor = d.first and b.factor = d.second and c.factor = d.third; QUERY PLAN ---------------------------------------------------------------------- +------------------------------------- Hash Join (cost=4767418.33..456638449.34 rows=40093902426 width=51) Hash Cond: (c.factor = queries.third) -> Seq Scan on clusters c (cost=0.00..164.01 rows=10001 width=17) -> Hash (cost=2650170.83..2650170.83 rows=104233720 width=36) -> Merge Join (cost=815926.44..2650170.83 rows=104233720 wi +dth=36) Merge Cond: ((queries.first = a.factor) AND (queries.se +cond = b.factor)) -> Sort (cost=1492.98..1536.92 rows=17576 width=6) Sort Key: queries.first, queries.second -> Seq Scan on queries (cost=0.00..253.76 rows= +17576 width=6) -> Materialize (cost=814433.46..834478.40 rows=400898 +9 width=34) -> Sort (cost=814433.46..824455.93 rows=4008989 + width=34) Sort Key: a.factor, b.factor -> Hash Join (cost=289.02..45880.96 rows= +4008989 width=34) Hash Cond: (a.sequence = b.sequence) -> Seq Scan on clusters a (cost=0.0 +0..164.01 rows=10001 width=17) -> Hash (cost=164.01..164.01 rows=1 +0001 width=17) -> Seq Scan on clusters b (co +st=0.00..164.01 rows=10001 width=17) (17 rows) test=#

For Limbic~Region.

Try this:

#! perl -slw use strict; use Win32::GuiTest qw[ FindWindowLike SetFocus SendKeys ];; system 1, 'notepad.exe'; my @w = FindWindowLike( undef, qr/Notepad/ );; sleep 1; SetFocus( $w[0] ); SendKeys( "%{SPACE}M{DOWN}{RIGHT}{DOWN}{RIGHT}{DOWN}{RIGHT}{DOWN}{RIGH +T}{DOWN}{RIGHT}{DOWN}{RIGHT}{ENTER}" );;

For Limbic~Region.

Regarding thought 1 (Only leverage cache if I used the same number of hits):

Any board A (that requires more than 1 move) is board A' + that move; where board A' is what remains of board A after that move.

Of course board A may can have more than 1 first move, so it may result in many A's for different first moves.

And it is common that several first moves on A can result in the same board A'.

But the (my; not yet conclusive) bottom line is that if you have already accessed board A'; then whatever statistics you have gathered for previously assessed boards (min.moves/max.moves/number of different solutions/etc.) can be combined with the data gathered so far for board A to produce As stats (for the (set of) first move(s) that took A -> A').

If you can store/retrieve those stats efficiently, then you can accumulate the stats in a hierarchal manner that means you build up a DB of previously accessed boards that will avoid having to fully access new boards.

That is to say, rather than storing the full stats/analysis for board A; you can store the set of valid first moves, plus a reference to the resultant A' for each of those first moves. And for each of the A's, they in turn store the set of their first moves; and references to their A'' resultants.

Whilst there are 5^30 possible boards; there are far, far less A' boards because for any given A board, many of the possible first moves result in the same A' board.

Take

10101 01010 10101 00000 01010 10101

This can be solved in two moves (no more nor less) many different ways:

[0, 6], [0, 8], [0, 21], [0, 23], [2, 6], [2, 8], [2, 21], [2, 23], [4, 6], [4, 8], [4, 21], [4, 23], [6, 0], [6, 2], [6, 4], [6, 10], [6, 12], [6, 14], [6, 25], [6, 27], [ +6, 29], [8, 0], [8, 2], [8, 4], [8, 10], [8, 12], [8, 14], [8, 25], [8, 27], [ +8, 29], [10, 6], [10, 8], [10, 21], [10, 23], [12, 6], [12, 8], [12, 21], [12, 23], [14, 6], [14, 8], [14, 21], [14, 23], [21, 0], [21, 2], [21, 4], [21, 10], [21, 12], [21, 14], [21, 25], [21 +, 27], [21, 29], [23, 0], [23, 2], [23, 4], [23, 10], [23, 12], [23, 14], [23, 25], [23 +, 27], [23, 29], [25, 6], [25, 8], [25, 21], [25, 23], [27, 6], [27, 8], [27, 21], [27, 23], [29, 6], [29, 8], [29, 21], [29, 23],

But, if you look carefully, there are only two possible A' boards:

00000 01010 00000 00000 01010 00000 10101 00000 10101 00000 00000 10101

Which means if the 13 possible first moves; 9 result in (point to) one sv_flags ; use Data:version, :Dump qw, A'; and 4 result in (point to) the other A'.

Which should mean that after some few (probably millions?) of assessments; you reach a point where even new board quickly resolves to its first moves + pointers to previously solved boards.

I haven't wrapped my brain around the math or the scale of the storage problem. But it does strike me that for many boards (that will be A's for more complex boards; you will know that they require too may moves and can simply store a marker indicating that; so preventing costly assessment of any boards more complex that lead to this A'.

With regard to thought 2: (disk storage):

There wouldn't be a need to hit the disk for every A'. It should be possible to store the knowledge that a given A' has already been assessed + a basic set of stats in memory; and only hit the disk if full stats are required.

As for how to store the stats -- memory and disk -- could be done very efficiently using something line LibSQLite.

That's as far as my thought train goes. As I said, you probably want to dismiss this unless I get back to you with something that works; And maybe even then as you seem to have working code that does what you need. But I thought I'd lay it out where my brain has been going for the last few days. :)


For perlbotics

Here's my version of flipbits32() and flipbits64() and the benchmark results:

typedef unsigned __int64 U64; typedef unsigned int U32; typedef unsigned char U8; void flipbits32( SV *sv ) { STRLEN len; char *p = SvPV( sv, len ); while( len > 3 ) *((U32*)p)++ = ~*((U32*)p), len -= 4; while( len > 0 ) *((U8 *)p)++ = ~*((U8 *)p), len -= 1; } void flipbits64( SV *sv ) { STRLEN len; char *p = SvPV( sv, len ); while( len > 7 ) *((U64*)p)++ = ~*((U64*)p), len -= 8; while( len > 0 ) *((U8 *)p)++ = ~*((U8 *)p), len -= 1; return; } C:\test>1046579 =N=2**30 Rate str translate C8bits C32bits C64bits str 527355/s -- -57% -68% -79% -84% translate 1231678/s 134% -- -25% -51% -63% C8bits 1644457/s 212% 34% -- -34% -50% C32bits 2494674/s 373% 103% 52% -- -24% C64bits 3287236/s 523% 167% 100% 32% -- C:\test>1046579 =N=2**20 Rate str translate C8bits C32bits C64bits str 505846/s -- -55% -70% -79% -85% translate 1121547/s 122% -- -34% -53% -66% C8bits 1708547/s 238% 52% -- -28% -48% C32bits 2370166/s 369% 111% 39% -- -27% C64bits 3264306/s 545% 191% 91% 38% --

For hdb:

Here's an example of a pattern I just found in another sample. Might help or be a complete red herring.

Here are two chunks of the sample, that match for a bit, and then diverge with no apparent pattern to the divergence:

1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2 4 3 2 3 1 2 3 1 3 3 2 1 2 3 1 3 2 1 2 1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2 7 2 3 1 5 1 3 3 2 3 3 1 5 1 2 1 6 6 2

But then I looked at the first divergence and noticed that the pattern after the divergence appeared to align but slipped a bit, and the two values at and after the divergence in the top row, summed to the single value in the bottom row:

1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2*4+3*2 3 1 2 3 1 3 3 2 1 2 3 1 3 2 1 2 1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2 7 2 3 1 5 1 3 3 2 3 3 1 5 1 2 1 6 6 2

And then the next two, and the next and the next ...:

1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2*4+3*2 3 1*2+3*1 3 3 2*1+byInt ); free( bm-addr; } char *findByInt( BIMAP *bm, U64 i ) { register U32 mask = bm- -DDEBUG=0 -W3 /Ge /RTC1 /RTCc /RTCs /RTCu +/Zi -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT -DWIN64 -DUSE_SI +TECUSTOMIZE -DPRIVLIB_LAST_IN_INC -DPERL_IMPLICIT_CONTEXT -DPERL_IMPL +ICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READFIX -nologo , $a,$b,$c; } } } close O; __END__ copy clusters from But, if you look carefully, there are only two poss +ible A2*3 1*3+2*1 2 1 2 1 2 3 1 3 2 1 2 3 3 1 3 2 1 3 2 3 4 2 1 2 1 + 2 7 2 3 1 5 1 3 3 2 3 3 1 5 1 2 1 6 6 2

And that continues until the sub-samples completely align and the next rep starts.

I haven't got a clue how to begin to write a program to look for things like that?


For CorionGetContext.pl Took 1.769526005 seconds Took 2.477406979 seconds 5.18 (SP) PerlbyInt ); free( bm-:

From what you said, this ought to display the symptoms that the take sub would produce non-matching pairs of linenumbers because one is closed over when the sub is instantiated and assigned to the symbol table and the other is provided at run time, but they do not. I always strictly matching pairs?

#! perl -slw use strict; use threads; sub take; sub gather(&$) { my( $code, $tag ) = @_; local *take = sub { print "$tag, $_[0]"; }; &async( $code )->detach; } gather{ sleep( 1 ), take( __LINE__ ) for 1 .. 1000; } __LINE__; gather{ sleep( 1 ), take( __LINE__ ) for 1 .. 1000; } __LINE__; gather{ sleep( 1 ), take( __LINE__ ) for 1 .. 1000; } __LINE__; gather{ sleep( 1 ), take( __LINE__ ) for 1 .. 1000; } __LINE__; sleep 1000; __END__ C:\test>t-take.pl 13, 13 14, 14 15, 15 16, 16 13, 13 14, 14 15, 15 16, 16 13, 13 14, 14 15, 15 16, 16 14, 14 13, 13 15, 15 16, 16 13, 13 14, 14 15, 15 16, 16 14, 14 13, 13 15, 15 16, 16 13, 13 14, 14 15, 15 16, 16 14, 14 13, 13 ...

For davido:

This works! That is, it allows users to use Some::Foo and then my $obj = Some::Foo->new;.

It's a little bit 'trick'; but not so much to concern anyone.

package Some::Foo; package Some; use strict; use Inline CPP => Config => BUILD_NOISY => 1; use Inline CPP => <<'END'; #include <iostream> using namespace std; class Foo { int data; public: Foo(); ~Foo(); int get() { return data; } void set(int a) { data = a; } }; Foo::Foo() { cout << "creating a Foo()" << endl; } Foo::~Foo() { cout << "deleting a Foo()" << endl; } END package Some::Foo; return 1 if caller; package main; my $foo = Some::Foo->new(); $foo->set( 1 ); print $foo->get();
For syphilis:
#include <stdio.h> int main( int argc, char **argv ) { unsigned __int64 u64 = 0xffffffff7fffffff; double d = *(double*)&u64; printf( "%f\n", d ); } C:\test>cl qnan.c Microsoft (R) C/C++ Optimizing Compiler Version 15.00.21022.08 for x64 Copyright (C) Microsoft Corporation. All rights reserved. qnan.c Microsoft (R) Incremental Linker Version 9.00.21022.08 Copyright (C) Microsoft Corporation. All rights reserved. /out:qnan.exe qnan.obj C:\test>qnan -1.#QNAN0

For syphilis:
c:\test>type bitvector.typemap U64 UV_T c:\test>type \perl64\lib\ExtUtils\typemap # basic C types int T_IV unsigned T_UV unsigned int T_UV long T_IV unsigned long T_UV short T_IV unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV unsigned char * T_PV const char * T_PV caddr_t T_PV wchar_t * T_PV wchar_t T_IV # bool_t is defined in <rpc/rpc.h> bool_t T_IV size_t T_UV ssize_t T_IV time_t T_NV unsigned long * T_OPAQUEPTR char ** T_PACKEDARRAY void * T_PTR Time_t * T_PV SV * T_SV SVREF T_SVREF AV * T_AVREF HV * T_HVREF CV * T_CVREF IV T_IV UV T_UV U64 t_UV NV T_NV I32 T_IV I16 T_IV I8 T_IV STRLEN T_UV U32 T_U_LONG U16 T_U_SHORT U8 T_UV Result T_U_CHAR Boolean T_BOOL float T_FLOAT double T_DOUBLE SysRet T_SYSRET SysRetLong T_SYSRET FILE * T_STDIO PerlIO * T_INOUT FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT OutputStream T_OUT bool T_BOOL ###################################################################### +####### INPUT T_SV $var = $arg T_SVREF if (SvROK($arg)) $var = (SV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a re, time() -$start; $start = time) ) _sv = Perl_new_version(my_perl, _sv); if ( Perl_vcmp(my_perl, _sv,xssv) ) Perl_croak(my_perl, mask; } while( bm-; Test2( $_ ) for 1 .. 1e7; printf used; } U32 size( BIMAP *bm ) { return bm-` =~ m; my $seq = 21, 10ference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_AVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) $var = (AV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not an array reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_HVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV) $var = (HV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a hash reference\", ${$ALIAS?\q= 2) _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-Psv = (*Perl_Istack_base_ptr(my_perl)), ((void*)(Perl_vstring +ify(my_perl, _sv))) ); } } while (0); Perl_newXS(my_perl, C:\Program Files (x86)\Microsoft Visual Studio + 9.0\VC\Bin\am,0,2|32)); if ( items d64\cl.EXEclusters.dat boards:[GvNAME(CvGV(cv))]:\qq[\"$pname\"] +}, \"$var\") T_CVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) $var = (CV*)SvRV($arg); else Perl_croak(aTHX_ \"%s: %s is not a code reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_SYSRET $var NOT IMPLEMENTED T_UV $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT $var = (int)SvIV($arg) T_ENUM $var = ($type)SvIV($arg) T_BOOL $var = (bool)SvTRUE($arg) T_U_INT $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG $var = (unsigned long)SvUV($arg) T_CHAR $var = (char)*SvPV_nolen($arg) T_U_CHAR $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV $var = ($type)SvNV($arg) T_DOUBLE $var = (double)SvNV($arg) T_PV $var = ($type)SvPV_nolen($arg) T_PTR $var = INT2PTR($type,SvIV($arg)) T_PTRREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REF_IV_REF if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type *, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REF_IV_PTR if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type, tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\", \"$ntype\") T_REFREF if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not a reference\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = *INT2PTR($type,tmp); } else Perl_croak(aTHX_ \"%s: %s is not of type %s\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\ i byInt"$pname\"]}, Pp) T_PTROBJ if (sv_derived_from($arg, \ \"$var\", \"$ntype\") T_OPAQUE $var = *($type *)SvPV_nolen($arg) T_OPAQUEPTR $var = ($type)SvPV_nolen($arg) T_PACKED $var = XS_unpack_$ntype($arg) T_PACKEDARRAY $var = XS_unpack_$ntype($arg) T_CALLBACK $var = make_perl_cb_$type($arg) T_ARRAY U32 ix_$var = $argoff; $var = $ntype(items -= $argoff); while (items--) { DO_ARRAY_ELEM; ix_$var++; } /* this is the number of elements in the array */ ix_$var -= $argoff T_STDIO $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) T_IN $var = IoIFP(sv_2io($arg)) T_INOUT $var = IoIFP(sv_2io($arg)) T_OUT $var = IoOFP(sv_2io($arg)) #############8, 2##################################################### +########### OUTPUT T_SV $arg = $var; T_SVREF $arg = newRV((SV*)$var); T_AVREF $arg = newRV((SV*)$var); T_HVREF $arg = newRV((SV*)$var); T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); T_UV sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else sv_setiv($arg, (IV)$var); } T_ENUM sv_setiv($arg, (IV)$var); T_BOOL $arg = boolSV($var); T_U_INT sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (NV)$var); T_DOUBLE sv_setnv($arg, (double)$var); T_PV sv_setpv((SV*)$arg, $var); T_PTR sv_setiv($arg, PTR2IV($var)); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); T_REF_IV_PTR sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)) +; T_REFREF NOT_IMPLEMENTED T_REFOBJ NOT IMPLEMENTED T_OPAQUE sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR sv_setpvn($arg, (char *)$var, sizeof(*$var)); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT sv_setpvn($arg, $var.chp(), $var.size()); T_CALLBACK sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY { U32 ix_$var; EXTEND(SP,size_$var); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } } T_STDIO { GV *gv = newGVgen("$Package"); PerlIO *fp = PerlIO_importFILE($var,0); if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package", +1))); else $arg = &PL_sv_undef; } T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package", +1))); else $arg = &PL_sv_undef; } T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package", +1))); else $arg = &PL_sv_undef; } T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package", +1))); else $arg = &PL_sv_undef; }
Sure looks (to me) like the typemap isn't being seen, despite that it is listed in the output from the build) (maybe I'm down-level on I::C? (it lists 0.49 in C.pm)):
/* * This file was generated automatically by ExtUtils::ParseXS version +2.22 from the * contents of bitvector.xs. Do not edit this file, edit bitvector.xs +instead. * * ANY CHANGES MADE HERE WILL BE LOST! * */ #line 1 "bitvector.xs" #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" typedef unsigned __int64 U64; char *newxz( U64 bytes ) { char *p; Newxz( p, bytes, char ); if( !p ) croak( "Couldn't allocate %I64u bytes\n", bytes ); return p; } SV* new( const char *classname, SV *bits ) { U64 bytes = ( SvUV( bits )+7 ) / 8; unsigned char *vector = newxz( bytes ); SV *obj = newSV_type( SVt_PV ); SV *obj_ref = newRV_noinc( obj ); SvPOK_only( obj ); SvPV_set( obj, vector ); SvCUR_set( obj, bytes-1 ); SvLEN_set( obj, bytes ); sv_bless( obj_ref, gv_stashpv( classname, GV_ADD) ); return obj_ref; } U64 setbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; //return _bittestandset64( vec+quad, bit ); return vec[ quad ] |= 1ULL << bit; } U64 tstbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; //return _bittest6 , 4( vec+quad, bit ); return ( vec[ quad ] & ( 1ULL << bit ) ) ? 1 : 0; } U64 clrbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; //return _bittestandreset64( vec+quad, bit ); return vec[ quad ] &= ~( 1ULL << bit ); } _inline int _popcnt( U64 x ) { x -=( x >> 1 ) & 0x5555555555555555ULL; x = ( x & 0x3333333333333333Ul ) + ( ( x >> 2 ) & 0x33333333333333 +33ULL ); x = ( x + (x >> 4)) & 0x0f0f0f0f0f0f0f0fULL; return ( :\qqx * 0x0101010101010101ULL ) >> 56; } U64 cntbit( SV *self ) { STRLEN l = 0; U64 *vec = (U64*)SvPV( SvRV( self ), l ); U64 cnt = 0ULL; int i; l /= 8; ++l; for( i = 0; i <l; ++i ) { cnt += _popcnt( vec[ i ] ); } return cnt; } #line 89 "bitvector.c" #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, para +ms); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here +. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), par +ams); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #ifdef PERL_IMPLICIT_CONTEXT #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) #else #define croak_xs_usage S_croak_xs_usage #endif #endif /* NOTE: the prototype of newXSproto() is different in versions of per +ls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(nam +e, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)new +XS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ #line 141 "bitvector.c" XS(XS_main_new); /* prototype to pass -Wmissing-prototypes */ XS(XS_main_new) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif if (items != 2) croak_xs_usage(cv, "classname, bits"); { const char * classname = (const char *)SvPV_nolen(ST(0)); SV * bits = ST(1); SV * RETVAL; RETVAL = new(classname, bits); ST(0) = RETVAL; sv_2mortal(ST(0)); } XSRETURN(1); } #ifdef __cplusplus extern "C" #endif XS(boot_bitvector); /* prototype to pass -Wmissing-prototypes */ XS(boot_bitvector) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif #if (PERL_REVISION == 5 && PERL_VERSION < 9) char* file = __FILE__; #else const char* file = __FILE__; #endif PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XS_VERSION_BOOTCHECK ; newXS("main::new", XS_main_new, file); #if (PERL_REVISION == 5 && PERL_VERSION >= 9) if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); #endif XSRETURN_YES; }

For syphilis: The output from mine then yours (with '+' removed):
C:\test>IDrand62xN 2**20 main=SCALAR(0x3e8c608) : 131071 1048576 0 C:\test>bitvec2 2**20 main=SCALAR(0x4062568) : 131071 1048576 0

For syphilis: Using this typemap:
U64 UV_T

Compiling this goes clean, but the methods aren't visible (bound?) at runtime? Switch the method return types to UV and they are. (The hope is eventually use the typedef to hide platform/architecture differences.).

The typemap (bitvector.typemap) is being seen, but ... (sorry!) "doesn't work!". Build log at the bottom. :

#! perl -slw use strict; use Config; use Inline C => Config => BUILD_NOISY => 1, CCFLAGS => $Config{ccflags +}." -DDEBUG=1", TYPEMAPS => './bitvector.typemap'; use Inline C => <<'END_C', NAME => 'bitvector', CLEAN_AFTER_BUILD => +0; typedef unsigned __int64 U64; char *newxz( U64 bytes ) { char *p; Newxz( p, bytes, char ); if( !p ) croak( "Couldn't allocate %I64u bytes\n", bytes ); return p; } SV* new( const char *classname, SV *bits ) { U64 bytes = ( SvUV( bits )+7 ) / 8; unsigned char *vector = newxz( bytes ); SV *obj = newSV_type( SVt_PV ); SV *obj_ref = newRV_noinc( obj ); SvPOK_only( obj ); SvPV_set( obj, vector ); SvCUR_set( obj, bytes-1 ); SvLEN_set( obj, bytes ); sv_bless( obj_ref, gv_stashpv( classname, GV_ADD) ); return obj_ref; } U64 setbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; return _bittestandset64( vec+quad, bit ); //vec[ quad ] |= 1ULL << + bit; } U64 tstbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; return _bittest64( vec+quad, bit ); //( vec[ quad ] & ( 1ULL << bi +t ) ) ? 1 : 0; } U64 clrbit( SV *self, SV *offset ) { U64 *vec = (U64*)SvPVX( SvRV( self ) ); U64 bit = SvUV( offset ) & 0x000000000000003fULL; U64 quad = SvUV( offset ) >> 6; return _bittestandreset64( vec+quad, bit ); //vec[ quad ] &= ~( 1U +LL << bit ); } _inline int _popcnt( U64 x ) { x -=( x >> 1 ) & 0x5555555555555555ULL; x = ( x & 0x3333333333333333Ul ) + ( ( x >> 2 ) & 0x33333333333333 +33ULL ); x = ( x + (x >> 4)) & 0x0f0f0f0f0f0f0f0fULL; return ( x * 0x0101010101010101 ) >> 56; } U64 cntbit( SV *self ) { STRLEN l = 0; U64 *vec = (U64*)SvPV( SvRV( self ), l ); U64 cnt = 0ULL; int i; l /= 8; ++l; for( i = 0; i <l; ++i ) { cnt += _popcnt( vec[ i ] ); } return cnt; } END_C use Devel::Peek; my $size = eval $ARGV[ 0 ]; my $v = new( 'main', $size ); print $v, ' : ', length $$v; for my $bit ( 0 .. $size - 1 ) { $v->tstbit( $bit ) and warn "Bit $bit unexpectely set"; $v->setbit( $bit ); $v->tstbit( $bit ) or warn "Bit $bit unexpectely unset";; } print $v->cntbit(); for my $bit ( 0 .. $size - 1 ) { $v->clrbit( $bit ); $v->tstbit( $bit ) and warn "Bit $bit unexpectely set";; } print $v->cntbit();

Build and run:

C:\test>IDrand62xN 2**31 validate Stage get_maps Stage Writing Makefile for bitvector Microsoft (R) Program Maintenance Utility Version 9.00.21022.08 Copyright (C) Microsoft Corporation. All , I havenrights reserved. C:\Perl64\bin\perl.exe C:\Perl64\lib\ExtUtils\xsubpp -typemap + "C:\Perl64\lib\ExtUtils\typemap" -typemap "C:\test\bitvector.typemap +" bitvector.xs > bitvector.xsc && C:\Perl64\bin\perl.exe -MExtUtils: +:Command -e "mv" -- bitvector.xsc bitvector.c cl -c -I"C:/test" -nologo -GF -W3 -MD -Zi -DNDEBUG -Ox -GL - +Wp64 -fp:precise -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT -DW +IN64 -DCONSERVATIVE -DUSE_SITECUSTOMIZE -DPRIVLIB_LAST_IN_INC -DPERL_ +IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READF +IX -DDEBUG=1 -MD -Zi -DNDEBUG -Ox -GL -Wp64 -fp:precise -DVERSION= +\"0.00\" -DXS_VERSION=\"0.00 int main( int argc, char **argv ) { unsigned __int64 u64 = 0xffffffff7fffffff; double d = *(double*)t think that it should be possible to get her +e. */ Perl_croak(aTHX_ \" "-IC:\Perl64\lib\CORE" bitvector.c cl : Command line warning D9035 : option 'Wp64' has been deprecated an +d will be removed in a future release cl : Command line warning D9035 : option 'Wp64' has been deprecated an +d will be removed in a future release bitvector.c Running Mkbootstrap for bitvector () C:\Perl64\bin\perl.exe -MExtUtils::Command -e "chmod" -- 644 b +itvector.bs C:\Perl64\bin\perl.exe -MExtUtils::Mksymlists -e "Mksymlists( +'NAME'=>\"bitvector\", 'DLBASE' => 'bitvector', 'DL_FUNCS' => { }, ' +FUNCLIST' => [], 'IMPORTS' => { }, 'DL_VARS' => []);" link -out:blib\arch\auto\bitvector\bitvector.dll -dll -nologo +-nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"C:\Perl64\lib\CORE +" -machine:AMD64 bitvector.obj C:\Perl64\lib\CORE\perl510.lib oldn +ames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib + advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.l +ib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib +comctl32.lib bufferoverflowU.lib msvcrt.lib -def:bitvector.def Creating library blib\arch\auto\bitvector\bitvector.lib and object +blib\arch\auto\bitvector\bitvector.exp Generating code Finished generating code if exist blib\arch\auto\bitvector\bitvector.dll.manifest mt -n +ologo -manifest blib\arch\auto\bitvector\bitvector.dll.manifest -outp +utresource:blib\arch\auto\bitvector\bitvector.dll;2 if exist blib\arch\auto\bitvector\bitvector.dll.manifest del b +lib\arch\auto\bitvector\bitvector.dll.manifest C:\Perl64\bin\perl.exe -MExtUtils::Command -e "chmod" -- 755 b +lib\arch\auto\bitvector\bitvector.dll C:\Perl64\bin\perl.exe -MExtUtils::Command -e "cp" -- bitvecto +r.bs blib\arch\auto\bitvector\bitvector.bs C:\Perl64\bin\perl.exe -MExtUtils::Command -e "chmod" -- 644 b +lib\arch\auto\bitvector\bitvector.bs Microsoft (R) Program Maintenance Utility Version 9.00.21022.08 Copyright (C) Microsoft Corporation. All rights reserved. Files found in blib\arch: installing files in blib\lib into architectu +re dependent library tree Installing C:\test\_Inline\lib\auto\bitvector\bitvector.dll Installing C:\test\_Inline\lib\auto\bitvector\bitvector.exp Installing C:\test\_Inline\lib\auto\bitvector\bitvector.lib Installing C:\test\_Inline\lib\auto\bitvector\bitvector.pdb main=SCALAR(0x40ff688) : 268435455 Can't locate aut, doesno/main/tstbit.al in @INC (@INC contains: C:\tes +t\_Inline\lib c:/Perl64/site/lib c:/Perl64/lib .) at C:\test\IDrand62 +xN.pl line 84

For Syphilis

The (slightly tweaked) code:

#! perl -slw use strict; use Inline C => Config => BUILD_NOISY => 1; use Inline C => <<'END_C', NAME => 'JobObject', CLEAN_AFTER_BUILD => +0; #include <windows.h> #ifndef JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE #define JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE 0x2000 #endif int createJobObject( char *name ) { HANDLE job; JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli = { 0, }; jeli.B6, 2$var\asicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_ +KILL_ON_JO$Packagel; ++i ) { cnt += _popcnt( vecB_CLOSE; job = (int)CreateJobObjectA( NULL, name ); SetInformationJobObject( job, 9, &jeli, sizeof(jeli) ); return job; } int assignProcessToJobObject( int job, int pid ) { HANDLE hProc = OpenProcess( PROCESS_SET_QUOTA |PROCESS_TERMINATE, +0, pid ); return (int)AssignProcessToJobObject( job, hProc ); } int closeHandle( int handle ) { return (int)CloseHandle( (HANDLE)handle ); } END_C #use Win32::JobAdd; my $job = createJobObject( 'fred' ); print $job; my $pid = open IN, q[\perl64\bin\perl.exe -E"system 1, 'calc.exe'; sys +tem 1, 'notepad.exe'; sleep 100" |] or die $^E; print assignProcessToJobObject( $job, $pid ); sleep 10; print closeHandle( $job ); #kill 21, $pid; __END__

And the build:<code> C:\test>JobObj.pl validate Shttp://www.sqlite.org/c3ref/intro.html|LibSQLitetage Starting Build Preprocess Stage get_maps Stage Finished Build Preprocess Stage Starting Build Parse Stage Finished Build Parse Stage Starting Build Glue 1 Stage Finished Build Glue 1 Stage Starting Build Glue 2 Stage Finished Build Glue 2 Stage Starting Build Glue 3 Stage Finished Build Glue 3 Stage Starting Build Compile Stage Starting "perl Makefile.PL" Stage Writing Makefile for JobObject Finished "perl Makefile.PL" Stage Starting "make" Stage Microsoft (R) Program Maintenance Utility Version 9.00.21022.08 Copyright (C) Microsoft Corporation. All rights reserved. C:\Perl64\bin\perl.exe C:\Perl64\lib\ExtUtils\xsubpp -typemap "C:\Perl64\lib\ExtUtils\typemap" JobObject.xs > JobObject.xsc && C:\Perl64\bin\perl.exe -MExtUtils::Command -e "mv" -- JobObject.xsc JobObject.c cl -c -I"C:/test" -nologo -GF -W3 -MD -Zi -DNDEBUG -Ox -GL -Wp64 -fp:precise -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT -DWIN64 -DCONSERVATIVE -DUSE_SITECUSTOMIZE -DPRIVLIB_LAST_IN_INC -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READFIX -MD -Zi -DNDEBUG -Ox -GL -Wp64 -fp:precise -DVERSION=\"0.00\" -DXS_VERSION=\"0.00\" "-IC:\Perl64\lib\CORE" JobObject.c cl : Command line warning D9035 : option 'Wp64' has been deprecated and will be removed in a future release cl : Command line warning D9035 : option 'Wp64' has been deprecated and will be removed in a future release JobObject.c JobObject.xs(16) : warning C4013: 'CreateJobObjectA' undefined; assuming extern returning int JobObject.xs(16) : warning C4047: '=' : 'HANDLE' differs in levels of indirection from 'int' JobObject.xs(17) : warning C4013: 'SetInformationJobObject' undefined; assuming extern returning int JobObject.xs(18) : warning C4047: 'return' : 'int' differs in levels of indirection from 'HANDLE' JobObject.xs(23) : warning C4013: 'AssignProcessToJobObject' undefined; assuming extern returning int JobObject.xs(27) : warning C4312: 'type cast' : conversion from 'int' to 'HANDLE' of greater size Running Mkbootstrap for JobObject () C:\Perl64\bin\perl.exe -MExtUtils::Command -e "chmod" -- 644 JobObject.bs C:\Perl64\bin\perl.exe -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>\"JobObject\", 'DLBASE' => 'JobObject', 'DL_FUNCS' => { }, 'FUNCLIST' => [], 'IMPORTS' => { }, 'DL_VARS' => []);" link -out:blib\arch\auto\JobObject\JobObject.dll -dll -nologo -nodefaultlib -debug -opt:ref,icf -ltcg -libpath:"C:\Perl64\lib\CORE" -machine:AMD64 JobObject.obj C:\Perl64\lib\CORE\perl510.lib oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib a Config =dvapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib comctl32.lib bufferoverflowU.lib msvcrt.lib -def:JobObject.def Creating library blib\arch\auto\JobObject\JobObject.lib and object blib\arch\auto\JobObject\JobObject.exp Generating code Finish ); print $job; my $pid = open IN, qed generating code if exist blib\arch\auto\JobObject\JobObject.dll.manifest mt -nologo -manifest blib\arch\auto\JobObject\JobObject.dll.manifest -outputresource:blib\arch\auto\JobObject\JobObject.dll;2 if exist blib\arch\autPL_sv_undef; } T_IN { GV *gv = newGVgen( #include has been deprecated and will be removed in a future release cl : Command line warning D9035 : option XSUB.h${ntype}\ 56; } U64 cntbit( SV *self ) { STRLEN l = 0; U64 *vec = (U64*)SvPV( SvRV( self ), l ); U64 cnt = 0ULL; int i; l /= 8; ++l; for( i = 0; i GvNAME(CvGV(cv))\perl64\bin\perl.exe -E

Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (3)
As of 2015-02-28 14:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    On my keyboard, Caps lock is:








    Results (462 votes), past polls