Faster/Faster.pm

=head1 NAME

Faster - do some things faster

=head1 SYNOPSIS

 use Faster;

=head1 DESCRIPTION

=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";

our $source;
our $label_next;
our $label_last;
our $label_redo;

my @ops;
my $op;
my $op_name;

my %flag;

for (split /\n/, <<EOF) {
   leavesub     unsafe
   leavesublv   unsafe
   return       unsafe
   flip         unsafe
   goto         unsafe
   last         unsafe
   redo         unsafe
   next         unsafe
   eval         unsafe
   leaveeval    unsafe
   entertry     unsafe
   substconst   unsafe
   formline     unsafe
   grepstart    unsafe
   require      unsafe
   match        unsafe noasync  todo
   subst        unsafe noasync  todo
   entereval    unsafe noasync  todo
   mapstart     unsafe noasync  todo

   mapwhile     noasync
   grepwhile    noasync

   seq          noasync
   pushmark     noasync
   padsv        noasync extend=1
   padav        noasync extend=1
   padhv        noasync extend=1
   padany       noasync extend=1
   entersub     noasync
   aassign      noasync
   sassign      noasync
   rv2av        noasync
   rv2cv        noasync
   rv2gv        noasync
   rv2hv        noasync
   refgen       noasync
   nextstate    noasync
   gv           noasync
   gvsv         noasync
   add          noasync
   subtract     noasync
   multiply     noasync
   divide       noasync
   complement   noasync
   cond_expr    noasync
   and          noasync
   or           noasync
   not          noasync
   defined      noasync
   method_named noasync
   preinc       noasync
   postinc      noasync
   predec       noasync
   postdec      noasync
   stub         noasync
   unstack      noasync
   leaveloop    noasync
   aelem        noasync
   aelemfast    noasync 
   helem        noasync
   pushre       noasync
   const        noasync extend=1
   list         noasync
   join         noasync
   split        noasync
   concat       noasync
   push         noasync
   pop          noasync
   shift        noasync
   unshift      noasync
   require      noasync
   length       noasync
   substr       noasync
   stringify    noasync
   eq           noasync
   ne           noasync
   gt           noasync
   lt           noasync
   ge           noasync
   le           noasync
   enteriter    noasync

   iter         async
EOF
   my (undef, $op, @flags) = split /\s+/;

   undef $flag{$_}{$op}
      for ("known", @flags);
}

sub callop {
   $op_name eq "entersub"
      ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
      : $op_name eq "mapstart"
        ? "Perl_pp_grepstart (aTHX)"
        : "Perl_pp_$op_name (aTHX)"
}

sub out_gotonext {
   if (${$op->next}) {
      $source .= "  assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
      $source .= "  goto op_${$op->next};\n";
   } else {
      $source .= "  return 0;\n";
   }
}

sub out_next {
   $source .= "  nextop = (OP *)${$op->next}L;\n";

   out_gotonext;
}

sub out_linear {
   $source .= "  assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#
   $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
   if ($op_name eq "entersub") {
      $source .= <<EOF;
  while (nextop != (OP *)${$op->next}L)
    {
      PERL_ASYNC_CHECK ();
      PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
    }
EOF
   }

   out_gotonext;
}

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;
   };
}

sub op_stringify {
   $source .= "  { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";

   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_res;

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

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

        /* simple "polymorphic" inline cache */
        if (stash == last_stash)
          {
            XPUSHs (last_res);
            PUTBACK;
          }
        else
          {
            PL_op = nextop;
            nextop = Perl_pp_method_named (aTHX);

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

   out_next;
}

sub cv2c {
   my ($cv) = @_;

   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;
         if (B::class($op) eq "LOGOP") {
            push @todo, $op->other;
         } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
            push @todo, $op->pmreplstart;
         } elsif ($name =~ /^enter(loop|iter)$/) {
#            if ($] > 5.009) {
#               $labels{${$op->nextop}} = "NEXT";
#               $labels{${$op->lastop}} = "LAST";
#               $labels{${$op->redoop}} = "REDO";
#            } else {
#               $labels{$op->nextop->seq} = "NEXT";
#               $labels{$op->lastop->seq} = "LAST";
#               $labels{$op->redoop->seq} = "REDO";         
#            }
         }
      }
   }

   local $source = <<EOF;
#define PERL_NO_GET_CONTEXT

