Faster/Faster.pm

=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<use Faster> 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</tmp>, and it will even create those temporary files in an insecure
manner, so watch out.

=over 4

=cut

package Faster;

no warnings;

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 $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
   eval flip leaveeval entertry
   formline grepstart mapstart
   substcont entereval require
);

# 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

   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 method_named bless
   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; PUSHs ((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 .= "    PUSHs (sv);\n";
      $source .= "    PUTBACK;\n";
      $source .= "  }\n";

      out_next;
   };

   *op_gvsv = sub {
      $source .= "  {\n";
      $source .= "    dSP;\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 .= <<EOF;
  {
    dSP;
    SV *targ = PAD_SV ((PADOFFSET)$targ);
    sv_copypv (TARG, TOPs);
    SETTARG;
    PUTBACK;
  }
EOF

   out_next;
}

sub op_and {
   $source .= <<EOF;
  {
    dSP;

    if (SvTRUE (TOPs))
      {
        --SP;
        PUTBACK;
        nextop = (OP *)${$op->other}L;
        goto op_${$op->other};
      }
  }
EOF

   out_next;
}

sub op_or {
   $source .= <<EOF;
  {
    dSP;

    if (!SvTRUE (TOPs))
      {
        --SP;
        PUTBACK;
        nextop = (OP *)${$op->other}L;
        goto op_${$op->other};
      }
  }
EOF

   out_next;
}

sub op_padsv {
   my $flags = $op->flags;
   my $padofs = "(PADOFFSET)" . $op->targ;

   #d#TODO: why does our version break
   if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
      return out_linear;#d#
   }#d#

   $source .= <<EOF;
  {
    dSP;
    SV *sv = PAD_SVl ($padofs);
EOF

   if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
      $source .= "    SAVECLEARSV (PAD_SVl ($padofs));\n";
      $ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
   }
         
   $source .= <<EOF;
    PUSHs (sv);
    PUTBACK;
EOF

   if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
      $source .= "    vivify_ref (sv, $flags & OPpDEREF);\n";
   }
   $source .= "  }\n";

   out_next;
}

sub op_sassign {
  $source .= <<EOF;
  {
    dSP;
    dPOPTOPssrl;
EOF
   $source .= "    SV *temp = left; left = right; right = temp;\n"
      if $op->private & B::OPpASSIGN_BACKWARDS;

   if ($insn->{pre_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 .= <<EOF;
    SETs (right);
    PUTBACK;
  }
EOF

  out_next;
}

# pattern const+ (or general push1)
# pattern pushmark return(?)
# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign

# pattern const method_named
sub op_method_named {
   $source .= <<EOF;
  {
    static HV *last_stash;
    static SV *last_cv;
    static U32 last_sub_generation;

    SV *obj = *(PL_stack_base + TOPMARK + 1);

    if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
      {
        dSP;
        HV *stash = SvSTASH (SvRV (obj));

        /* simple "polymorphic" inline cache */
        if (stash == last_stash
            && PL_sub_generation == last_sub_generation)
          {
            PUSHs (last_cv);
            PUTBACK;
          }
        else
          {
            PL_op = nextop; nextop = Perl_pp_method_named (aTHX);

            SPAGAIN;
            last_sub_generation = PL_sub_generation;
            last_stash          = stash;
            last_cv             = TOPs;
          }
      }
    else
      {
        /* error case usually */
        PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
      }
  }
EOF

   out_next;
}

sub op_grepstart {
   out_callop;
   $op = $op->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;
   my %op_target;

   while (my $op = shift @todo) {
      for (; $$op; $op = $op->next) {
         last if $opsseen{$$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") {
            push @todo, $op->other;
            $op_target{${$op->other}}++;

            # regcomp/o patches ops at runtime, lets expect that
            if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
               $op_target{${$op->first}}++;
               $op_regcomp{${$op->first}} = $op->next;
            }

         } elsif ($class eq "PMOP") {
            if (${$op->pmreplstart}) {
               unshift @todo, $op->pmreplstart;
               $op_target{${$op->pmreplstart}}++;
            }

         } elsif ($class eq "LOOP") {
            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;
         }
      }
   }

   $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;

   local $source = <<EOF;
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]->{op}}L;
EOF

   while (@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#

      $source .= "  PERL_ASYNC_CHECK ();\n"
         unless exists $f_noasync{$op_name};

      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}) {
         # unsafe, return to interpreter
         assert "nextop == (OP *)$$op";
         $source .= "  return nextop;\n";

      } elsif ("LOGOP" eq $class) {
         # logical operation with optional branch
         out_callop;
         out_cond_jump $op->other;
         out_jump_next;

      } elsif ("PMOP" eq $class) {
         # regex-thingy
         out_callop;
         out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
         out_jump_next;

      } else {
         # normal operator, linear execution
         out_linear;
      }
   }

   $op_name = "func exit"; assert (0);

   $source .= <<EOF;
