Faster/Faster.pm

=head1 NAME

Faster - do some things faster

=head1 SYNOPSIS

 use Faster;

 perl -MFaster ...

=head1 DESCRIPTION

This module implements a very simple-minded JIT. It works by more or less
translating every function it sees into a C program, compiling it and then
replacing the function by the compiled code.

As a result, startup times are immense, as every function might lead to a
full-blown compilation.

The speed improvements are also not great, you can expect 20% or so on
average, for code that runs very often.

Faster is in the early stages of development. Due to its design its
relatively safe to use (it will either work or simply slowdown the program
immensely, but rarely cause bugs).

Usage is very easy, just C<use Faster> and every function called from then
on will be compiled.

Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in
F</tmp>, and it will even create those temporary files in an insecure
manner, so watch out.

=over 4

=cut

package Faster;

use strict;
use Config;
use B ();
#use Digest::MD5 ();
use DynaLoader ();

BEGIN {
   our $VERSION = '0.01';

   require XSLoader;
   XSLoader::load __PACKAGE__, $VERSION;
}

my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
my $LINK    = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
my $LIBS    = "$Config{libs}";
my $_o      = $Config{_o};
my $_so     = ".so";

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

my $opt_assert = 0;

our $source;

our @ops;
our $op;
our $op_name;
our @op_loop;
our %op_regcomp;

my %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
   delete       noasync
   exists       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
   orassign     noasync
   regcomp      noasync
   regcreset    noasync
   regcmaybe    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_cond_jump {
   $source .= "  if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
}

sub out_jump_next {
   out_cond_jump $op_regcomp{$$op}
      if $op_regcomp{$$op};

   assert "nextop == (OP *)${$op->next}";
   $source .= "  goto op_${$op->next};\n";
}

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

   out_jump_next;
}

sub out_linear {
   out_callop;
   out_jump_next;
}

sub op_entersub {
   out_callop;
   $source .= "  RUNOPS_TILL ((OP *)${$op->next}L);\n";
   out_jump_next;
}

*op_require = \&op_entersub;

sub op_nextstate {
   $source .= "  PL_curcop = (COP *)nextop;\n";
   $source .= "  PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
   $source .= "  FREETMPS;\n";

   out_next;
}

sub op_pushmark {
   $source .= "  PUSHMARK (PL_stack_sp);\n";

   out_next;
}

if ($Config{useithreads} ne "define") {
   # disable optimisations on ithreads

   *op_const = sub {
      $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";

      out_next;
   };

   *op_gv = \&op_const;

   *op_aelemfast = sub {
      my $targ = $op->targ;
      my $private = $op->private;

      $source .= "  {\n";

      if ($op->flags & B::OPf_SPECIAL) {
         $source .= "    AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
      } else {
         $source .= "    AV *av = GvAV ((GV *)${$op->sv}L);\n";
      }

      if ($op->flags & B::OPf_MOD) {
         $source .= "    SV *sv = *av_fetch (av, $private, 1);\n";
      } else {
         $source .= "    SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
      }

      if (!($op->flags & B::OPf_MOD)) {
         $source .= "    if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
      }

      $source .= "    dSP;\n";
      $source .= "    XPUSHs (sv);\n";
      $source .= "    PUTBACK;\n";
      $source .= "  }\n";

      out_next;
   };

   *op_gvsv = sub {
      $source .= "  {\n";
      $source .= "    dSP;\n";
      $source .= "    EXTEND (SP, 1);\n";

      if ($op->private & B::OPpLVAL_INTRO) {
        $source .= "    PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
      } else {
        $source .= "    PUSHs (GvSV ((GV *)${$op->sv}L));\n";
      }

      $source .= "    PUTBACK;\n";
      $source .= "  }\n";

      out_next;
   };
}

# does kill Crossfire/res2pm
sub op_stringify {
   my $targ = $op->targ;

   $source .= <<EOF;
  {
    dSP;
    SV *targ = PAD_SV ((PADOFFSET)$targ);
    sv_copypv (TARG, TOPs);
    SETTARG;
    PUTBACK;
  }
EOF

   out_next;
}

sub op_and {
   $source .= <<EOF;
  {
    dSP;

    if (SvTRUE (TOPs))
      {
        --SP;
        PUTBACK;
        nextop = (OP *)${$op->other}L;
        goto op_${$op->other};
      }
  }
EOF

   out_next;
}

sub op_or {
   $source .= <<EOF;
  {
    dSP;

    if (!SvTRUE (TOPs))
      {
        --SP;
        PUTBACK;
        nextop = (OP *)${$op->other}L;
        goto op_${$op->other};
      }
  }
EOF

   out_next;
}