//#define NDEBUG 1
#include <assert.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

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#

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

      if (my $can = __PACKAGE__->can ("op_$op_name")) {
         $can->($op);
      } elsif (exists $flag{unsafe}{$op_name}) {
         $source .= "  assert ((\"$op_name\", nextop == (OP *)$$op));\n";
         $source .= "  return nextop;\n";
      } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
         $source .= "  assert ((\"$op_name\", nextop == (OP *)$$op));\n";
         $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
         $source .= "  if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
         $source .= "  assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
         $source .= ${$op->next} ? "  goto op_${$op->next};\n" : "  return 0;\n";
      } else {
         out_linear;
      }
   }

   $source .= "}\n";
   #warn $source;

   $source
}

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

   my $md5 = Digest::MD5::md5_hex $source;
   $source =~ s/%%%FUNC%%%/Faster_$md5/;

   my $stem = "/tmp/$md5";

   unless (-e "$stem$_so") {
      open FILE, ">:raw", "$stem.c";
      print FILE $source;
      close FILE;
      system "$COMPILE -o $stem$_o $stem.c";
      system "$LINK -o $stem$_so $stem$_o $LIBS";
   }

#   warn $source;
   my $so = DynaLoader::dl_load_file "$stem$_so"
      or die "$stem$_so: $!";

   DynaLoader::dl_find_symbol $so, "Faster_$md5"
      or die "Faster_$md5: $!"
}

sub entersub {
   my ($cv) = @_;

   eval {
      my $source = cv2c $cv;

       my $ptr = source2ptr $source;

       patch_cv $cv, $ptr;
   };

   warn $@ if $@;
}

hook_entersub;

1;

=back

=head1 LIMITATIONS

