--- Faster/Faster.pm	2006/03/09 06:03:12	1.2
+++ Faster/Faster.pm	2006/03/10 02:03:50	1.10
@@ -15,6 +15,10 @@
 package Faster;
 
 use strict;
+use Config;
+use B ();
+use Digest::MD5 ();
+use DynaLoader ();
 
 BEGIN {
    our $VERSION = '0.01';
@@ -23,13 +27,21 @@
    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";
 
 our $source;
 our $label_next;
 our $label_last;
 our $label_redo;
 
+my @ops;
+my $op;
+my $op_name;
+
 my %flag;
 
 for (split /\n/, <<EOF) {
@@ -47,6 +59,76 @@
    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+/;
 
@@ -54,40 +136,236 @@
       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 {
-   my ($op) = @_;
+   $source .= "  nextop = (OP *)${$op->next}L;\n";
+
+   out_gotonext;
+}
 
-   my $ppaddr = ppaddr $op->type;
+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
+   }
 
-   $source .= "  PL_op = (OP *)${$op->next}L;\n";
-   $source .= "  goto op_${$op->next};\n";
+   out_gotonext;
 }
 
 sub op_nextstate {
-   my ($op) = @_;
-
-   $source .= "  PL_curcop = (COP *)PL_op;\n";
+   $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;
 }
 
-sub op_const {
-   my ($op) = @_;
+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";
 
-   $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\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";
+      }
 
-   out_next $op;
+      $source .= "    PUTBACK;\n";
+      $source .= "  }\n";
+
+      out_next;
+   };
 }
 
-*op_gv = \&op_const;
+sub op_stringify {
+   $source .= "  { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
 
-sub entersub {
+   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 @ops;
    my @todo = $cv->START;
 
    while (my $op = shift @todo) {
@@ -113,40 +391,91 @@
       }
    }
 
-   local $source;
+   local $source = <<EOF;
+#define PERL_NO_GET_CONTEXT
 
-   $source = "typedef OP *(*PPFUNC)(pTHX);\n\n";
-   
-   $source .= "OP *func (pTHX)\n{\n";
+//#define NDEBUG 1
+#include <assert.h>
 
-   for my $op (@ops) {
-      my $name = $op->name;
-      my $ppaddr = ppaddr $op->type;
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
 
-      $source .= "op_$$op: /* $name */\n";
+OP *%%%FUNC%%% (pTHX)
+{
+  register OP *nextop = (OP *)${$ops[0]}L;
+EOF
 
-      if (my $can = __PACKAGE__->can ("op_$name")) {
+   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 ("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}) {
+         $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 {
-         $source .= "  PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
-         $source .= "  goto op_${$op->next};\n";
+         out_linear;
       }
    }
 
    $source .= "}\n";
+   #warn $source;
 
-   print <<EOF;
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-EOF
-   print $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;