sub op_padsv {
   my $flags = $op->flags;
   my $target = $op->targ;

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

   out_next;
}

# pattern const+ (or general push1)
# pattern pushmark return(?)
# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign

# pattern const method_named
sub op_method_named {
   $source .= <<EOF;
  {
    static HV *last_stash;
    static SV *last_cv;
    static U32 last_sub_generation;

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

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

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

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

   out_next;
}

sub op_grepstart {
   out_callop;
   $op = $op->next;
   out_cond_jump $op->other;
   out_jump_next;
}

*op_mapstart = \&op_grepstart;

sub op_substcont {
   out_callop;
   out_cond_jump $op->other->pmreplstart;
   assert "nextop == (OP *)${$op->other->next}L";
   $source .= "  goto op_${$op->other->next};\n";
}

sub out_break_op {
   my ($idx) = @_;

   out_callop;

   out_cond_jump $_->[$idx]
      for reverse @op_loop;

   $source .= "  return nextop;\n";
}

sub xop_next {
   out_break_op 0;
}

sub op_last {
   out_break_op 1;
}

sub xop_redo {
   out_break_op 2;
}

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

   local @ops;
   local @op_loop;
   local %op_regcomp;

   my %opsseen;
   my @todo = $cv->START;

   while (my $op = shift @todo) {
      for (; $$op; $op = $op->next) {
         last if $opsseen{$$op}++;
         push @ops, $op;

         my $name = $op->name;
         my $class = B::class $op;

         if ($class eq "LOGOP") {
            unshift @todo, $op->other; # unshift vs. push saves jumps

            # regcomp/o patches ops at runtime, lets expect that
            $op_regcomp{${$op->first}} = $op->next
               if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;

         } elsif ($class eq "PMOP") {
            unshift @todo, $op->pmreplstart if ${$op->pmreplstart};

         } elsif ($class eq "LOOP") {
            push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
            push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
         }
      }
   }

   local $source = <<EOF;
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]}L;
EOF

   while (@ops) {
      $op = shift @ops;
      $op_name = $op->name;

      $source .= "op_$$op: /* $op_name */\n";
      #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
      #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#

      $source .= "  PERL_ASYNC_CHECK ();\n"
         unless exists $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
}

my $uid = "aaaaaaa0";

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

   my $stem = "/tmp/Faster-$$-" . $uid++;

   open FILE, ">:raw", "$stem.c";
   print FILE <<EOF;
#define PERL_NO_GET_CONTEXT

#include <assert.h>

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

#define RUNOPS_TILL(op)                                         \\
while (nextop != (op))                                  \\
 {                                                              \\
   PERL_ASYNC_CHECK ();                                 \\
   PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);   \\
 }

EOF
   for (@source) {
      my $func = $uid++;
      $_ =~ s/%%%FUNC%%%/$func/g;
      print FILE $_;
      $_ = $func;
   }

   close FILE;
   system "$COMPILE -o $stem$_o $stem.c";
   #d#unlink "$stem.c";
   system "$LINK -o $stem$_so $stem$_o $LIBS";
   unlink "$stem$_o";

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

   #unlink "$stem$_so";

   map +(DynaLoader::dl_find_symbol $so, $_), @source
}

my %ignore;

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

   my $pkg = $cv->STASH->NAME;

   return if $ignore{$pkg};

   warn "compiling ", $cv->STASH->NAME;#d#

   eval {
      my @cv;
      my @cv_source;

      # always compile the whole stash
      my %stash = $cv->STASH->ARRAY;
      while (my ($k, $v) = each %stash) {
         $v->isa (B::GV::)
            or next;

         my $cv = $v->CV;

         if ($cv->isa (B::CV::)
             && ${$cv->START}
             && $cv->START->name ne "null") {
            push @cv, $cv;
            push @cv_source, cv2c $cv;
         }
      }

      my @ptr = source2ptr @cv_source;

      for (0 .. $#cv) {
         patch_cv $cv[$_], $ptr[$_];
      }
   };

   if ($@) {
      $ignore{$pkg}++;
      warn $@;
   }
}

hook_entersub;

1;

=back

=head1 BUGS/LIMITATIONS

Perl will check much less often for asynchronous signals in
Faster-compiled code. It tries to check on every function call, loop
iteration and every I/O operator, though.

The following things will disable Faster. If you manage to enable them at
runtime, bad things will happen. Enabling them at startup will be fine,
though.

 enabled tainting
 enabled debugging

Thread-enabled builds of perl will dramatically reduce Faster's
performance, but you don't care about speed if you enable threads anyway.

These constructs will force the use of the interpreter for the currently
executed function as soon as they are being encountered during execution.

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

=head1 AUTHOR

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

=cut

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