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

# we don't need no steenking PIC on x86
$COMPILE =~ s/-f(?:PIC|pic)//g
   if $Config{archname} =~ /^(i[3456]86)-/;

my $opt_assert = 1;

our $source;

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

my %flag;

# complex flag steting is no longer required, rewrite this ugly code
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
   formline     unsafe
   grepstart    unsafe
   mapstart     unsafe
   substcont    unsafe
   entereval    unsafe noasync  todo
   require      unsafe

   mapstart     noasync
   grepstart    noasync
   match        noasync

   last         noasync
   next         noasync
   redo         noasync
   seq          noasync
   pushmark     noasync extend=0
   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
   subst        noasync
   const        noasync extend=1
   list         noasync
   join         noasync
   split        noasync
   concat       noasync
   push         noasync
   pop          noasync
   shift        noasync
   unshift      noasync
   length       noasync
   substr       noasync
   stringify    noasync
   eq           noasync
   ne           noasync
   gt           noasync
   lt           noasync
   ge           noasync
   le           noasync
   enteriter    noasync
   ord          noasync

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

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

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_jump_next {
   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 out_cond_jump {
   $source .= "  if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
}

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 @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) = @_;

   @loop = ();

   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
         } elsif ($class eq "PMOP") {
            unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
         } elsif ($class eq "LOOP") {
            push @loop, [$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 $flag{noasync}{$op_name};

      if (my $can = __PACKAGE__->can ("op_$op_name")) {
         # handcrafted replacement
         $can->($op);

      } elsif (exists $flag{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
}

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 <<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
      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) = @_;

   # always compile the whole stash
#   my @stash = $cv->STASH->ARRAY;
#   warn join ":", @stash;
#   exit;

   eval {
      my $source = cv2c $cv;

      my $ptr = source2ptr $source;

      patch_cv $cv, $ptr;
   };

   warn $@ if $@;
}

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.

 enabled tainting
 enabled debugging

This will dramatically reduce Faster's performance:

 threads (but you don't care about speed if you use threads anyway)

These constructs will force the use of the interpreter as soon as they are
being executed, for the rest of the currently executed:

 .., ... (flipflop operators)
 goto
 next, redo (but not well-behaved last's)
 eval
 require
 any use of formats

=head1 AUTHOR

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

=cut

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