=head1 NAME Faster - do some things faster =head1 SYNOPSIS use Faster; perl -MFaster ... =head1 DESCRIPTION This module implements a very simple-minded JIT. It works by more or less translating every function it sees into a C program, compiling it and then replacing the function by the compiled code. As a result, startup times are immense, as every function might lead to a full-blown compilation. The speed improvements are also not great, you can expect 20% or so on average, for code that runs very often. Faster is in the early stages of development. Due to its design its relatively safe to use (it will either work or simply slowdown the program immensely, but rarely cause bugs). Usage is very easy, just C and every function called from then on will be compiled. Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in F, and it will even create those temporary files in an insecure manner, so watch out. =over 4 =cut package Faster; use strict; use Config; use B (); #use Digest::MD5 (); use DynaLoader (); use File::Temp (); BEGIN { our $VERSION = '0.01'; require XSLoader; XSLoader::load __PACKAGE__, $VERSION; } my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; my $LIBS = "$Config{libs}"; my $_o = $Config{_o}; my $_so = ".so"; # we don't need no steenking PIC on x86 $COMPILE =~ s/-f(?:PIC|pic)//g if $Config{archname} =~ /^(i[3456]86)-/; my $opt_assert = $ENV{FASTER_DEBUG}; my $verbose = $ENV{FASTER_VERBOSE}+0; our $source; our @ops; our $op; our $op_name; our @op_loop; our %op_regcomp; my %f_unsafe = map +($_ => undef), qw( leavesub leavesublv return goto last redo next eval flip leaveeval entertry formline grepstart mapstart substcont entereval require ); # pushmark extend=0 # padsv extend=1 # padav extend=1 # padhv extend=1 # padany extend=1 # const extend=1 my %f_noasync = map +($_ => undef), qw( mapstart grepstart match entereval enteriter entersub leaveloop pushmark nextstate const stub unstack last next redo seq padsv padav padhv padany aassign sassign orassign rv2av rv2cv rv2gv rv2hv refgen gv gvsv add subtract multiply divide complement cond_expr and or not defined method_named preinc postinc predec postdec aelem aelemfast helem delete exists pushre subst list join split concat length substr stringify ord push pop shift unshift eq ne gt lt ge le regcomp regcreset regcmaybe ); my %callop = ( entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", mapstart => "Perl_pp_grepstart (aTHX)", ); sub callop { $callop{$op_name} || "Perl_pp_$op_name (aTHX)" } sub assert { return unless $opt_assert; $source .= " assert ((\"$op_name\", ($_[0])));\n"; } sub out_callop { assert "nextop == (OP *)$$op"; $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; } sub out_cond_jump { $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n"; } sub out_jump_next { out_cond_jump $op_regcomp{$$op} if $op_regcomp{$$op}; assert "nextop == (OP *)${$op->next}"; $source .= " goto op_${$op->next};\n"; } sub out_next { $source .= " nextop = (OP *)${$op->next}L;\n"; out_jump_next; } sub out_linear { out_callop; out_jump_next; } sub op_entersub { out_callop; $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; out_jump_next; } *op_require = \&op_entersub; sub op_nextstate { $source .= " PL_curcop = (COP *)nextop;\n"; $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; $source .= " FREETMPS;\n"; out_next; } sub op_pushmark { $source .= " PUSHMARK (PL_stack_sp);\n"; out_next; } if ($Config{useithreads} ne "define") { # disable optimisations on ithreads *op_const = sub { $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; out_next; }; *op_gv = \&op_const; *op_aelemfast = sub { my $targ = $op->targ; my $private = $op->private; $source .= " {\n"; if ($op->flags & B::OPf_SPECIAL) { $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n"; } else { $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n"; } if ($op->flags & B::OPf_MOD) { $source .= " SV *sv = *av_fetch (av, $private, 1);\n"; } else { $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n"; } if (!($op->flags & B::OPf_MOD)) { $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; } $source .= " dSP;\n"; $source .= " XPUSHs (sv);\n"; $source .= " PUTBACK;\n"; $source .= " }\n"; out_next; }; *op_gvsv = sub { $source .= " {\n"; $source .= " dSP;\n"; $source .= " EXTEND (SP, 1);\n"; if ($op->private & B::OPpLVAL_INTRO) { $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; } else { $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; } $source .= " PUTBACK;\n"; $source .= " }\n"; out_next; }; } # does kill Crossfire/res2pm sub op_stringify { my $targ = $op->targ; $source .= <other}L; goto op_${$op->other}; } } EOF out_next; } sub op_or { $source .= <other}L; goto op_${$op->other}; } } EOF out_next; } sub op_padsv { my $flags = $op->flags; my $targ = $op->targ; $source .= <flags & B::OPf_MOD) { if ($op->private & B::OPpLVAL_INTRO) { $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; } elsif ($op->private & B::OPpDEREF) { my $deref = $op->private & B::OPpDEREF; $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n"; } } $source .= <next; out_cond_jump $op->other; out_jump_next; } *op_mapstart = \&op_grepstart; sub op_substcont { out_callop; out_cond_jump $op->other->pmreplstart; assert "nextop == (OP *)${$op->other->next}L"; $source .= " goto op_${$op->other->next};\n"; } sub out_break_op { my ($idx) = @_; out_callop; out_cond_jump $_->[$idx] for reverse @op_loop; $source .= " return nextop;\n"; } sub xop_next { out_break_op 0; } sub op_last { out_break_op 1; } sub xop_redo { out_break_op 2; } sub cv2c { my ($cv) = @_; local @ops; local @op_loop; local %op_regcomp; my %opsseen; my @todo = $cv->START; while (my $op = shift @todo) { for (; $$op; $op = $op->next) { last if $opsseen{$$op}++; push @ops, $op; my $name = $op->name; my $class = B::class $op; if ($class eq "LOGOP") { unshift @todo, $op->other; # unshift vs. push saves jumps # regcomp/o patches ops at runtime, lets expect that $op_regcomp{${$op->first}} = $op->next if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; } elsif ($class eq "PMOP") { unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; } elsif ($class eq "LOOP") { push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next]; push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; } } } local $source = <name; $source .= "op_$$op: /* $op_name */\n"; #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# $source .= " PERL_ASYNC_CHECK ();\n" unless exists $f_noasync{$op_name}; if (my $can = __PACKAGE__->can ("op_$op_name")) { # handcrafted replacement $can->($op); } elsif (exists $f_unsafe{$op_name}) { # unsafe, return to interpreter assert "nextop == (OP *)$$op"; $source .= " return nextop;\n"; } elsif ("LOGOP" eq B::class $op) { # logical operation with optionaö branch out_callop; out_cond_jump $op->other; out_jump_next; } elsif ("PMOP" eq B::class $op) { # regex-thingy out_callop; out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; out_jump_next; } else { # normal operator, linear execution out_linear; } } $op_name = "func exit"; assert (0); $source .= <:raw", "$stem.c"; print FILE < #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define RUNOPS_TILL(op) \\ while (nextop != (op)) \\ { \\ PERL_ASYNC_CHECK (); \\ PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ } EOF for (@source) { my $func = $uid++; $_ =~ s/%%%FUNC%%%/$func/g; print FILE $_; $_ = $func; } close FILE; system "$COMPILE -o $stem$_o $stem.c"; #d#unlink "$stem.c"; system "$LINK -o $stem$_so $stem$_o $LIBS"; unlink "$stem$_o"; my $so = DynaLoader::dl_load_file "$stem$_so" or die "$stem$_so: $!"; #unlink "$stem$_so"; map +(DynaLoader::dl_find_symbol $so, $_), @source } my %ignore; sub entersub { my ($cv) = @_; my $pkg = $cv->STASH->NAME; return if $ignore{$pkg}; warn "compiling ", $cv->STASH->NAME, "\n" if $verbose; eval { my @cv; my @cv_source; # always compile the whole stash my %stash = $cv->STASH->ARRAY; while (my ($k, $v) = each %stash) { $v->isa (B::GV::) or next; my $cv = $v->CV; if ($cv->isa (B::CV::) && ${$cv->START} && $cv->START->name ne "null") { push @cv, $cv; push @cv_source, cv2c $cv; } } my @ptr = source2ptr @cv_source; for (0 .. $#cv) { patch_cv $cv[$_], $ptr[$_]; } }; if ($@) { $ignore{$pkg}++; warn $@; } } hook_entersub; 1; =back =head1 ENVIRONMENT VARIABLES The following environment variables influence the behaviour of Faster: =over 4 =item FASTER_VERBOSE Faster will output more informational messages when set to values higher than C<0>. Currently, C<1> outputs which packages are being compiled. =item FASTER_DEBUG Add debugging code when set to values higher than C<0>. Currently, this adds 1-3 C's per perl op, to ensure that opcode order and C execution order are compatible. =item FASTER_CACHE NOT YET IMPLEMENTED Set a persistent cache directory that caches compiled code fragments. Normally, code compiled by Faster will be deleted immediately, and every restart will recompile everything. Setting this variable to a directory makes Faster cache the generated files for re-use. This directory will always grow in contents, so you might need to erase it from time to time. =back =head1 BUGS/LIMITATIONS Perl will check much less often for asynchronous signals in Faster-compiled code. It tries to check on every function call, loop iteration and every I/O operator, though. The following things will disable Faster. If you manage to enable them at runtime, bad things will happen. Enabling them at startup will be fine, though. enabled tainting enabled debugging Thread-enabled builds of perl will dramatically reduce Faster's performance, but you don't care about speed if you enable threads anyway. These constructs will force the use of the interpreter for the currently executed function as soon as they are being encountered during execution. goto next, redo (but not well-behaved last's) eval require any use of formats .., ... (flipflop operators) =head1 AUTHOR Marc Lehmann http://home.schmorp.de/ =cut