Here it is, another (but simple) external library module.
I combine what Perl is good at and what assembly language
is good at to make a zappy, concise module.
1) does Win32 API __stdcall calling convention.
2) does UNIX/Win32 __cdecl calling convention.
3) does callbacks - qsort test, self callback test.
4) Passes or returns doubles/quads for unsupported 32 bit Perls.
5) Gives the user finer control on argument
packing order less than 4 bytes - shorts and chars - a
likely source of compiler bugs and poor or wrong vendor documentation.
6) Saves arguments passed after the call !!!! - some
calls return values back to the stack overwritng the
original arguments(ie: FORTRAN's INTENTION IN,OUT).
In the module, Perl constructs the machine language string for your call, during the Declare phase , then edits your machine language with your parameters just before the call.
Because of its low level, this is an experimental module, but its for the user who wants to get down to the nuts and bolts of what he/she is doing, usually skipping the compile stage.
If I post this on CPAN, I should get this running on Linux and possibly FreeBSD . Of course it would be the polished version.
This is for an Intel type CPU, but I welcome versions for other CPU's .
The code below is two files Win32tests.pl and AsmUtil_IA32.pm . My output is after __END__ below:
# Win32tests.pl
use AsmUtil_IA32;
$a = "Just Another C&ASM Hacker\n";
$b = "Perl ";
# ---- CopyMemory - the 30 lb. sledge hammer version of Perl's subst
+r() or unpack("p??",...)
# ---- remember peek & poke ?, its back as CopyMemory:
$CopyMemory = DeclareXSub( "_CopyMemory" , "C:\\WINDOWS\\system32\\ker
+nel32.dll!RtlMoveMemory", "i,i,i","","s");
$QPF = DeclareXSub( "_QPF" , "C:\\WINDOWS\\system32\\kernel32.dll!Quer
+yPerformanceFrequency", "i","i","s");
$QPC = DeclareXSub( "_QPC" , "C:\\WINDOWS\\system32\\kernel32.dll!Quer
+yPerformanceCounter", "i","i","s");
$qsort = DeclareXSub( "_qsort" , "C:\\WINDOWS\\system32\\msvcrt.dll!qs
+ort", "i,i,i,i","","c");
$ClibAtan = DeclareXSub( "_atan" , "C:\\WINDOWS\\system32\\msvcrt.dll!
+atan", "d","d","c");
$atoi64 = DeclareXSub( "_atoi64" , "C:\\WINDOWS\\system32\\msvcrt.dll!
+_atoi64", "i","q","c");
$i64toa = DeclareXSub( "_i64toa" , "C:\\WINDOWS\\system32\\msvcrt.dll!
+_i64toa", "q,i,i","i","c");
print ">>> Win32 API __stdcall tests <<<\n";
print "Before CopyMemory: ",$a;
$CopyMemory->{Call}(SVPtr($a)+13,SVPtr($b),5);
print "After CopyMemory: ",$a;
my $Quad = "\x00" x 8;
$qstr = "\x00" x 80;
$QPF->{Call}(SVPtr($Quad));
$QPFreturn = unpack("i",$QPF->{RetEAX});
if($QPFreturn){
$i64toa->{Call}($Quad,SVPtr($qstr),10);
print "_i64toa tests:\nticks/second: ",$qstr ,"\n";
for($i=0;$i<50000;++$i){
$QPC->{Call}(SVPtr($Quad));
$qstr = "\x00" x 80;
$i64toa->{Call}($Quad,SVPtr($qstr),10);
print "ticks: ",$qstr ,"\r";
}
print "\n";
}
print ">>> Microsoft Visual C Run Time msvcrt.dll(and msvcr??.dll) __c
+decl tests <<<\n";
$qstr = "72623859790382856"; # 0n72623859790382856 == 0x01020304050607
+08
$atoi64->{Call}(SVPtr($qstr));
printf "_atoi64 call: Quad(longlong) return test (EDX:EAX)=> %08X%08X\
+n", unpack("L",$atoi64->{RetEDX}),unpack("L",$atoi64->{RetEAX});
printf("Perl emulated \(un\)pack\(Q,...\) test: %s\n",SVQuad(CQuad("72
+623859790382856")));
$ClibAtan->{Call}(1.00000);
printf("FPU doubles test: 4*atan(1) = Pi = %18.16f\n",4*unpack("d",$Cl
+ibAtan->{Ret64bit}));
print "---C library qsort calls back to Perl test:\n";
$qcompare = DeclareCallback(__PACKAGE__."::qcompare","p2,p2","","c");
+#p2==(short *)
$iArray = pack("s13",399,99,3,1,234,546,789,34,124,894,521,67,754);
print "Before sort:" ,join(",",unpack("s13",$iArray)),"\n";
$qsort->{Call}(SVPtr($iArray),13, 2, $qcompare->{Ptr});
print "After sort:" ,join(",",unpack("s13",$iArray)),"\n";
sub qcompare(){
# ----- reconstruct @_ without XS -----
my $Cstack = substr(unpack("P16",$qcompare->{stackPtr}),8); # copy s
+tack in binary form
$_[0] = substr($Cstack,0,4); # $_[0] == void*
$_[1] = substr($Cstack,4,4);
$e1=unpack("s",unpack("P2",$_[0])); # $e1 = (Perl scalar) *(short *)
+$_[0]
$e2=unpack("s",unpack("P2",$_[1]));
cbreturn({cbref => $qcompare ,ret32 => $e1-$e2,}); # return result ba
+ck to C qsort routine
}
$arg1="Assembly";
$arg2="Callback",
$arg3="To";
$arg4="Perl";
$ptrptrargs = pack("PPPPI",$arg1,$arg2,$arg3,$arg4,0);
$cbname = __PACKAGE__ . "::". "asm2perl";
$cb_asm2perl = "\x90" .
"\x68" . pack("I",$call_argv_ref) .# push [Perl_c
+all_argv()] PUSH POINTERS TO PERL API FUNCTIONS
"\x68" . pack("I",$get_context_ref) .# push [Perl_g
+et_context()]
"\x68" . pack("I",$Tstack_sp_ptr_ref) .# push [Perl_T
+stack_sp_ptr()]
"\x55" .# push ebp
"\x89\xE5" .# mov ebp,esp
+ use ebp to access XS
# ----------------- dSP; MACRO starts -------------------
"\xff\x55\x08" .# call dword p
+tr [ebp+8] => call Perl_get_context()
"\x50" .# push eax
"\xff\x55\x04" .# call dword p
+tr [ebp+4] => call Perl_Tstack_sp_ptr()
"\x59" .# pop ecx
"\x8B\x00" .# mov eax,dwo
+rd ptr [eax]
"\x89\x45\xec" .# mov dword p
+tr [sp],eax => local copy of SP
# -------------- perl_call_argv("callbackname",G_DISCARD,char **args)
+-----
"\x68" . pack("P",$ptrptrargs) .# push char **args
"\x68\x02\x00\x00\x00" .# push G_DISCARD
"\x68" . pack("p",$cbname) .# push ptr to name
+ of perl subroutine
"\xff\x55\x08" .# call Perl_get_co
+ntext()
"\x50" .# push eax
"\xff\x55\x0c" .# call perl_call_a
+rgv: call dword ptr [ebp+0x0c]
"\x83\xc4\x10" .# add esp,10 CDEC
+L call we maintain stack
"\x89\xec" .# mov esp,ebp
"\x5D" .# pop ebp
"\x83\xc4\x0c" .# add esp,0c
"\xc3"; # ret
print ">>> internal XSUB\'s(ASM routine) call/callback test <<<\n";
print "---Perl calls assembly calls back to Perl test:\n";
$cbtest = DeclareXSub( __PACKAGE__."::cbtest" , SVPtr($cb_asm2perl), "
+");
$cbtest->{Call}();
#cbtest();
sub asm2perl{
my $lastcaller = (caller(1))[3];
print "called from ",$lastcaller . "(\@_ = ",join(" ",@_),")\n";
}
print "Back to Perl\n";
__END__
my output:
>>> Win32 API __stdcall tests <<<
Before CopyMemory: Just Another C&ASM Hacker
After CopyMemory: Just Another Perl Hacker
_i64toa tests:
ticks/second: 3579545
ticks: 179650690908
>>> Microsoft Visual C Run Time msvcrt.dll(and msvcr??.dll) __cdecl te
+sts <<<
_atoi64 call: Quad(longlong) return test (EDX:EAX)=> 0102030405060708
Perl emulated (un)pack(Q,...) test: 0x0102030405060708
FPU doubles test: 4*atan(1) = Pi = 3.1415926535897931
---C library qsort calls back to Perl test:
Before sort:399,99,3,1,234,546,789,34,124,894,521,67,754
After sort:1,3,34,67,99,124,234,399,521,546,754,789,894
>>> internal XSUB's(ASM routine) call/callback test <<<
---Perl calls assembly calls back to Perl test:
called from AsmUtil_IA32::__ANON__(@_ = Assembly Callback To Perl)
Back to Perl
package AsmUtil_IA32;
use DynaLoader;
use Exporter;
use Config;
use strict;
our @ISA = qw(Exporter);
our @EXPORT = qw(DeclareXSub DeclareCallback SVPtr CInt CQuad cbreturn
SVQuad getparameters $call_argv_ref $get_context_ref
+ $Tstack_sp_ptr_ref);
our @EXPORT_OK = qw(G_DISCARD G_SCALAR G_NOARGS);
our @EXPORT_NOT_OK = qw();
our $VERSION = "0.01";
#-------- cop.h:
use constant G_SCALAR => 0;
use constant G_DISCARD => 2;
use constant TRUE => 1;
use constant FALSE => 0;
#--------------- get perl shared object and some API routines---
my $perldll = $^X;
my $VER = int($]) . int(1000*($]-int($])));
$perldll =~ s/\./$VER\./;
$perldll =~ s/\.exe/\.$Config{so}/;
our $perlAPI = DynaLoader::dl_load_file("$perldll");
our $call_argv_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_call_ar
+gv"); # embed.h
our $get_context_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_get_c
+ontext");
our $Tstack_sp_ptr_ref = DynaLoader::dl_find_symbol($perlAPI,"Perl_Tst
+ack_sp_ptr");
######################## Subs ###############
sub DeclareXSub{
my %FARPROC;
$FARPROC{namespace} = $_[0];
$FARPROC{lib} = DynaLoader::dl_load_file((split("!",$_[1]))[0]) if $_
+[1] =~ m/\!/;
$FARPROC{procptr} = defined($FARPROC{lib}) ? DynaLoader::dl_find_symb
+ol($FARPROC{lib},(split("!",$_[1]))[1]) : $_[1];
return undef if !defined($FARPROC{procptr});
$FARPROC{args} = $_[2];
$FARPROC{rtn} = $_[3];
if ($^O =~ /win32/i){
$FARPROC{conv} = defined($_[4]) ? $_[4] : "s" ; # default calling
+convention: Win32 __stdcall
}else{
$FARPROC{conv} = defined($_[4]) ? $_[4] : "c" ; # default calling
+convention: UNIX __cdecl
}
my $stackIN;
my @stridx;
my @bytype;
my $bytspushed;
my $asmcode = "\x90"; # machine code starts , this can also be \xcc -
+user breakpoint
my @Args = split(",",$FARPROC{args});
@Args = reverse @Args; # pushing order last args first
foreach my $arg (@Args){
$stackIN .= "\x68" . pack("I",0) ; # 4 byte push
$stackIN .= "\x68" . pack("I",0) if($arg =~ m/d|q/i) ; # another
+4 byte push for doubles,quads
push(@stridx,length($stackIN)-4+1) if $arg !~ m/d|q/i;
push(@stridx,length($stackIN)-9+1) if $arg =~ m/d|q/i;
push(@bytype,"byval") if $arg =~ m/v|l|i|c|d|q/i;
push(@bytype,"byref") if $arg =~ m/p|r/i; # 32 bit pointers
$bytspushed += 4 ; # 4 byte aligned
$bytspushed += 4 if($arg =~ m/d|q/i); # another 4 for doubles or qua
+ds
}
$FARPROC{sindex} = \@stridx;
$FARPROC{types} = \@bytype;
$FARPROC{stklen} = $bytspushed;
$FARPROC{edi} = "null"; # 4 bytes long !!! ,how convenient
$FARPROC{esi} = "null";
$FARPROC{RetEAX} = "null"; # usual return register
$FARPROC{RetEDX} = "null"; # second return register
$FARPROC{Ret64bit} = "nullnull"; # save double or quad returns
$FARPROC{stackOUT} ="\x00" x $bytspushed;
$asmcode .= "$stackIN";
$asmcode .= "\xb8" . CInt($FARPROC{procptr}); # mov eax, $procptr
$asmcode .= "\xFF\xd0" ; # call eax => CALL THE PROCEDURE or in C: (
+* EAX)(args, ...);
# --- save return values info into Perl Strings, including the stack:
# - some calls return values back to the stack, overwriting the origin
+al args
$asmcode .= "\xdd\x1d" . CPtr($FARPROC{Ret64bit}) if $FARPROC{rtn} =
+~ m/d/i; # fstp qword [$FARPROC{Ret64bit}]
$asmcode .= "\xa3" . CPtr($FARPROC{RetEAX}); # mov [$FARPROC{RetE
+AX}], eax
$asmcode .= "\x89\x15" . CPtr($FARPROC{RetEDX}); # mov [$FARPROC{RetE
+DX}], edx
$asmcode .= "\x89\x35" . CPtr($FARPROC{esi}); # mov [$FARPROC{esi}
+], esi
$asmcode .= "\x89\x3d" . CPtr($FARPROC{edi}); # mov [$FARPROC{edi}
+], edi
$asmcode .= "\x8d\xb4\x24" if $FARPROC{conv} =~ m/s/i; #
$asmcode .= CInt(-$bytspushed) if $FARPROC{conv} =~ m/s/i;# lea e
+si,[esp-$bytspushed]
$asmcode .= "\x89\xe6" if $FARPROC{conv} =~ m/c/i; # mov esi,esp
$asmcode .= "\xbf" .CPtr($FARPROC{stackOUT}); # mov edi, [$FARPROC
+{stackOUT}]
$asmcode .= "\xb9" . CInt($bytspushed); # mov ecx,$bytspushe
+d - number of bytes to copy
$asmcode .= "\xfc"; # cld
$asmcode .= "\xf3\xa4"; # rep movsb [edi],[e
+si] => copy the stack
$asmcode .= "\x8b\x3d" . CPtr($FARPROC{edi}); # mov edi,[$FARPROC{
+edi}]
$asmcode .= "\x8b\x35" . CPtr($FARPROC{esi}); # mov esi,[$FARPROC{
+esi}]
$asmcode .= "\x81\xc4" . CInt($bytspushed) if $FARPROC{conv} =~ m/c/
+i; # add esp,$bytspushed : __cdecl
$asmcode .= "\xc3" ;# ret __stdcall or __cdecl
$FARPROC{ASM} = $asmcode;
$FARPROC{coderef} = DynaLoader::dl_install_xsub($FARPROC{namespace},
+SVPtr($FARPROC{ASM}),__FILE__);
$FARPROC{Call} = sub{
my @templates = reverse split(",",$FARPROC{args});
my @args = reverse @_; # parameters get pushed last firs
+t;
# --- edit the machine language pushes with @args ---
for(my $index = 0; $index < scalar(@{$FARPROC{sindex}}) ;
+++$index ) {
my @a=split(":",$args[$index]) if $args[$index] =~ m/\:/;
if($templates[$index] eq "ss"){ $args[$index] = $a[0]<<16
+ + $a[1];}
if($templates[$index] eq "cccc"){$args[$index] = $a[0]<<2
+4 + $a[1]<<16 + $a[2]<<8 + $a[3]; }
if($templates[$index] eq "ccc"){$args[$index] = $a[0]<<16
+ + $a[1]<<8 + $a[2]; }
if($templates[$index] eq "cc"){$args[$index] = $a[0]<<8 +
+ $a[1]; }
if($templates[$index] eq "scc"){$args[$index] = $a[0]<<16
+ + $a[1]<<8 + $a[2] ; }
if($templates[$index] eq "ccs"){$args[$index] = $a[0]<<24
+ + $a[1]<<16 + $a[2] ; }
if($templates[$index] eq "sc"){$args[$index] = $a[0]<<16
++ $a[1] ; }
if($templates[$index] eq "cs"){$args[$index] = $a[0]<<16
++ $a[1]; }
if($templates[$index] =~ m/d|q/i){
$args[$index] = pack("d",$args[$index]) if $templates[$i
+ndex] =~ m/d/i;
my $Quad = $args[$index] if $templates[$index] =~ m/q/i;
+
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index]+5, 4 ,
+ substr($args[$index],0,4)) if $templates[$index] =~ m/d/i;
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 , s
+ubstr($args[$index],4,4)) if $templates[$index] =~ m/d/i;
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index]+5, 4 ,
+ substr($Quad,0,4)) if $templates[$index] =~ m/q/i;
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 , s
+ubstr($Quad,4,4)) if $templates[$index] =~ m/q/i;
}else{
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 , C
+Int($args[$index])) if $FARPROC{types}->[$index] eq "byval";
}
substr($FARPROC{ASM}, $FARPROC{sindex}->[$index], 4 , CP
+tr($args[$index])) if $FARPROC{types}->[$index] eq "byref";
}
my $ret = &{$FARPROC{coderef}}; # Invoke it
return $ret; # usually EAX==return value - not reliabe a
+s $FARPROC{RetEAX}
};
return \%FARPROC; # make an object out of a hash( has 1 XSUB, 1 sub,
+ 2 arrays, several scalars)
}
sub DeclareCallback{
my %CALLBACK;
$CALLBACK{cbname} = $_[0];
$CALLBACK{args} = $_[1];
$CALLBACK{cbrtn} = defined($_[2]) ? $_[2] : "I";
$CALLBACK{conv} = defined($_[3]) ? $_[3] : "c" ;
$CALLBACK{ptrptrargs} = "\x00" x 4 ; # char **args, NULL FOR NOW
$CALLBACK{stackPtr} = "\x00" x 4; # ebp
$CALLBACK{CallerRtn1} = "\x00" x 8; # eax register usually, possibly
+ for a double
$CALLBACK{CallerRtn2} = "\x00" x 4; # edx register usually , for ret
+urning 8 byte values edx:eax - doubles
$CALLBACK{ASM} =
"\x90" .# nop or debug brea
+k
"\x55" .# push ebp
"\x89\xE5" .# mov ebp,esp
# -------- local variables - Perl function pointers, stack info
"\x68" . CInt($call_argv_ref) .# push *Perl_call_a
+rgv()
"\x68" . CInt($get_context_ref) .# push *Perl_get_co
+ntext()
"\x68" . CInt($Tstack_sp_ptr_ref) .# push *Perl_Tstack
+_sp_ptr()
"\x68\x00\x00\x00\x00" .# empty local varia
+ble
"\x68\x00\x00\x00\x00" .# empty local varia
+ble
# ------- get ebp to access C stack on the Perl side and save return
+registers----------------
"\x89\x2d" . CPtr($CALLBACK{stackPtr}) .# mov ds:[$CALLBA
+CK{stackPtr}],ebp - stack access
"\xA3" . CPtr($CALLBACK{CallerRtn1}) .# mov ds:[$CALLBA
+CK{CallerRtn1}],eax - save eax primary return register
"\x89\x15" . CPtr($CALLBACK{CallerRtn2}) .# mov ds:[$CALLBA
+CK{CallerRtn2}],edx - save edx secondary return register
# ----------------- dSP; MACRO starts -------------------
"\xff\x55\xf8" .# call dword ptr [e
+bp-0x08] => call Perl_get_context()
"\x50" .# push eax
"\xff\x55\xf4" .# call dword ptr [e
+bp-0x0c] => call Perl_Tstack_sp_ptr()
"\x59" .# pop ecx
"\x8B\x00" .# mov eax,dword pt
+r [eax]
"\x89\x45\xec" .# mov dword ptr [s
+p],eax => local copy of SP
# -------------- perl_call_argv(char *callbackname,G_DISCARD,char **ar
+gs) -----
"\x68" . CPtr($CALLBACK{ptrptrargs}) .# push char **args
"\x68\x02\x00\x00\x00" .# push G_DISCARD
"\x68" . CPtr($CALLBACK{cbname}) .# push ptr to name of p
+erl subroutine
"\xff\x55\xf8" .# call Perl_get_context
+()
"\x50" .# push eax
"\xff\x55\xfc" .# call perl_call_argv =
+> call dword ptr [ebp-0x04]
"\x83\xc4\x10" .# add esp,0x10 CDECL c
+all we maintain stack
"\x83\xc4\x0c" .# add esp,14 # dealloca
+te local variables
"\x89\xec" .# mov esp,ebp
"\x5D" .# pop ebp
"\xA1" . CPtr($CALLBACK{CallerRtn1}) .# mov eax,[$CALLB
+ACK{CallerRtn1}] - return eax to caller
"\x8b\x15" . CPtr($CALLBACK{CallerRtn2}) .# mov edx,[$CALLB
+ACK{CallerRtn2}] - return edx to caller
"\xc3"; # ret
$CALLBACK{Ptr} = SVPtr($CALLBACK{ASM});
return \%CALLBACK;
}
sub getparameters{
my $argtmpl;
if(!defined($_[1])) {return [];};
my @args = split(",",$_[1]);
foreach my $arg (@args){ $argtmpl .= $arg;}
my $template = "P" . (4*scalar(@args)+8);
my $Cstack = substr(unpack($template,$_[0]),8); # copy stack in bin
+ary form
return unpack($argtmpl,$Cstack);
}
sub cbreturn{
my %rets = %{$_[0]};
substr($rets{cbref}->{CallerRtn1},0,4,pack("i",$rets{ret32})) if def
+ined($rets{ret32});
substr($rets{cbref}->{CallerRtn1},0,4,pack("x4i",$rets{ret32})) if d
+efined($rets{ret64}); # little endian
substr($rets{cbref}->{CallerRtn2},0,4,pack("ix4",$rets{ret32})) if d
+efined($rets{ret64});
}
sub SVPtr{
return unpack("I",pack("p",$_[0]));
}
sub CPtr{
return pack("p",$_[0]);
}
sub CInt{
return pack("i",$_[0]);
}
sub CShort{
return pack("s",$_[0]);
}
sub CByte{
return pack("c",$_[0]);
}
sub CDbl{
return pack("d",$_[0]);
}
sub CQuad{ # emulates pack("Q",...) - assumes decimal string input
# --- convert an arbitrary length decimal string to a hex string ---
my @digits = split(//, $_[0]);
my $lohexstr = substr(sprintf("%08X",substr($_[0],-8)),-2); # gets t
+he first 8 bits
my $totquotient = "";
# bit shift to the right 8 bits by dividing by 256,
# using arbitrary precision grade school long division
for (my $j = 0;$j <4 ; ++$j){ # shift 8 bits, 4 times for lower long
my $remainder = "";
$totquotient = "";
my $quotient = "";
my $dividend = "";
my $remainder = "";
for(my $i=0;$i<=$#digits;++$i){
$dividend = $remainder . $digits[$i];
$quotient = int($dividend/256);
$remainder = $dividend % 256;
$totquotient .= sprintf("%01d",$quotient);
}
$totquotient =~ s/^0*//;
last if $j==3;
$lohexstr = substr(sprintf("%08X",substr($totquotient,-8)),6,2) . $lo
+hexstr; # unshift 8 more bits
@digits = split(//,$totquotient);
}
my $hihexstr = sprintf("%08X",$totquotient);
my $lo = pack("H*", $lohexstr);
my $hi = pack("H*", $hihexstr);
( $hi, $lo ) = ( $lo, $hi ) ; # little endian
return $hi . $lo;
}
sub SVQuad{ # emulates unpack("Q",...) - assumes binary input
my ($hi, $lo) = unpack("NN",$_[0]) ;
( $hi, $lo ) = ( $lo, $hi ) ; # little endian
return sprintf("0x%08X%08X",$hi,$lo); # - 64 bit base 10 expressions
+mean anything ?
}
1;
|
|
