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

    printf ("todo: PL_subgeneration or somesuch\\n");
    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.10
Committed:	Fri Mar 10 02:03:50 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.9:	+1 -0 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.10	printf ("todo: PL_subgeneration or somesuch\\n");
332	root	1.4	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
333	root	1.3	{
334	root	1.4	dSP;
335			HV *stash = SvSTASH (SvRV (obj));
336	root	1.3
337	root	1.4	/* simple "polymorphic" inline cache */
338	root	1.3	if (stash == last_stash)
339			{
340	root	1.4	XPUSHs (last_res);
341			PUTBACK;
342	root	1.3	}
343			else
344			{
345	root	1.4	PL_op = nextop;
346			nextop = Perl_pp_method_named (aTHX);
347
348	root	1.3	SPAGAIN;
349			last_stash = stash;
350			last_res = TOPs;
351			}
352			}
353	root	1.4	else
354			{
355			/* error case usually */
356			PL_op = nextop;
357			nextop = Perl_pp_method_named (aTHX);
358			}
359	root	1.3	}
360			EOF
361
362	root	1.8	out_next;
363	root	1.3	}
364
365	root	1.4	sub cv2c {
366	root	1.1	my ($cv) = @_;
367
368			my %opsseen;
369			my @todo = $cv->START;
370
371			while (my $op = shift @todo) {
372			for (; $$op; $op = $op->next) {
373			last if $opsseen{$$op}++;
374			push @ops, $op;
375			my $name = $op->name;
376			if (B::class($op) eq "LOGOP") {
377			push @todo, $op->other;
378			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
379			push @todo, $op->pmreplstart;
380			} elsif ($name =~ /^enter(loop\|iter)$/) {
381			# if ($] > 5.009) {
382			# $labels{${$op->nextop}} = "NEXT";
383			# $labels{${$op->lastop}} = "LAST";
384			# $labels{${$op->redoop}} = "REDO";
385			# } else {
386			# $labels{$op->nextop->seq} = "NEXT";
387			# $labels{$op->lastop->seq} = "LAST";
388			# $labels{$op->redoop->seq} = "REDO";
389			# }
390			}
391			}
392			}
393
394	root	1.4	local $source = <<EOF;
395			#define PERL_NO_GET_CONTEXT
396
397	root	1.8	//#define NDEBUG 1
398	root	1.4	#include <assert.h>
399
400			#include "EXTERN.h"
401			#include "perl.h"
402			#include "XSUB.h"
403	root	1.2
404	root	1.4	OP *%%%FUNC%%% (pTHX)
405			{
406			register OP nextop = (OP )${$ops[0]}L;
407			EOF
408	root	1.2
409	root	1.8	while (@ops) {
410			$op = shift @ops;
411			$op_name = $op->name;
412	root	1.2
413	root	1.8	$source .= "op_$$op: /* $op_name */\n";
414			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
415	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
416
417	root	1.8	unless (exists $flag{noasync}{$op_name}) {
418	root	1.4	$source .= " PERL_ASYNC_CHECK ();\n";
419			}
420	root	1.2
421	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
422	root	1.2	$can->($op);
423	root	1.8	} elsif (exists $flag{unsafe}{$op_name}) {
424			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
425	root	1.9	$source .= " return nextop;\n";
426	root	1.8	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
427			$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
428	root	1.4	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
429			$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
430	root	1.8	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
431	root	1.5	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
432	root	1.2	} else {
433	root	1.8	out_linear;
434	root	1.2	}
435	root	1.1	}
436	root	1.2
437			$source .= "}\n";
438	root	1.4	#warn $source;
439	root	1.2
440	root	1.4	$source
441			}
442
443			sub source2ptr {
444			my ($source) = @_;
445
446			my $md5 = Digest::MD5::md5_hex $source;
447			$source =~ s/%%%FUNC%%%/Faster_$md5/;
448
449			my $stem = "/tmp/$md5";
450
451			unless (-e "$stem$_so") {
452			open FILE, ">:raw", "$stem.c";
453			print FILE $source;
454			close FILE;
455			system "$COMPILE -o $stem$_o $stem.c";
456			system "$LINK -o $stem$_so $stem$_o $LIBS";
457			}
458
459			# warn $source;
460			my $so = DynaLoader::dl_load_file "$stem$_so"
461			or die "$stem$_so: $!";
462
463			DynaLoader::dl_find_symbol $so, "Faster_$md5"
464			or die "Faster_$md5: $!"
465			}
466
467			sub entersub {
468			my ($cv) = @_;
469
470			eval {
471			my $source = cv2c $cv;
472
473			my $ptr = source2ptr $source;
474
475			patch_cv $cv, $ptr;
476			};
477
478			warn $@ if $@;
479	root	1.1	}
480
481			hook_entersub;
482
483			1;
484
485			=back
486
487	root	1.2	=head1 LIMITATIONS
488
489			Tainting and debugging will disable Faster.
490
491	root	1.1	=head1 AUTHOR
492
493			Marc Lehmann <schmorp@schmorp.de>
494			http://home.schmorp.de/
495
496			=cut
497