PDL+TCC

example.pl

use strict;
use warnings;
use PDL;

use Inline Pdlpp => Config =>
        INC => "-I$ENV{HOME}/include",
        LIBS => "-L$ENV{HOME}/lib -ltcc",
        ;

use Inline 'Pdlpp';

######### The functions to check #########

my ($pdl_a, $pdl_b);

sub pdl_radius {
    return sqrt($pdl_a**2 + $pdl_b**2);
}

sub tcc_radius {
    return $pdl_a->custom_binop($pdl_b, 'sqrt(a*a + b*b)');
}

$pdl_b = $pdl_a = sequence(10);
print "pdl_radius gives ", pdl_radius(), "\n";
print "tcc_radius gives ", tcc_radius(), "\n";

######### Benchmarking code #########

use Time::HiRes qw(gettimeofday tv_interval);
my @Lengths = map {($_, 2*$_, 5*$_)} map {10**$_} qw(2 3 4 5 6 7);

for (@Lengths) {
    print "$_ elements...\n";
    $pdl_a = random($_);
    $pdl_b = random($_);
    
    my $t0 = [gettimeofday];
    pdl_radius();
    my $t1 = [gettimeofday];
    print "   PDL : ", tv_interval($t0 => $t1), "\n";
    
    $t0 = [gettimeofday];
    tcc_radius();
    $t1 = [gettimeofday];
    print "   TCC : ", tv_interval($t0 => $t1), "\n";
}

#my $a = ones(10)->float + 2;
#my $b = $a->sequence;
#my $op = 'sqrt(a*a + b*b)';
#my $c = $a->custom_binop($b, $op);
#
#print "a is $a\nb is $b\n";
#print "$op is $c\n";

__END__

__Pdlpp__

# I need to define a few functions and declare a few package-globals:
pp_addpm(<<'MODULE_MATERIAL');

END {
        _cleanup;
}

MODULE_MATERIAL

pp_addxs(<<'XS_MATERIAL');

void
_cleanup()
        CODE:
# line 39 "eval-it.pl"
                /* Cleanup the compiler states */
                HV * states_hash = get_hv("PDL::TCC::compiler_states", 0);
                if (states_hash != NULL) {
                        char * key;
                        HE * hash_entry;
                        SV ** value_p;
                        int n_keys = hv_iterinit(states_hash);
                        int i;
                        TCCState * s;
                        for(i = 0; i < n_keys; ++i) {
                                /* Get the hash entry */
                                hash_entry = hv_iternext(states_hash);
                                /* Get the key of the hash entry */
                                key = hv_iterkey(hash_entry, 0);
                                /* Free the TCC State object at the associated address */
                                /* note: tried to use hv_fetchs, but ran into compile issues */
                                value_p = hv_fetch(states_hash, key, strlen(key), 0);
                                s = INT2PTR(TCCState *, SvIV(*value_p));
                                tcc_delete(s);
                        }
                }

XS_MATERIAL

pp_addhdr(<<'HEADER'); 

/* libtcc, of course */
#include <libtcc.h>

double foo(double a, double b) {
        return sqrt(a*a + b*b);
}

HEADER

pp_def('custom_binop',
        Pars => 'a(); b(); [o] c()',
        OtherPars => 'char * string_to_eval',
        Code => q{
                # line 79 "eval-it.pl"
                /* First check if the cash has a compiler state associated with this
                 * code fragment */
                HV * states_hash = get_hv("PDL::TCC::compiler_states", GV_ADD);
                
                TCCState * s;
                char * key = $COMP(string_to_eval);
                if (! hv_exists(states_hash, key, strlen(key))) {
                        char * to_compile = form("double sqrt(double); double foo(double, double); double to_eval (double a, double b) { return (%s);}", key);
                        
                        /* Doesn't exist, so create the state and compile the function */
                        s = tcc_new();
                        if (s == NULL) croak("Unable to create tcc compiler context");
                        if (tcc_compile_string(s, to_compile) < 0)
                                croak("Unable to compile your string");
                        
                        /* Add the sqrt symbol */
                        /* tcc_add_symbol(s, "sqrt", sqrt); */
                        /* tcc_add_symbol(s, "foo", foo); */
                        
                        if (tcc_relocate(s) < 0)
                                croak("Unable to relocate compiled code");
                        
                        /* Add the state to the hash */
                        hv_store(states_hash, key, strlen(key), newSViv((I32)s), 0);
                }
                else {
                        s = INT2PTR(TCCState *, SvIV(*(hv_fetch(states_hash, key, strlen(key), 0))));
                }
                
                double (*to_eval)(double, double) = tcc_get_symbol(s, "to_eval");
                
                threadloop %{
                        $c() = to_eval($a(), $b());
                %}
        }
);