--- Faster/Faster.pm	2006/03/10 00:13:15	1.7
+++ Faster/Faster.pm	2006/03/10 22:32:15	1.20
@@ -6,8 +6,31 @@
 
  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
@@ -17,7 +40,7 @@
 use strict;
 use Config;
 use B ();
-use Digest::MD5 ();
+#use Digest::MD5 ();
 use DynaLoader ();
 
 BEGIN {
@@ -33,132 +56,201 @@
 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 $label_next;
-our $label_last;
-our $label_redo;
-
-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	todo
-   subst	unsafe	todo
-   entereval	unsafe	todo
-   mapstart	unsafe	todo
-
-   pushmark	noasync
-   padsv	noasync
-   entersub	noasync
-   aassign	noasync
-   sassign	noasync
-   rv2av	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
-   method_named	noasync
-   preinc	noasync
-   postinc	noasync
-   predec	noasync
-   postdec	noasync
-   stub		noasync
-   unstack	noasync
-   leaveloop	noasync
-   shift	noasync
-   aelemA	noasync
-   aelemfast	noasync	
-EOF
-   my (undef, $op, @flags) = split /\s+/;
 
-   undef $flag{$_}{$op}
-      for ("known", @flags);
+our @ops;
+our $op;
+our $op_name;
+our @op_loop;
+our %op_regcomp;
+
+my %f_unsafe = map +($_ => undef), qw(
+   leavesub leavesublv return
+   goto last redo next
+   eval flip leaveeval entertry
+   formline grepstart mapstart
+   substcont entereval require
+);
+
+#  pushmark	extend=0
+#  padsv	extend=1
+#  padav	extend=1
+#  padhv	extend=1
+#  padany	extend=1
+#  const	extend=1
+
+my %f_noasync = map +($_ => undef), qw(
+   mapstart grepstart match entereval
+   enteriter entersub leaveloop
+
+   pushmark nextstate
+
+   const stub unstack
+   last next redo seq
+   padsv padav padhv padany
+   aassign sassign orassign
+   rv2av rv2cv rv2gv rv2hv refgen
+   gv gvsv
+   add subtract multiply divide
+   complement cond_expr and or not
+   defined
+   method_named
+   preinc postinc predec postdec
+   aelem aelemfast helem delete exists
+   pushre subst list join split concat
+   length substr stringify ord
+   push pop shift unshift
+   eq ne gt lt ge le
+   regcomp regcreset regcmaybe
+);
+
+my %callop = (
+   entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
+   mapstart => "Perl_pp_grepstart (aTHX)",
+);
+
+sub callop {
+   $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
 }
 
-sub out_next {
-   my ($op) = @_;
+sub assert {
+   return unless $opt_assert;
+   $source .= "  assert ((\"$op_name\", ($_[0])));\n";
+}
 
-   if (${$op->next}) {
-      $source .= "  nextop = (OP *)${$op->next}L;\n";
-      $source .= "  goto op_${$op->next};\n";
-   } else {
-      $source .= "  return 0;\n";
-   }
+sub out_callop {
+   assert "nextop == (OP *)$$op";
+   $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
 }
 
-sub callop {
-   my ($op) = @_;
+sub out_cond_jump {
+   $source .= "  if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
+}
 
-   my $name = $op->name;
+sub out_jump_next {
+   out_cond_jump $op_regcomp{$$op}
+      if $op_regcomp{$$op};
 
-   $name eq "entersub"
-      ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
-      : $name eq "mapstart"
-        ? "Perl_pp_grepstart (aTHX)"
-        : "Perl_pp_$name (aTHX)"
+   assert "nextop == (OP *)${$op->next}";
+   $source .= "  goto op_${$op->next};\n";
 }
 
-sub op_nextstate {
-   my ($op) = @_;
+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 $op;
+   out_next;
 }
 
 sub op_pushmark {
-   my ($op) = @_;
-
    $source .= "  PUSHMARK (PL_stack_sp);\n";
 
-   out_next $op;
+   out_next;
 }
 
-sub op_const {
-   my ($op) = @_;
+if ($Config{useithreads} ne "define") {
+   # disable optimisations on ithreads
 
-   $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
+   *op_const = sub {
+      $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
 
-   out_next $op;
-}
+      out_next;
+   };
+
+   *op_gv = \&op_const;
 
-*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 ($op) = @_;
+   my $targ = $op->targ;
 
-   $source .= "  { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
+   $source .= <<EOF;
+  {
+    dSP;
+    SV *targ = PAD_SV ((PADOFFSET)$targ);
+    sv_copypv (TARG, TOPs);
+    SETTARG;
+    PUTBACK;
+  }
+EOF
 
-   out_next $op;
+   out_next;
 }
 
 sub op_and {
-   my ($op) = @_;
-
    $source .= <<EOF;
   {
     dSP;
@@ -173,12 +265,10 @@
   }
 EOF
 
-   out_next $op;
+   out_next;
 }
 
 sub op_or {
-   my ($op) = @_;
-
    $source .= <<EOF;
   {
     dSP;
@@ -193,12 +283,10 @@
   }
 EOF
 
-   out_next $op;
+   out_next;
 }
 
 sub op_padsv {
-   my ($op) = @_;
-
    my $flags = $op->flags;
    my $target = $op->targ;
 
@@ -220,39 +308,7 @@
   }
 EOF
 
-   out_next $op;
-}
-
-sub op_aelemfast {
-   my ($op) = @_;
-
-   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;
+   out_next;
 }
 
 # pattern const+ (or general push1)
@@ -261,176 +317,265 @@
 
 # pattern const method_named
 sub op_method_named {
-   my ($op) = @_;
-
    $source .= <<EOF;
   {
     static HV *last_stash;
-    static SV *last_res;
+    static SV *last_cv;
+    static U32 last_sub_generation;
 
     SV *obj = *(PL_stack_base + TOPMARK + 1);
 
-    if (SvROK (obj) && SvOBJECT (SvRV (obj)))
+    if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
       {
         dSP;
         HV *stash = SvSTASH (SvRV (obj));
 
         /* simple "polymorphic" inline cache */
-        if (stash == last_stash)
+        if (stash == last_stash
+            && PL_sub_generation == last_sub_generation)
           {
-            XPUSHs (last_res);
+            XPUSHs (last_cv);
             PUTBACK;
           }
         else
           {
-            PL_op = nextop;
-            nextop = Perl_pp_method_named (aTHX);
+            PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
 
             SPAGAIN;
-            last_stash = stash;
-            last_res   = TOPs;
+            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);
+        PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
       }
   }
 EOF
 
-   out_next $op;
+   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 @ops;
    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";         
-#            }
+         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;
-#define PERL_NO_GET_CONTEXT
-
-#include <assert.h>
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-/*typedef OP *(*PPFUNC)(pTHX);*/
-   
 OP *%%%FUNC%%% (pTHX)
 {
   register OP *nextop = (OP *)${$ops[0]}L;
 EOF
 
-   for my $op (@ops) {
-      my $name = $op->name;
-      my $ppaddr = ppaddr $op->type;
+   while (@ops) {
+      $op = shift @ops;
+      $op_name = $op->name;
 
-      $source .= "op_$$op: /* $name */\n";
-      #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
+      $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}{$name}) {
-         $source .= "  PERL_ASYNC_CHECK ();\n";
-      }
+      $source .= "  PERL_ASYNC_CHECK ();\n"
+         unless exists $f_noasync{$op_name};
 
-      if (my $can = __PACKAGE__->can ("op_$name")) {
+      if (my $can = __PACKAGE__->can ("op_$op_name")) {
+         # handcrafted replacement
          $can->($op);
-      } elsif (exists $flag{unsafe}{$name}) {
-         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
-         $source .= "  PL_op = nextop; return " . (callop $op) . ";\n";
-      } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
-         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
-         $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
-         $source .= "  if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
-         $source .= "  assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
-         $source .= ${$op->next} ? "  goto op_${$op->next};\n" : "  return 0;\n";
+
+      } elsif (exists $f_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 {
-         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
-         $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
-         if ($name eq "entersub") {
-            $source .= <<EOF;
-while (nextop != (OP *)${$op->next})
-  {
-    PERL_ASYNC_CHECK ();
-    PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
-  }
-EOF
-         }
-         $source .= "  assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
-         $source .= ${$op->next} ? "  goto op_${$op->next};\n" : "  return 0;\n";
+         # normal operator, linear execution
+         out_linear;
       }
    }
 
-   $source .= "}\n";
+   $op_name = "func exit"; assert (0);
+
+   $source .= <<EOF;
+op_0:
+  return 0;
+}
+EOF
    #warn $source;
 
    $source
 }
 
+my $uid = "aaaaaaa0";
+
 sub source2ptr {
-   my ($source) = @_;
+   my (@source) = @_;
 
-   my $md5 = Digest::MD5::md5_hex $source;
-   $source =~ s/%%%FUNC%%%/Faster_$md5/;
+   my $stem = "/tmp/Faster-$$-" . $uid++;
 
-   my $stem = "/tmp/$md5";
+   open FILE, ">:raw", "$stem.c";
+   print FILE <<EOF;
+#define PERL_NO_GET_CONTEXT
+
+#include <assert.h>
 
-   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";
+#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;
    }
 
-#   warn $source;
+   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: $!";
 
-   DynaLoader::dl_find_symbol $so, "Faster_$md5"
-      or die "Faster_$md5: $!"
+   #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 $source = cv2c $cv;
+      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 $source;
+      my @ptr = source2ptr @cv_source;
 
-       patch_cv $cv, $ptr;
+      for (0 .. $#cv) {
+         patch_cv $cv[$_], $ptr[$_];
+      }
    };
 
-   warn $@ if $@;
+   if ($@) {
+      $ignore{$pkg}++;
+      warn $@;
+   }
 }
 
 hook_entersub;
@@ -439,9 +584,31 @@
 
 =back
 
-=head1 LIMITATIONS
+=head1 BUGS/LIMITATIONS
 
-Tainting and debugging will disable Faster.
+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