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 ();

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

   $source .= <<EOF;
  {
    dSP;
    XPUSHs (PAD_SV ((PADOFFSET)$target));
    PUTBACK;
EOF
   if ($op->flags & B::OPf_MOD) {
      if ($op->private & B::OPpLVAL_INTRO) {
         $source .= "    SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
      } elsif ($op->private & B::OPpDEREF) {
         my $deref = $op->private & B::OPpDEREF;
         $source .= "    Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $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;

      $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 .= <<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;#d#

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