--- Faster/Faster.pm 2006/03/10 22:41:47 1.22 +++ Faster/Faster.pm 2006/03/13 17:10:32 1.33 @@ -10,26 +10,36 @@ =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. +This module implements a very simple-minded "JIT" (or actually AIT, ahead +of time compiler). 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. +average, for code that runs very often. The reason for this is that data +handling is mostly being done by the same old code, it just gets called +a bit faster. Regexes and string operations won't get faster. Airhtmetic +doresn't become any faster. Just the operands and other stuff is put on +the stack faster, and the opcodes themselves have a bit less overhead. 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). +More intelligent algorithms (loop optimisation, type inference) could +improve that easily, but requires a much more elaborate presentation and +optimiser than what is in place. There are no plans to improve Faster in +this way, yet, but it would provide a reasonably good place to start. + 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. +Right now, Faster can leave lots of F<*.c> and F<*.so> files in your +F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will +even create those temporary files in an insecure manner, so watch out. =over 4 @@ -37,12 +47,15 @@ package Faster; +no warnings; + use strict; use Config; use B (); -#use Digest::MD5 (); use DynaLoader (); -use File::Temp (); +use Digest::MD5 (); +use Storable (); +use Fcntl (); BEGIN { our $VERSION = '0.01'; @@ -51,6 +64,14 @@ XSLoader::load __PACKAGE__, $VERSION; } +my $CACHEDIR = + $ENV{FASTER_CACHE} + || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache") + || do { + require File::Temp; + File::Temp::tempdir (CLEANUP => 1) + }; + 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}"; @@ -61,17 +82,21 @@ $COMPILE =~ s/-f(?:PIC|pic)//g if $Config{archname} =~ /^(i[3456]86)-/; -my $opt_assert = $ENV{FASTER_DEBUG}; +my $opt_assert = $ENV{FASTER_DEBUG} > 1; my $verbose = $ENV{FASTER_VERBOSE}+0; +warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2; + our $source; our @ops; +our $insn; our $op; our $op_name; our @op_loop; our %op_regcomp; +# ops that cause immediate return to the interpreter my %f_unsafe = map +($_ => undef), qw( leavesub leavesublv return goto last redo next @@ -80,32 +105,73 @@ substcont entereval require ); -# pushmark extend=0 -# padsv extend=1 -# padav extend=1 -# padhv extend=1 -# padany extend=1 -# const extend=1 +# ops with known stack extend behaviour +# the values given are maximum values +my %extend = ( + pushmark => 0, + nextstate => 0, # might reduce the stack + unstack => 0, + enter => 0, + + stringify => 0, + not => 0, + and => 0, + or => 0, + gvsv => 0, + rv2gv => 0, + preinc => 0, + predec => 0, + postinc => 0, + postdec => 0, + aelem => 0, + helem => 0, + qr => 1, #??? + pushre => 1, + gv => 1, + aelemfast => 1, + aelem => 0, + padsv => 1, + const => 1, + pop => 1, + shift => 1, + eq => -1, + ne => -1, + gt => -1, + lt => -1, + ge => -1, + lt => -1, + cond_expr => -1, + add => -1, + subtract => -1, + multiply => -1, + divide => -1, + aassign => 0, + sassign => -2, + method => 0, + method_named => 1, +); +# ops that do not need an ASYNC_CHECK my %f_noasync = map +($_ => undef), qw( mapstart grepstart match entereval enteriter entersub leaveloop - pushmark nextstate + pushmark nextstate caller const stub unstack - last next redo seq + last next redo goto 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 + bit_and bit_or bit_xor defined - method_named + method method_named bless preinc postinc predec postdec aelem aelemfast helem delete exists - pushre subst list join split concat + pushre subst list lslice join split concat length substr stringify ord push pop shift unshift eq ne gt lt ge le @@ -113,7 +179,7 @@ ); my %callop = ( - entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", + entersub => "(PL_op->op_ppaddr) (aTHX)", mapstart => "Perl_pp_grepstart (aTHX)", ); @@ -171,7 +237,7 @@ } sub op_pushmark { - $source .= " PUSHMARK (PL_stack_sp);\n"; + $source .= " faster_PUSHMARK (PL_stack_sp);\n"; out_next; } @@ -180,7 +246,9 @@ # disable optimisations on ithreads *op_const = sub { - $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; + $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; + + $ops[0]{follows_const}++ if @ops;#d# out_next; }; @@ -210,7 +278,7 @@ } $source .= " dSP;\n"; - $source .= " XPUSHs (sv);\n"; + $source .= " PUSHs (sv);\n"; $source .= " PUTBACK;\n"; $source .= " }\n"; @@ -220,7 +288,6 @@ *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"; @@ -290,36 +357,86 @@ sub op_padsv { my $flags = $op->flags; - my $targ = $op->targ; + my $padofs = "(PADOFFSET)" . $op->targ; $source .= <private & B::OPpLVAL_INTRO)) { + $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n"; + $ops[0]{follows_padsv_lval_intro}++ if @ops;#d# + } + + $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"; - } + + if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) { + $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n"; } + $source .= " }\n"; + + out_next; +} + +sub op_sassign { + $source .= <private & B::OPpASSIGN_BACKWARDS; + + if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) { + # simple assignment - the target exists, but is basically undef + $source .= " SvSetSV (right, left);\n"; + } else { + $source .= " SvSetMagicSV (right, left);\n"; + } + $source .= <{follows_const}) { + $source .= <START; + my %op_target; + my $numpushmark; 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; + my $insn = { op => $op }; + + push @ops, $insn; + + if (exists $extend{$name}) { + my $extend = $extend{$name}; + $extend = $extend->($op) if ref $extend; + $insn->{extend} = $extend if defined $extend; + } + + push @todo, $op->next; + if ($class eq "LOGOP") { - unshift @todo, $op->other; # unshift vs. push saves jumps + push @todo, $op->other; + $op_target{${$op->other}}++; # 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; + if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) { + $op_target{${$op->first}}++; + $op_regcomp{${$op->first}} = $op->next; + } } elsif ($class eq "PMOP") { - unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; + if (${$op->pmreplstart}) { + unshift @todo, $op->pmreplstart; + $op_target{${$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; + my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next); + + push @op_loop, \@targ; + push @todo, @targ; + + $op_target{$$_}++ for @targ; + + } elsif ($class eq "COP") { + $insn->{bblock}++ if defined $op->label; + + } else { + if ($name eq "pushmark") { + $numpushmark++; + } } } } + $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops; + local $source = <{op}}L; EOF + $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n" + if $numpushmark; + while (@ops) { - $op = shift @ops; + $insn = shift @ops; + + $op = $insn->{op}; $op_name = $op->name; + my $class = B::class $op; + + $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d# $source .= "op_$$op: /* $op_name */\n"; #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# @@ -453,6 +612,21 @@ if (my $can = __PACKAGE__->can ("op_$op_name")) { # handcrafted replacement + + if ($insn->{extend} > 0) { + # coalesce EXTENDs + # TODO: properly take negative preceeding and following EXTENDs into account + for my $i (@ops) { + last if exists $i->{bblock}; + last unless exists $i->{extend}; + my $extend = delete $i->{extend}; + $insn->{extend} += $extend if $extend > 0; + } + + $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n" + if $insn->{extend} > 0; + } + $can->($op); } elsif (exists $f_unsafe{$op_name}) { @@ -460,16 +634,16 @@ assert "nextop == (OP *)$$op"; $source .= " return nextop;\n"; - } elsif ("LOGOP" eq B::class $op) { - # logical operation with optionaö branch + } elsif ("LOGOP" eq $class) { + # logical operation with optional branch out_callop; out_cond_jump $op->other; out_jump_next; - } elsif ("PMOP" eq B::class $op) { + } elsif ("PMOP" eq $class) { # regex-thingy out_callop; - out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; + out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot}; out_jump_next; } else { @@ -491,15 +665,37 @@ } my $uid = "aaaaaaa0"; +my %so; + +sub func2ptr { + my (@func) = @_; -sub source2ptr { - my (@source) = @_; + #LOCK + mkdir $CACHEDIR, 0777; + sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666 + or die "$$CACHEDIR/meta: $!"; + binmode $meta_fh, ":raw:perlio"; + fcntl_lock fileno $meta_fh + or die "$CACHEDIR/meta: $!"; + + my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 }; + + for my $f (@func) { + $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source}); + $f->{so} = $meta->{$f->{func}}; + } - my $stem = "/tmp/Faster-$$-" . $uid++; + if (grep !$_->{so}, @func) { + my $stem; + + do { + $stem = "$CACHEDIR/$$-" . $uid++; + } while -e "$stem$_so"; - open FILE, ">:raw", "$stem.c"; - print FILE <:raw", "$stem.c"; + print $fh < @@ -507,33 +703,56 @@ #include "perl.h" #include "XSUB.h" +#if 1 +# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow () +# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base +#else +# define faster_PUSHMARK_PREALLOC(count) 1 +# define faster_PUSHMARK(p) PUSHMARK(p) +#endif + #define RUNOPS_TILL(op) \\ -while (nextop != (op)) \\ - { \\ - PERL_ASYNC_CHECK (); \\ - PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ - } + 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; + for my $f (grep !$_->{so}, @func) { + next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others + + warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1; + my $source = $f->{source}; + $source =~ s/%%%FUNC%%%/$f->{func}/g; + print $fh $source; + $meta->{$f->{func}} = $f->{so} = $stem; + } + + close $fh; + system "$COMPILE -o $stem$_o $stem.c"; + unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0; + system "$LINK -o $stem$_so $stem$_o $LIBS"; + unlink "$stem$_o"; } - close FILE; - system "$COMPILE -o $stem$_o $stem.c"; - #d#unlink "$stem.c"; - system "$LINK -o $stem$_so $stem$_o $LIBS"; - unlink "$stem$_o"; + for my $f (@func) { + my $stem = $f->{so}; - my $so = DynaLoader::dl_load_file "$stem$_so" - or die "$stem$_so: $!"; + my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so") + or die "$stem$_so: $!"; - #unlink "$stem$_so"; + #unlink "$stem$_so"; + + $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func} + or die "$f->{func} not found in $stem$_so: $!"; + } - map +(DynaLoader::dl_find_symbol $so, $_), @source + seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!"; + Storable::nstore_fd $meta, $meta_fh; + truncate $meta_fh, tell $meta_fh; + + # UNLOCK (by closing $meta_fh) } my %ignore; @@ -545,12 +764,17 @@ return if $ignore{$pkg}; - warn "compiling ", $cv->STASH->NAME, "\n" + warn "optimising ", $cv->STASH->NAME, "\n" if $verbose; eval { - my @cv; - my @cv_source; + my @func; + + push @func, { + cv => $cv, + name => "<>", + source => cv2c $cv, + }; # always compile the whole stash my %stash = $cv->STASH->ARRAY; @@ -563,15 +787,19 @@ if ($cv->isa (B::CV::) && ${$cv->START} && $cv->START->name ne "null") { - push @cv, $cv; - push @cv_source, cv2c $cv; + + push @func, { + cv => $cv, + name => $k, + source => cv2c $cv, + }; } } - my @ptr = source2ptr @cv_source; + func2ptr @func; - for (0 .. $#cv) { - patch_cv $cv[$_], $ptr[$_]; + for my $f (@func) { + patch_cv $f->{cv}, $f->{ptr}; } }; @@ -596,24 +824,23 @@ =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. +than C<0>. Currently, C<1> outputs which packages are being compiled, C<3> +outputs the cache directory and C<10> outputs information on which perl +function is compiled into which shared object. =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. +adds 1-3 C's per perl op (FASTER_DEBUG > 1), 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. +Set a persistent cache directory that caches compiled code fragments. The +default is C<$HOME/.perl-faster-cache> if C is set and a temporary +directory otherwise. -This directory will always grow in contents, so you might need to erase it +This directory will always grow in size, so you might need to erase it from time to time. =back