--- Faster/Faster.pm	2006/03/09 06:03:12	1.2
+++ Faster/Faster.pm	2006/03/10 18:58:26	1.15
@@ -15,6 +15,10 @@
 package Faster;
 
 use strict;
+use Config;
+use B ();
+use Digest::MD5 ();
+use DynaLoader ();
 
 BEGIN {
    our $VERSION = '0.01';
@@ -23,15 +27,28 @@
    XSLoader::load __PACKAGE__, $VERSION;
 }
 
-use B ();
+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 $label_next;
-our $label_last;
-our $label_redo;
+
+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
@@ -44,9 +61,82 @@
    eval		unsafe
    leaveeval	unsafe
    entertry	unsafe
-   substconst	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+/;
 
@@ -54,99 +144,430 @@
       for ("known", @flags);
 }
 
-sub out_next {
-   my ($op) = @_;
+my %callop = (
+   entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
+   mapstart => "Perl_pp_grepstart (aTHX)",
+);
+
+sub callop {
+   $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
+}
 
-   my $ppaddr = ppaddr $op->type;
+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";
+}
 
-   $source .= "  PL_op = (OP *)${$op->next}L;\n";
+sub out_jump_next {
+   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;
+}
 
-   $source .= "  PL_curcop = (COP *)PL_op;\n";
+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 $op;
+   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_const {
-   my ($op) = @_;
+# 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;
+}
 
-   $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
+sub op_and {
+   $source .= <<EOF;
+  {
+    dSP;
+
+    if (SvTRUE (TOPs))
+      {
+        --SP;
+        PUTBACK;
+        nextop = (OP *)${$op->other}L;
+        goto op_${$op->other};
+      }
+  }
+EOF
 
-   out_next $op;
+   out_next;
 }
 
-*op_gv = \&op_const;
+sub op_or {
+   $source .= <<EOF;
+  {
+    dSP;
+
+    if (!SvTRUE (TOPs))
+      {
+        --SP;
+        PUTBACK;
+        nextop = (OP *)${$op->other}L;
+        goto op_${$op->other};
+      }
+  }
+EOF
 
-sub entersub {
+   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 @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
+         } 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;
-
-   $source = "typedef OP *(*PPFUNC)(pTHX);\n\n";
-   
-   $source .= "OP *func (pTHX)\n{\n";
+   local $source = <<EOF;
+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: /* $op_name */\n";
+      #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
+      #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
 
-      $source .= "op_$$op: /* $name */\n";
+      $source .= "  PERL_ASYNC_CHECK ();\n"
+         unless exists $flag{noasync}{$op_name};
 
-      if (my $can = __PACKAGE__->can ("op_$name")) {
+      if (my $can = __PACKAGE__->can ("op_$op_name")) {
+         # handcrafted replacement
          $can->($op);
-      } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
-         $source .= "  PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
-         $source .= "  if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
-         $source .= "  goto op_${$op->next};\n";
-      } elsif (exists $flag{unsafe}{$name}) {
-         $source .= "  return ((PPFUNC)${ppaddr}L)(aTHX);\n";
+
+      } 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 {
-         $source .= "  PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
-         $source .= "  goto op_${$op->next};\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
+}
+
+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>
 
-   print <<EOF;
 #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 $source;
+      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;
@@ -155,9 +576,31 @@
 
 =back
 
-=head1 LIMITATIONS
+=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:
 
-Tainting and debugging will disable Faster.
+ .., ... (flipflop operators)
+ goto
+ next, redo (but not well-behaved last's)
+ eval
+ require
+ any use of formats
 
 =head1 AUTHOR