Tainting and debugging will disable Faster.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.9
Committed:	Fri Mar 10 01:55:12 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.8:	+9 -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			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15			package Faster;
16
17			use strict;
18	root	1.4	use Config;
19			use B ();
20			use Digest::MD5 ();
21			use DynaLoader ();
22	root	1.1
23			BEGIN {
24			our $VERSION = '0.01';
25
26			require XSLoader;
27			XSLoader::load __PACKAGE__, $VERSION;
28			}
29
30	root	1.4	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31			my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32			my $LIBS = "$Config{libs}";
33			my $_o = $Config{_o};
34			my $_so = ".so";
35	root	1.1
36			our $source;
37			our $label_next;
38			our $label_last;
39			our $label_redo;
40
41	root	1.8	my @ops;
42			my $op;
43			my $op_name;
44
45	root	1.2	my %flag;
46
47			for (split /\n/, <<EOF) {
48			leavesub unsafe
49			leavesublv unsafe
50			return unsafe
51			flip unsafe
52			goto unsafe
53			last unsafe
54			redo unsafe
55			next unsafe
56			eval unsafe
57			leaveeval unsafe
58			entertry unsafe
59			substconst unsafe
60			formline unsafe
61			grepstart unsafe
62	root	1.4	require unsafe
63	root	1.8	match unsafe noasync todo
64			subst unsafe noasync todo
65			entereval unsafe noasync todo
66			mapstart unsafe noasync todo
67
68			mapwhile noasync
69			grepwhile noasync
70	root	1.4
71	root	1.8	seq noasync
72	root	1.4	pushmark noasync
73	root	1.8	padsv noasync extend=1
74			padav noasync extend=1
75			padhv noasync extend=1
76			padany noasync extend=1
77	root	1.4	entersub noasync
78			aassign noasync
79			sassign noasync
80			rv2av noasync
81	root	1.8	rv2cv noasync
82			rv2gv noasync
83			rv2hv noasync
84			refgen noasync
85	root	1.4	nextstate noasync
86			gv noasync
87			gvsv noasync
88			add noasync
89			subtract noasync
90			multiply noasync
91			divide noasync
92			complement noasync
93			cond_expr noasync
94			and noasync
95			or noasync
96			not noasync
97	root	1.8	defined noasync
98	root	1.4	method_named noasync
99			preinc noasync
100			postinc noasync
101			predec noasync
102			postdec noasync
103			stub noasync
104			unstack noasync
105			leaveloop noasync
106	root	1.8	aelem noasync
107	root	1.4	aelemfast noasync
108	root	1.8	helem noasync
109			pushre noasync
110			const noasync extend=1
111			list noasync
112			join noasync
113			split noasync
114			concat noasync
115			push noasync
116			pop noasync
117			shift noasync
118			unshift noasync
119			require noasync
120			length noasync
121			substr noasync
122			stringify noasync
123			eq noasync
124			ne noasync
125			gt noasync
126			lt noasync
127			ge noasync
128			le noasync
129			enteriter noasync
130
131			iter async
132	root	1.2	EOF
133			my (undef, $op, @flags) = split /\s+/;
134
135			undef $flag{$_}{$op}
136			for ("known", @flags);
137			}
138
139	root	1.8	sub callop {
140			$op_name eq "entersub"
141			? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
142			: $op_name eq "mapstart"
143			? "Perl_pp_grepstart (aTHX)"
144			: "Perl_pp_$op_name (aTHX)"
145			}
146
147	root	1.9	sub out_gotonext {
148	root	1.5	if (${$op->next}) {
149	root	1.8	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
150	root	1.5	$source .= " goto op_${$op->next};\n";
151			} else {
152			$source .= " return 0;\n";
153			}
154	root	1.2	}
155
156	root	1.9	sub out_next {
157			$source .= " nextop = (OP *)${$op->next}L;\n";
158
159			out_gotonext;
160			}
161
162	root	1.8	sub out_linear {
163			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#
164			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
165			if ($op_name eq "entersub") {
166			$source .= <<EOF;
167			while (nextop != (OP *)${$op->next}L)
168			{
169			PERL_ASYNC_CHECK ();
170			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171			}
172			EOF
173			}
174	root	1.4
175	root	1.9	out_gotonext;
176	root	1.4	}
177
178	root	1.2	sub op_nextstate {
179	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
180	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
181			$source .= " FREETMPS;\n";
182
183	root	1.8	out_next;
184	root	1.2	}
185
186	root	1.3	sub op_pushmark {
187			$source .= " PUSHMARK (PL_stack_sp);\n";
188
189	root	1.8	out_next;
190	root	1.3	}
191
192	root	1.8	if ($Config{useithreads} ne "define") {
193			# disable optimisations on ithreads
194
195			*op_const = sub {
196			$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
197
198			out_next;
199			};
200
201			*op_gv = \&op_const;
202
203			*op_aelemfast = sub {
204			my $targ = $op->targ;
205			my $private = $op->private;
206
207			$source .= " {\n";
208
209			if ($op->flags & B::OPf_SPECIAL) {
210			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
211			} else {
212			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
213			}
214
215			if ($op->flags & B::OPf_MOD) {
216			$source .= " SV sv = av_fetch (av, $private, 1);\n";
217			} else {
218			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
219			}
220
221			if (!($op->flags & B::OPf_MOD)) {
222			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223			}
224
225			$source .= " dSP;\n";
226			$source .= " XPUSHs (sv);\n";
227			$source .= " PUTBACK;\n";
228			$source .= " }\n";
229
230			out_next;
231			};
232	root	1.2
233	root	1.8	*op_gvsv = sub {
234			$source .= " {\n";
235			$source .= " dSP;\n";
236			$source .= " EXTEND (SP, 1);\n";
237	root	1.2
238	root	1.8	if ($op->private & B::OPpLVAL_INTRO) {
239			$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240			} else {
241			$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
242			}
243
244			$source .= " PUTBACK;\n";
245			$source .= " }\n";
246
247			out_next;
248			};
249	root	1.2	}
250
251	root	1.3	sub op_stringify {
252			$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
253
254	root	1.8	out_next;
255	root	1.3	}
256
257	root	1.4	sub op_and {
258			$source .= <<EOF;
259			{
260			dSP;
261	root	1.5
262	root	1.4	if (SvTRUE (TOPs))
263			{
264			--SP;
265			PUTBACK;
266			nextop = (OP *)${$op->other}L;
267			goto op_${$op->other};
268			}
269			}
270			EOF
271	root	1.5
272	root	1.8	out_next;
273	root	1.4	}
274
275	root	1.7	sub op_or {
276			$source .= <<EOF;
277			{
278			dSP;
279
280			if (!SvTRUE (TOPs))
281			{
282			--SP;
283			PUTBACK;
284			nextop = (OP *)${$op->other}L;
285			goto op_${$op->other};
286			}
287			}
288			EOF
289
290	root	1.8	out_next;
291	root	1.7	}
292
293	root	1.4	sub op_padsv {
294			my $flags = $op->flags;
295			my $target = $op->targ;
296
297			$source .= <<EOF;
298			{
299			dSP;
300			XPUSHs (PAD_SV ((PADOFFSET)$target));
301			PUTBACK;
302			EOF
303			if ($op->flags & B::OPf_MOD) {
304			if ($op->private & B::OPpLVAL_INTRO) {
305			$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
306			} elsif ($op->private & B::OPpDEREF) {
307			my $deref = $op->private & B::OPpDEREF;
308			$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309			}
310			}
311			$source .= <<EOF;
312			}
313			EOF
314
315	root	1.8	out_next;
316	root	1.6	}
317
318	root	1.3	# pattern const+ (or general push1)
319			# pattern pushmark return(?)
320			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
321
322			# pattern const method_named
323	root	1.4	sub op_method_named {
324	root	1.3	$source .= <<EOF;
325			{
326	root	1.4	static HV *last_stash;
327			static SV *last_res;
328
329			SV obj = (PL_stack_base + TOPMARK + 1);
330	root	1.3
331	root	1.4	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
332	root	1.3	{
333	root	1.4	dSP;
334			HV *stash = SvSTASH (SvRV (obj));
335	root	1.3
336	root	1.4	/* simple "polymorphic" inline cache */
337	root	1.3	if (stash == last_stash)
338			{
339	root	1.4	XPUSHs (last_res);
340			PUTBACK;
341	root	1.3	}
342			else
343			{
344	root	1.4	PL_op = nextop;
345			nextop = Perl_pp_method_named (aTHX);
346
347	root	1.3	SPAGAIN;
348			last_stash = stash;
349			last_res = TOPs;
350			}
351			}
352	root	1.4	else
353			{
354			/* error case usually */
355			PL_op = nextop;
356			nextop = Perl_pp_method_named (aTHX);
357			}
358	root	1.3	}
359			EOF
360
361	root	1.8	out_next;
362	root	1.3	}
363
364	root	1.4	sub cv2c {
365	root	1.1	my ($cv) = @_;
366
367			my %opsseen;
368			my @todo = $cv->START;
369
370			while (my $op = shift @todo) {
371			for (; $$op; $op = $op->next) {
372			last if $opsseen{$$op}++;
373			push @ops, $op;
374			my $name = $op->name;
375			if (B::class($op) eq "LOGOP") {
376			push @todo, $op->other;
377			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
378			push @todo, $op->pmreplstart;
379			} elsif ($name =~ /^enter(loop\|iter)$/) {
380			# if ($] > 5.009) {
381			# $labels{${$op->nextop}} = "NEXT";
382			# $labels{${$op->lastop}} = "LAST";
383			# $labels{${$op->redoop}} = "REDO";
384			# } else {
385			# $labels{$op->nextop->seq} = "NEXT";
386			# $labels{$op->lastop->seq} = "LAST";
387			# $labels{$op->redoop->seq} = "REDO";
388			# }
389			}
390			}
391			}
392
393	root	1.4	local $source = <<EOF;
394			#define PERL_NO_GET_CONTEXT
395
396	root	1.8	//#define NDEBUG 1
397	root	1.4	#include <assert.h>
398
399			#include "EXTERN.h"
400			#include "perl.h"
401			#include "XSUB.h"
402	root	1.2
403	root	1.4	OP *%%%FUNC%%% (pTHX)
404			{
405			register OP nextop = (OP )${$ops[0]}L;
406			EOF
407	root	1.2
408	root	1.8	while (@ops) {
409			$op = shift @ops;
410			$op_name = $op->name;
411	root	1.2
412	root	1.8	$source .= "op_$$op: /* $op_name */\n";
413			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
414	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
415
416	root	1.8	unless (exists $flag{noasync}{$op_name}) {
417	root	1.4	$source .= " PERL_ASYNC_CHECK ();\n";
418			}
419	root	1.2
420	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
421	root	1.2	$can->($op);
422	root	1.8	} elsif (exists $flag{unsafe}{$op_name}) {
423			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
424	root	1.9	$source .= " return nextop;\n";
425	root	1.8	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
426			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
427	root	1.4	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
428			$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
429	root	1.8	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
430	root	1.5	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
431	root	1.2	} else {
432	root	1.8	out_linear;
433	root	1.2	}
434	root	1.1	}
435	root	1.2
436			$source .= "}\n";
437	root	1.4	#warn $source;
438	root	1.2
439	root	1.4	$source
440			}
441
442			sub source2ptr {
443			my ($source) = @_;
444
445			my $md5 = Digest::MD5::md5_hex $source;
446			$source =~ s/%%%FUNC%%%/Faster_$md5/;
447
448			my $stem = "/tmp/$md5";
449
450			unless (-e "$stem$_so") {
451			open FILE, ">:raw", "$stem.c";
452			print FILE $source;
453			close FILE;
454			system "$COMPILE -o $stem$_o $stem.c";
455			system "$LINK -o $stem$_so $stem$_o $LIBS";
456			}
457
458			# warn $source;
459			my $so = DynaLoader::dl_load_file "$stem$_so"
460			or die "$stem$_so: $!";
461
462			DynaLoader::dl_find_symbol $so, "Faster_$md5"
463			or die "Faster_$md5: $!"
464			}
465
466			sub entersub {
467			my ($cv) = @_;
468
469			eval {
470			my $source = cv2c $cv;
471
472			my $ptr = source2ptr $source;
473
474			patch_cv $cv, $ptr;
475			};
476
477			warn $@ if $@;
478	root	1.1	}
479
480			hook_entersub;
481
482			1;
483
484			=back
485
486	root	1.2	=head1 LIMITATIONS
487
488			Tainting and debugging will disable Faster.
489
490	root	1.1	=head1 AUTHOR
491
492			Marc Lehmann <schmorp@schmorp.de>
493			http://home.schmorp.de/
494
495			=cut
496