op_0:
  return 0;
}
EOF
   #warn $source;

   $source
}

my $uid = "aaaaaaa0";

sub source2ptr {
   my (@source) = @_;

   my $stem = "/tmp/Faster-$$-" . $uid++;

   open FILE, ">:raw", "$stem.c";
   print FILE <<EOF;
#define PERL_NO_GET_CONTEXT
#define PERL_CORE

#include <assert.h>

#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<assert>'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 <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.24
Committed:	Sat Mar 11 04:53:00 2006 UTC (18 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.23:	+151 -30 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Faster - do some things faster
4
5			=head1 SYNOPSIS
6
7			use Faster;
8
9	root	1.18	perl -MFaster ...
10
11	root	1.1	=head1 DESCRIPTION
12
13	root	1.18	This module implements a very simple-minded JIT. It works by more or less
14			translating every function it sees into a C program, compiling it and then
15			replacing the function by the compiled code.
16
17			As a result, startup times are immense, as every function might lead to a
18			full-blown compilation.
19
20			The speed improvements are also not great, you can expect 20% or so on
21			average, for code that runs very often.
22
23			Faster is in the early stages of development. Due to its design its
24			relatively safe to use (it will either work or simply slowdown the program
25			immensely, but rarely cause bugs).
26
27			Usage is very easy, just C<use Faster> and every function called from then
28			on will be compiled.
29
30	root	1.19	Right now, Faster will leave lots of F<.c>, F<.o> and F<*.so> files in
31	root	1.18	F</tmp>, and it will even create those temporary files in an insecure
32			manner, so watch out.
33
34	root	1.1	=over 4
35
36			=cut
37
38			package Faster;
39
40	root	1.24	no warnings;
41
42	root	1.1	use strict;
43	root	1.4	use Config;
44			use B ();
45	root	1.19	#use Digest::MD5 ();
46	root	1.4	use DynaLoader ();
47	root	1.22	use File::Temp ();
48	root	1.1
49			BEGIN {
50			our $VERSION = '0.01';
51
52			require XSLoader;
53			XSLoader::load __PACKAGE__, $VERSION;
54			}
55
56	root	1.4	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
57			my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
58			my $LIBS = "$Config{libs}";
59			my $_o = $Config{_o};
60			my $_so = ".so";
61	root	1.1
62	root	1.13	# we don't need no steenking PIC on x86
63			$COMPILE =~ s/-f(?:PIC\|pic)//g
64			if $Config{archname} =~ /^(i[3456]86)-/;
65
66	root	1.21	my $opt_assert = $ENV{FASTER_DEBUG};
67			my $verbose = $ENV{FASTER_VERBOSE}+0;
68	root	1.11
69	root	1.1	our $source;
70
71	root	1.18	our @ops;
72	root	1.24	our $insn;
73	root	1.18	our $op;
74			our $op_name;
75			our @op_loop;
76			our %op_regcomp;
77	root	1.8
78	root	1.24	# ops that cause immediate return to the interpreter
79	root	1.20	my %f_unsafe = map +($_ => undef), qw(
80			leavesub leavesublv return
81			goto last redo next
82			eval flip leaveeval entertry
83			formline grepstart mapstart
84			substcont entereval require
85			);
86	root	1.2
87	root	1.24	# ops with known stack extend behaviour
88			# the values given are maximum values
89			my %extend = (
90			pushmark => 0,
91			nextstate => 0, # might reduce the stack
92			unstack => 0,
93			enter => 0,
94
95			stringify => 0,
96			not => 0,
97			and => 0,
98			or => 0,
99			gvsv => 0,
100			rv2gv => 0,
101			preinc => 0,
102			predec => 0,
103			postinc => 0,
104			postdec => 0,
105			aelem => 0,
106			helem => 0,
107			qr => 1, #???
108			pushre => 1,
109			gv => 1,
110			aelemfast => 1,
111			aelem => 0,
112			padsv => 1,
113			const => 1,
114			pop => 1,
115			shift => 1,
116			eq => -1,
117			ne => -1,
118			gt => -1,
119			lt => -1,
120			ge => -1,
121			lt => -1,
122			cond_expr => -1,
123			add => -1,
124			subtract => -1,
125			multiply => -1,
126			divide => -1,
127			aassign => 0,
128			sassign => -2,
129			method => 0,
130			method_named => 1,
131			);
132	root	1.20
133	root	1.24	# ops that do not need an ASYNC_CHECK
134	root	1.20	my %f_noasync = map +($_ => undef), qw(
135			mapstart grepstart match entereval
136			enteriter entersub leaveloop
137
138			pushmark nextstate
139
140			const stub unstack
141			last next redo seq
142			padsv padav padhv padany
143			aassign sassign orassign
144			rv2av rv2cv rv2gv rv2hv refgen
145			gv gvsv
146			add subtract multiply divide
147			complement cond_expr and or not
148			defined
149	root	1.24	method method_named bless
150	root	1.20	preinc postinc predec postdec
151			aelem aelemfast helem delete exists
152			pushre subst list join split concat
153			length substr stringify ord
154			push pop shift unshift
155			eq ne gt lt ge le
156			regcomp regcreset regcmaybe
157			);
158	root	1.2
159	root	1.11	my %callop = (
160			entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
161			mapstart => "Perl_pp_grepstart (aTHX)",
162			);
163
164	root	1.8	sub callop {
165	root	1.11	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
166			}
167
168			sub assert {
169			return unless $opt_assert;
170			$source .= " assert ((\"$op_name\", ($_[0])));\n";
171			}
172
173			sub out_callop {
174			assert "nextop == (OP *)$$op";
175			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
176	root	1.8	}
177
178	root	1.18	sub out_cond_jump {
179			$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180			}
181
182	root	1.11	sub out_jump_next {
183	root	1.18	out_cond_jump $op_regcomp{$$op}
184			if $op_regcomp{$$op};
185
186	root	1.11	assert "nextop == (OP *)${$op->next}";
187			$source .= " goto op_${$op->next};\n";
188	root	1.2	}
189
190	root	1.9	sub out_next {
191			$source .= " nextop = (OP *)${$op->next}L;\n";
192
193	root	1.11	out_jump_next;
194	root	1.9	}
195
196	root	1.8	sub out_linear {
197	root	1.11	out_callop;
198			out_jump_next;
199			}
200
201			sub op_entersub {
202			out_callop;
203			$source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
204			out_jump_next;
205	root	1.4	}
206
207	root	1.11	*op_require = \&op_entersub;
208
209	root	1.2	sub op_nextstate {
210	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
211	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
212			$source .= " FREETMPS;\n";
213
214	root	1.8	out_next;
215	root	1.2	}
216
217	root	1.3	sub op_pushmark {
218			$source .= " PUSHMARK (PL_stack_sp);\n";
219
220	root	1.8	out_next;
221	root	1.3	}
222
223	root	1.13	if ($Config{useithreads} ne "define") {
224	root	1.8	# disable optimisations on ithreads
225
226			*op_const = sub {
227	root	1.24	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
228	root	1.8
229			out_next;
230			};
231
232			*op_gv = \&op_const;
233
234			*op_aelemfast = sub {
235			my $targ = $op->targ;
236			my $private = $op->private;
237
238			$source .= " {\n";
239
240			if ($op->flags & B::OPf_SPECIAL) {
241			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
242			} else {
243			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
244			}
245
246			if ($op->flags & B::OPf_MOD) {
247			$source .= " SV sv = av_fetch (av, $private, 1);\n";
248			} else {
249			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
250			}
251
252			if (!($op->flags & B::OPf_MOD)) {
253			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
254			}
255
256			$source .= " dSP;\n";
257	root	1.24	$source .= " PUSHs (sv);\n";
258	root	1.8	$source .= " PUTBACK;\n";
259			$source .= " }\n";
260
261			out_next;
262			};
263	root	1.2
264	root	1.8	*op_gvsv = sub {
265			$source .= " {\n";
266			$source .= " dSP;\n";
267	root	1.2
268	root	1.8	if ($op->private & B::OPpLVAL_INTRO) {
269			$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
270			} else {
271			$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
272			}
273
274			$source .= " PUTBACK;\n";
275			$source .= " }\n";
276
277			out_next;
278			};
279	root	1.2	}
280
281	root	1.12	# does kill Crossfire/res2pm
282			sub op_stringify {
283			my $targ = $op->targ;
284
285			$source .= <<EOF;
286			{
287			dSP;
288			SV *targ = PAD_SV ((PADOFFSET)$targ);
289			sv_copypv (TARG, TOPs);
290			SETTARG;
291			PUTBACK;
292			}
293			EOF
294	root	1.3
295	root	1.8	out_next;
296	root	1.3	}
297
298	root	1.4	sub op_and {
299			$source .= <<EOF;
300			{
301			dSP;
302	root	1.5
303	root	1.4	if (SvTRUE (TOPs))
304			{
305			--SP;
306			PUTBACK;
307			nextop = (OP *)${$op->other}L;
308			goto op_${$op->other};
309			}
310			}
311			EOF
312	root	1.5
313	root	1.8	out_next;
314	root	1.4	}
315
316	root	1.7	sub op_or {
317			$source .= <<EOF;
318			{
319			dSP;
320
321			if (!SvTRUE (TOPs))
322			{
323			--SP;
324			PUTBACK;
325			nextop = (OP *)${$op->other}L;
326			goto op_${$op->other};
327			}
328			}
329			EOF
330
331	root	1.8	out_next;
332	root	1.7	}
333
334	root	1.4	sub op_padsv {
335			my $flags = $op->flags;
336	root	1.24	my $padofs = "(PADOFFSET)" . $op->targ;
337
338			#d#TODO: why does our version break
339			if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
340			return out_linear;#d#
341			}#d#
342	root	1.4
343			$source .= <<EOF;
344			{
345			dSP;
346	root	1.24	SV *sv = PAD_SVl ($padofs);
347			EOF
348
349			if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
350			$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
351			$ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
352			}
353
354			$source .= <<EOF;
355			PUSHs (sv);
356	root	1.4	PUTBACK;
357			EOF
358	root	1.24
359			if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
360			$source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
361			}
362			$source .= " }\n";
363
364			out_next;
365			}
366
367			sub op_sassign {
368			$source .= <<EOF;
369			{
370			dSP;
371			dPOPTOPssrl;
372			EOF
373			$source .= " SV *temp = left; left = right; right = temp;\n"
374			if $op->private & B::OPpASSIGN_BACKWARDS;
375
376			if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
377			# simple assignment - the target exists, but is basically undef
378			$source .= " SvSetSV (right, left);\n";
379			} else {
380			$source .= " SvSetMagicSV (right, left);\n";
381	root	1.4	}
382	root	1.24
383	root	1.4	$source .= <<EOF;
384	root	1.24	SETs (right);
385			PUTBACK;
386	root	1.4	}
387			EOF
388
389	root	1.24	out_next;
390	root	1.6	}
391
392	root	1.3	# pattern const+ (or general push1)
393			# pattern pushmark return(?)
394			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
395
396			# pattern const method_named
397	root	1.12	sub op_method_named {
398	root	1.3	$source .= <<EOF;
399			{
400	root	1.4	static HV *last_stash;
401	root	1.11	static SV *last_cv;
402			static U32 last_sub_generation;
403	root	1.4
404			SV obj = (PL_stack_base + TOPMARK + 1);
405	root	1.3
406	root	1.11	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
407	root	1.3	{
408	root	1.4	dSP;
409			HV *stash = SvSTASH (SvRV (obj));
410	root	1.3
411	root	1.4	/* simple "polymorphic" inline cache */
412	root	1.11	if (stash == last_stash
413			&& PL_sub_generation == last_sub_generation)
414	root	1.3	{
415	root	1.24	PUSHs (last_cv);
416	root	1.4	PUTBACK;
417	root	1.3	}
418			else
419			{
420	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
421	root	1.4
422	root	1.3	SPAGAIN;
423	root	1.11	last_sub_generation = PL_sub_generation;
424			last_stash = stash;
425			last_cv = TOPs;
426	root	1.3	}
427			}
428	root	1.4	else
429			{
430			/* error case usually */
431	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
432	root	1.4	}
433	root	1.3	}
434			EOF
435
436	root	1.8	out_next;
437	root	1.3	}
438
439	root	1.11	sub op_grepstart {
440			out_callop;
441	root	1.14	$op = $op->next;
442			out_cond_jump $op->other;
443	root	1.11	out_jump_next;
444			}
445
446			*op_mapstart = \&op_grepstart;
447
448			sub op_substcont {
449			out_callop;
450			out_cond_jump $op->other->pmreplstart;
451			assert "nextop == (OP *)${$op->other->next}L";
452			$source .= " goto op_${$op->other->next};\n";
453			}
454
455			sub out_break_op {
456			my ($idx) = @_;
457
458			out_callop;
459
460			out_cond_jump $_->[$idx]
461	root	1.18	for reverse @op_loop;
462	root	1.11
463			$source .= " return nextop;\n";
464			}
465
466			sub xop_next {
467			out_break_op 0;
468			}
469
470			sub op_last {
471			out_break_op 1;
472			}
473
474			sub xop_redo {
475			out_break_op 2;
476			}
477
478	root	1.4	sub cv2c {
479	root	1.1	my ($cv) = @_;
480
481	root	1.18	local @ops;
482			local @op_loop;
483			local %op_regcomp;
484	root	1.11
485	root	1.1	my %opsseen;
486			my @todo = $cv->START;
487	root	1.24	my %op_target;
488	root	1.1
489			while (my $op = shift @todo) {
490			for (; $$op; $op = $op->next) {
491			last if $opsseen{$$op}++;
492	root	1.11
493	root	1.1	my $name = $op->name;
494	root	1.11	my $class = B::class $op;
495
496	root	1.24	my $insn = { op => $op };
497
498			push @ops, $insn;
499
500			if (exists $extend{$name}) {
501			my $extend = $extend{$name};
502			$extend = $extend->($op) if ref $extend;
503			$insn->{extend} = $extend if defined $extend;
504			}
505
506			push @todo, $op->next;
507
508	root	1.11	if ($class eq "LOGOP") {
509	root	1.24	push @todo, $op->other;
510			$op_target{${$op->other}}++;
511	root	1.18
512			# regcomp/o patches ops at runtime, lets expect that
513	root	1.24	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
514			$op_target{${$op->first}}++;
515			$op_regcomp{${$op->first}} = $op->next;
516			}
517	root	1.18
518	root	1.11	} elsif ($class eq "PMOP") {
519	root	1.24	if (${$op->pmreplstart}) {
520			unshift @todo, $op->pmreplstart;
521			$op_target{${$op->pmreplstart}}++;
522			}
523	root	1.18
524	root	1.11	} elsif ($class eq "LOOP") {
525	root	1.24	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
526
527			push @op_loop, \@targ;
528			push @todo, @targ;
529
530			$op_target{$$_}++ for @targ;
531			} elsif ($class eq "COP") {
532			$insn->{bblock}++ if defined $op->label;
533	root	1.1	}
534			}
535			}
536
537	root	1.24	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
538
539	root	1.4	local $source = <<EOF;
540			OP *%%%FUNC%%% (pTHX)
541			{
542	root	1.24	register OP nextop = (OP )${$ops[0]->{op}}L;
543	root	1.4	EOF
544	root	1.2
545	root	1.8	while (@ops) {
546	root	1.24	$insn = shift @ops;
547
548			$op = $insn->{op};
549	root	1.8	$op_name = $op->name;
550	root	1.2
551	root	1.23	my $class = B::class $op;
552
553	root	1.24	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
554	root	1.8	$source .= "op_$$op: /* $op_name */\n";
555			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
556	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
557
558	root	1.11	$source .= " PERL_ASYNC_CHECK ();\n"
559	root	1.20	unless exists $f_noasync{$op_name};
560	root	1.2
561	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
562	root	1.11	# handcrafted replacement
563	root	1.24
564			if ($insn->{extend} > 0) {
565			# coalesce EXTENDs
566			# TODO: properly take negative preceeding and following EXTENDs into account
567			for my $i (@ops) {
568			last if exists $i->{bblock};
569			last unless exists $i->{extend};
570			my $extend = delete $i->{extend};
571			$insn->{extend} += $extend if $extend > 0;
572			}
573
574			$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
575			if $insn->{extend} > 0;
576			}
577
578	root	1.2	$can->($op);
579	root	1.11
580	root	1.20	} elsif (exists $f_unsafe{$op_name}) {
581	root	1.11	# unsafe, return to interpreter
582			assert "nextop == (OP *)$$op";
583	root	1.9	$source .= " return nextop;\n";
584	root	1.11
585	root	1.23	} elsif ("LOGOP" eq $class) {
586			# logical operation with optional branch
587	root	1.11	out_callop;
588			out_cond_jump $op->other;
589			out_jump_next;
590
591	root	1.23	} elsif ("PMOP" eq $class) {
592	root	1.11	# regex-thingy
593			out_callop;
594	root	1.23	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
595	root	1.11	out_jump_next;
596
597	root	1.2	} else {
598	root	1.11	# normal operator, linear execution
599	root	1.8	out_linear;
600	root	1.2	}
601	root	1.1	}
602	root	1.2
603	root	1.11	$op_name = "func exit"; assert (0);
604
605			$source .= <<EOF;
606			op_0:
607			return 0;
608			}
609			EOF
610	root	1.4	#warn $source;
611	root	1.2
612	root	1.4	$source
613			}
614
615	root	1.19	my $uid = "aaaaaaa0";
616
617	root	1.4	sub source2ptr {
618	root	1.19	my (@source) = @_;
619	root	1.4
620	root	1.19	my $stem = "/tmp/Faster-$$-" . $uid++;
621	root	1.4
622	root	1.19	open FILE, ">:raw", "$stem.c";
623			print FILE <<EOF;
624	root	1.11	#define PERL_NO_GET_CONTEXT
625	root	1.24	#define PERL_CORE
626	root	1.11
627			#include <assert.h>
628
629			#include "EXTERN.h"
630			#include "perl.h"
631			#include "XSUB.h"
632
633			#define RUNOPS_TILL(op) \\
634	root	1.19	while (nextop != (op)) \\
635			{ \\
636			PERL_ASYNC_CHECK (); \\
637			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
638			}
639	root	1.11
640			EOF
641	root	1.19	for (@source) {
642			my $func = $uid++;
643			$_ =~ s/%%%FUNC%%%/$func/g;
644			print FILE $_;
645			$_ = $func;
646	root	1.4	}
647
648	root	1.19	close FILE;
649			system "$COMPILE -o $stem$_o $stem.c";
650			#d#unlink "$stem.c";
651			system "$LINK -o $stem$_so $stem$_o $LIBS";
652			unlink "$stem$_o";
653
654	root	1.4	my $so = DynaLoader::dl_load_file "$stem$_so"
655			or die "$stem$_so: $!";
656
657	root	1.19	#unlink "$stem$_so";
658
659			map +(DynaLoader::dl_find_symbol $so, $_), @source
660	root	1.4	}
661
662	root	1.19	my %ignore;
663
664	root	1.4	sub entersub {
665			my ($cv) = @_;
666
667	root	1.19	my $pkg = $cv->STASH->NAME;
668
669			return if $ignore{$pkg};
670
671	root	1.21	warn "compiling ", $cv->STASH->NAME, "\n"
672			if $verbose;
673	root	1.11
674	root	1.4	eval {
675	root	1.19	my @cv;
676			my @cv_source;
677	root	1.4
678	root	1.19	# always compile the whole stash
679			my %stash = $cv->STASH->ARRAY;
680			while (my ($k, $v) = each %stash) {
681			$v->isa (B::GV::)
682			or next;
683
684			my $cv = $v->CV;
685
686			if ($cv->isa (B::CV::)
687			&& ${$cv->START}
688			&& $cv->START->name ne "null") {
689			push @cv, $cv;
690			push @cv_source, cv2c $cv;
691			}
692			}
693
694			my @ptr = source2ptr @cv_source;
695	root	1.4
696	root	1.19	for (0 .. $#cv) {
697			patch_cv $cv[$_], $ptr[$_];
698			}
699	root	1.4	};
700
701	root	1.19	if ($@) {
702			$ignore{$pkg}++;
703			warn $@;
704			}
705	root	1.1	}
706
707			hook_entersub;
708
709			1;
710
711			=back
712
713	root	1.21	=head1 ENVIRONMENT VARIABLES
714
715			The following environment variables influence the behaviour of Faster:
716
717			=over 4
718
719			=item FASTER_VERBOSE
720
721			Faster will output more informational messages when set to values higher
722			than C<0>. Currently, C<1> outputs which packages are being compiled.
723
724			=item FASTER_DEBUG
725
726			Add debugging code when set to values higher than C<0>. Currently, this
727			adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
728			execution order are compatible.
729
730			=item FASTER_CACHE
731
732			NOT YET IMPLEMENTED
733
734			Set a persistent cache directory that caches compiled code
735			fragments. Normally, code compiled by Faster will be deleted immediately,
736			and every restart will recompile everything. Setting this variable to a
737			directory makes Faster cache the generated files for re-use.
738
739			This directory will always grow in contents, so you might need to erase it
740			from time to time.
741
742			=back
743
744	root	1.11	=head1 BUGS/LIMITATIONS
745
746			Perl will check much less often for asynchronous signals in
747			Faster-compiled code. It tries to check on every function call, loop
748			iteration and every I/O operator, though.
749
750			The following things will disable Faster. If you manage to enable them at
751	root	1.19	runtime, bad things will happen. Enabling them at startup will be fine,
752			though.
753	root	1.11
754			enabled tainting
755			enabled debugging
756
757	root	1.19	Thread-enabled builds of perl will dramatically reduce Faster's
758			performance, but you don't care about speed if you enable threads anyway.
759	root	1.11
760	root	1.19	These constructs will force the use of the interpreter for the currently
761			executed function as soon as they are being encountered during execution.
762	root	1.11
763			goto
764			next, redo (but not well-behaved last's)
765			eval
766			require
767			any use of formats
768	root	1.19	.., ... (flipflop operators)
769	root	1.2
770	root	1.1	=head1 AUTHOR
771
772			Marc Lehmann <schmorp@schmorp.de>
773			http://home.schmorp.de/
774
775			=cut
776