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_next {
   if (${$op->next}) {
      $source .= "  nextop = (OP *)${$op->next}L;\n";
      $source .= "  assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
      $source .= "  goto op_${$op->next};\n";
   } else {
      $source .= "  return 0;\n";
   }
}

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

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 .= "  PL_op = nextop; return " . (callop $op) . ";\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.8
Committed:	Fri Mar 10 01:51:14 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.7:	+144 -105 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.2	sub out_next {
148	root	1.5	if (${$op->next}) {
149			$source .= " nextop = (OP *)${$op->next}L;\n";
150	root	1.8	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
151	root	1.5	$source .= " goto op_${$op->next};\n";
152			} else {
153			$source .= " return 0;\n";
154			}
155	root	1.2	}
156
157	root	1.8	sub out_linear {
158			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#
159			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160			if ($op_name eq "entersub") {
161			$source .= <<EOF;
162			while (nextop != (OP *)${$op->next}L)
163			{
164			PERL_ASYNC_CHECK ();
165			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
166			}
167			EOF
168			}
169	root	1.4
170	root	1.8	out_next;
171	root	1.4	}
172
173	root	1.2	sub op_nextstate {
174	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
175	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
176			$source .= " FREETMPS;\n";
177
178	root	1.8	out_next;
179	root	1.2	}
180
181	root	1.3	sub op_pushmark {
182			$source .= " PUSHMARK (PL_stack_sp);\n";
183
184	root	1.8	out_next;
185	root	1.3	}
186
187	root	1.8	if ($Config{useithreads} ne "define") {
188			# disable optimisations on ithreads
189
190			*op_const = sub {
191			$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
192
193			out_next;
194			};
195
196			*op_gv = \&op_const;
197
198			*op_aelemfast = sub {
199			my $targ = $op->targ;
200			my $private = $op->private;
201
202			$source .= " {\n";
203
204			if ($op->flags & B::OPf_SPECIAL) {
205			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
206			} else {
207			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
208			}
209
210			if ($op->flags & B::OPf_MOD) {
211			$source .= " SV sv = av_fetch (av, $private, 1);\n";
212			} else {
213			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
214			}
215
216			if (!($op->flags & B::OPf_MOD)) {
217			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
218			}
219
220			$source .= " dSP;\n";
221			$source .= " XPUSHs (sv);\n";
222			$source .= " PUTBACK;\n";
223			$source .= " }\n";
224
225			out_next;
226			};
227	root	1.2
228	root	1.8	*op_gvsv = sub {
229			$source .= " {\n";
230			$source .= " dSP;\n";
231			$source .= " EXTEND (SP, 1);\n";
232	root	1.2
233	root	1.8	if ($op->private & B::OPpLVAL_INTRO) {
234			$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
235			} else {
236			$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
237			}
238
239			$source .= " PUTBACK;\n";
240			$source .= " }\n";
241
242			out_next;
243			};
244	root	1.2	}
245
246	root	1.3	sub op_stringify {
247			$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
248
249	root	1.8	out_next;
250	root	1.3	}
251
252	root	1.4	sub op_and {
253			$source .= <<EOF;
254			{
255			dSP;
256	root	1.5
257	root	1.4	if (SvTRUE (TOPs))
258			{
259			--SP;
260			PUTBACK;
261			nextop = (OP *)${$op->other}L;
262			goto op_${$op->other};
263			}
264			}
265			EOF
266	root	1.5
267	root	1.8	out_next;
268	root	1.4	}
269
270	root	1.7	sub op_or {
271			$source .= <<EOF;
272			{
273			dSP;
274
275			if (!SvTRUE (TOPs))
276			{
277			--SP;
278			PUTBACK;
279			nextop = (OP *)${$op->other}L;
280			goto op_${$op->other};
281			}
282			}
283			EOF
284
285	root	1.8	out_next;
286	root	1.7	}
287
288	root	1.4	sub op_padsv {
289			my $flags = $op->flags;
290			my $target = $op->targ;
291
292			$source .= <<EOF;
293			{
294			dSP;
295			XPUSHs (PAD_SV ((PADOFFSET)$target));
296			PUTBACK;
297			EOF
298			if ($op->flags & B::OPf_MOD) {
299			if ($op->private & B::OPpLVAL_INTRO) {
300			$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
301			} elsif ($op->private & B::OPpDEREF) {
302			my $deref = $op->private & B::OPpDEREF;
303			$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
304			}
305			}
306			$source .= <<EOF;
307			}
308			EOF
309
310	root	1.8	out_next;
311	root	1.6	}
312
313	root	1.3	# pattern const+ (or general push1)
314			# pattern pushmark return(?)
315			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
316
317			# pattern const method_named
318	root	1.4	sub op_method_named {
319	root	1.3	$source .= <<EOF;
320			{
321	root	1.4	static HV *last_stash;
322			static SV *last_res;
323
324			SV obj = (PL_stack_base + TOPMARK + 1);
325	root	1.3
326	root	1.4	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
327	root	1.3	{
328	root	1.4	dSP;
329			HV *stash = SvSTASH (SvRV (obj));
330	root	1.3
331	root	1.4	/* simple "polymorphic" inline cache */
332	root	1.3	if (stash == last_stash)
333			{
334	root	1.4	XPUSHs (last_res);
335			PUTBACK;
336	root	1.3	}
337			else
338			{
339	root	1.4	PL_op = nextop;
340			nextop = Perl_pp_method_named (aTHX);
341
342	root	1.3	SPAGAIN;
343			last_stash = stash;
344			last_res = TOPs;
345			}
346			}
347	root	1.4	else
348			{
349			/* error case usually */
350			PL_op = nextop;
351			nextop = Perl_pp_method_named (aTHX);
352			}
353	root	1.3	}
354			EOF
355
356	root	1.8	out_next;
357	root	1.3	}
358
359	root	1.4	sub cv2c {
360	root	1.1	my ($cv) = @_;
361
362			my %opsseen;
363			my @todo = $cv->START;
364
365			while (my $op = shift @todo) {
366			for (; $$op; $op = $op->next) {
367			last if $opsseen{$$op}++;
368			push @ops, $op;
369			my $name = $op->name;
370			if (B::class($op) eq "LOGOP") {
371			push @todo, $op->other;
372			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
373			push @todo, $op->pmreplstart;
374			} elsif ($name =~ /^enter(loop\|iter)$/) {
375			# if ($] > 5.009) {
376			# $labels{${$op->nextop}} = "NEXT";
377			# $labels{${$op->lastop}} = "LAST";
378			# $labels{${$op->redoop}} = "REDO";
379			# } else {
380			# $labels{$op->nextop->seq} = "NEXT";
381			# $labels{$op->lastop->seq} = "LAST";
382			# $labels{$op->redoop->seq} = "REDO";
383			# }
384			}
385			}
386			}
387
388	root	1.4	local $source = <<EOF;
389			#define PERL_NO_GET_CONTEXT
390
391	root	1.8	//#define NDEBUG 1
392	root	1.4	#include <assert.h>
393
394			#include "EXTERN.h"
395			#include "perl.h"
396			#include "XSUB.h"
397	root	1.2
398	root	1.4	OP *%%%FUNC%%% (pTHX)
399			{
400			register OP nextop = (OP )${$ops[0]}L;
401			EOF
402	root	1.2
403	root	1.8	while (@ops) {
404			$op = shift @ops;
405			$op_name = $op->name;
406	root	1.2
407	root	1.8	$source .= "op_$$op: /* $op_name */\n";
408			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
409	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
410
411	root	1.8	unless (exists $flag{noasync}{$op_name}) {
412	root	1.4	$source .= " PERL_ASYNC_CHECK ();\n";
413			}
414	root	1.2
415	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
416	root	1.2	$can->($op);
417	root	1.8	} elsif (exists $flag{unsafe}{$op_name}) {
418			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
419	root	1.5	$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
420	root	1.8	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
421			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
422	root	1.4	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
423			$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
424	root	1.8	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
425	root	1.5	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
426	root	1.2	} else {
427	root	1.8	out_linear;
428	root	1.2	}
429	root	1.1	}
430	root	1.2
431			$source .= "}\n";
432	root	1.4	#warn $source;
433	root	1.2
434	root	1.4	$source
435			}
436
437			sub source2ptr {
438			my ($source) = @_;
439
440			my $md5 = Digest::MD5::md5_hex $source;
441			$source =~ s/%%%FUNC%%%/Faster_$md5/;
442
443			my $stem = "/tmp/$md5";
444
445			unless (-e "$stem$_so") {
446			open FILE, ">:raw", "$stem.c";
447			print FILE $source;
448			close FILE;
449			system "$COMPILE -o $stem$_o $stem.c";
450			system "$LINK -o $stem$_so $stem$_o $LIBS";
451			}
452
453			# warn $source;
454			my $so = DynaLoader::dl_load_file "$stem$_so"
455			or die "$stem$_so: $!";
456
457			DynaLoader::dl_find_symbol $so, "Faster_$md5"
458			or die "Faster_$md5: $!"
459			}
460
461			sub entersub {
462			my ($cv) = @_;
463
464			eval {
465			my $source = cv2c $cv;
466
467			my $ptr = source2ptr $source;
468
469			patch_cv $cv, $ptr;
470			};
471
472			warn $@ if $@;
473	root	1.1	}
474
475			hook_entersub;
476
477			1;
478
479			=back
480
481	root	1.2	=head1 LIMITATIONS
482
483			Tainting and debugging will disable Faster.
484
485	root	1.1	=head1 AUTHOR
486
487			Marc Lehmann <schmorp@schmorp.de>
488			http://home.schmorp.de/
489
490			=cut
491