cvsroot/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;

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 .= <<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 $targ = $op->targ;

   $source .= <<EOF;
  {
    dSP;
    XPUSHs (PAD_SV ((PADOFFSET)$targ));
    PUTBACK;
EOF
   if ($op->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 .= <<EOF;
  }
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)
          {
            XPUSHs (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;

   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 = <<EOF;
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]}L;
EOF

   while (@ops) {
      $op = shift @ops;
      $op_name = $op->name;

      my $class = B::class $op;

      $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 $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

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