This is an automated email from the git hooks/post-receive script.

ppm-guest pushed a commit to annotated tag v0.28
in repository libmath-prime-util-perl.

commit 5f42b95fd42bb81001ac372457d3ead00b17079a
Author: Dana Jacobsen <d...@acm.org>
Date:   Mon May 20 17:14:33 2013 -0700

    Add forprimes multicall
---
 Changes                |   9 +++
 MANIFEST               |   1 +
 TODO                   |   5 ++
 XS.xs                  |  69 ++++++++++++++++++++
 lib/Math/Prime/Util.pm |  15 +++++
 multicall.h            | 166 +++++++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 265 insertions(+)

diff --git a/Changes b/Changes
index 2220c72..de73411 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,14 @@
 Revision history for Perl extension Math::Prime::Util.
 
+0.28 xx May 2013
+
+    - Yet another XS micro-speedup (PERL_NO_GET_CONTEXT)
+
+    - forprimes { block } [begin,]end.  e.g.
+        forprimes { say } 100;
+        $sum = 0;  forprimes { $sum += $_ } 1000,50000;  say $sum;
+        forprimes { say if is_prime($_+2) } 10000;  # print twin primes
+
 0.27 20 May 2013
 
     - is_prime, is_prob_prime, next_prime, and prev_prime now all go straight
diff --git a/MANIFEST b/MANIFEST
index b2cb116..6590300 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -13,6 +13,7 @@ README
 TODO
 XS.xs
 ptypes.h
+multicall.h
 mulmod.h
 aks.h
 aks.c
diff --git a/TODO b/TODO
index b9417b5..4b10d09 100644
--- a/TODO
+++ b/TODO
@@ -40,3 +40,8 @@
 - Big features:
    - LMO prime count
    - QS factoring
+
+- forprimes { say } 1000,2000
+  - Documentation
+  - Tests
+  - Examples
diff --git a/XS.xs b/XS.xs
index ee9018d..bad5906 100644
--- a/XS.xs
+++ b/XS.xs
@@ -1,7 +1,10 @@
 
+#define PERL_NO_GET_CONTEXT  /* Define at top for more efficiency. */
+
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+#include "multicall.h"  /* only works in 5.6 and newer */
 #include <ctype.h>
 /* We're not using anything for which we need ppport.h */
 #ifndef XSRETURN_UV   /* Er, almost.  Fix 21086 from Sep 2003 */
@@ -25,6 +28,13 @@
    val = SvUV(sv)
 #endif
 
+#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
+#  define PERL_HAS_BAD_MULTICALL_REFCOUNT
+#endif
+#ifndef CvISXSUB
+#  define CvISXSUB(cv) CvXSUB(cv)
+#endif
+
 
 static int pbrent_factor_a1(UV n, UV *factors, UV maxrounds) {
   return pbrent_factor(n, factors, maxrounds, 1);
@@ -37,6 +47,7 @@ static int pbrent_factor_a1(UV n, UV *factors, UV maxrounds) {
  */
 static int _validate_int(SV* n, int negok)
 {
+  dTHX;
   char* ptr;
   STRLEN i, len;
   UV val;
@@ -76,6 +87,7 @@ static int _validate_int(SV* n, int negok)
  */
 static SV* _callsub(SV* arg, const char* name)
 {
+  dTHX;
   dSP;                               /* Local copy of stack pointer         */
   int count;
   SV* v;
@@ -606,3 +618,60 @@ _validate_num(SV* n, ...)
     }
   OUTPUT:
     RETVAL
+
+void
+forprimes (SV* block, IN SV* svbeg, IN SV* svend = 0)
+  PROTOTYPE: &$;$
+  CODE:
+  {
+    UV beg, end;
+    GV *gv;
+    HV *stash;
+    CV *cv;
+
+    if (!_validate_int(svbeg, 0) || (items >= 3 && !_validate_int(svend,0))) {
+      dSP;
+      PUSHMARK(SP);
+      XPUSHs(block); XPUSHs(svbeg); XPUSHs(svend);
+      PUTBACK;
+      (void) call_pv("Math::Prime::Util::_generic_forprimes", 
G_VOID|G_DISCARD);
+      SPAGAIN;
+      XSRETURN_UNDEF;
+    }
+    if (items < 3) {
+      beg = 2;
+      set_val_from_sv(end, svbeg);
+    } else {
+      set_val_from_sv(beg, svbeg);
+      set_val_from_sv(end, svend);
+    }
+    if (beg > end)
+      XSRETURN_UNDEF;
+
+    cv = sv_2cv(block, &stash, &gv, 0);
+    if (cv == Nullcv)
+      croak("Not a subroutine reference");
+    SAVESPTR(GvSV(PL_defgv));
+    if (!CvISXSUB(cv)) {
+      dMULTICALL;
+      I32 gimme = G_VOID;
+      PUSH_MULTICALL(cv);
+      START_DO_FOR_EACH_PRIME(beg, end) {
+        GvSV(PL_defgv) = newSVuv(p);
+        MULTICALL;
+      } END_DO_FOR_EACH_PRIME
+#ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
+      if (CvDEPTH(multicall_cv) > 1)
+        SvREFCNT_inc_simple_void_NN(multicall_cv);
+#endif
+      POP_MULTICALL;
+    } else {
+      START_DO_FOR_EACH_PRIME(beg, end) {
+        dSP;
+        GvSV(PL_defgv) = newSVuv(p);
+        PUSHMARK(SP);
+        call_sv((SV*)cv, G_VOID|G_DISCARD);
+      } END_DO_FOR_EACH_PRIME
+    }
+    XSRETURN_UNDEF;
+  }
diff --git a/lib/Math/Prime/Util.pm b/lib/Math/Prime/Util.pm
index 5ef8fc6..6cb62fd 100644
--- a/lib/Math/Prime/Util.pm
+++ b/lib/Math/Prime/Util.pm
@@ -21,6 +21,7 @@ our @EXPORT_OK =
       is_aks_prime
       miller_rabin
       primes
+      forprimes
       next_prime  prev_prime
       prime_count
       prime_count_lower prime_count_upper prime_count_approx
@@ -91,6 +92,7 @@ BEGIN {
     *is_prime      = \&Math::Prime::Util::_generic_is_prime;
     *next_prime    = \&Math::Prime::Util::_generic_next_prime;
     *prev_prime    = \&Math::Prime::Util::_generic_prev_prime;
+    *forprimes     = \&Math::Prime::Util::_generic_forprimes;
 
     *_prime_memfreeall = \&Math::Prime::Util::PP::_prime_memfreeall;
     *prime_memfree  = \&Math::Prime::Util::PP::prime_memfree;
@@ -1350,6 +1352,19 @@ sub divisor_sum {
   return $sum;
 }
 
+sub _generic_forprimes (&$;$) {
+  my($sub, $beg, $end) = @_;
+  if (!defined $end) { $end = $beg; $beg = 2; }
+  _validate_num($beg) || _validate_positive_integer($beg);
+  _validate_num($end) || _validate_positive_integer($end);
+  my $p = ($beg <= 2) ? 2 : next_prime($beg-1);
+  while ($p <= $end) {
+    local *_ = \$p;
+    $sub->();
+    $p = next_prime($p);
+  }
+}
+
 # Omega function A001221.  Just an example.
 sub _omega {
   my($n) = @_;
diff --git a/multicall.h b/multicall.h
new file mode 100644
index 0000000..b8296e1
--- /dev/null
+++ b/multicall.h
@@ -0,0 +1,166 @@
+/*    multicall.h              (version 1.0)
+ *
+ * Implements a poor-man's MULTICALL interface for old versions
+ * of perl that don't offer a proper one. Intended to be compatible
+ * with 5.6.0 and later.
+ *
+ */
+
+#ifdef dMULTICALL
+#define REAL_MULTICALL
+#else
+#undef REAL_MULTICALL
+
+/* In versions of perl where MULTICALL is not defined (i.e. prior
+ * to 5.9.4), Perl_pad_push is not exported either. It also has
+ * an extra argument in older versions; certainly in the 5.8 series.
+ * So we redefine it here.
+ */
+
+#ifndef AVf_REIFY
+#  ifdef SVpav_REIFY
+#    define AVf_REIFY SVpav_REIFY
+#  else
+#    error Neither AVf_REIFY nor SVpav_REIFY is defined
+#  endif
+#endif
+
+#ifndef AvFLAGS
+#  define AvFLAGS SvFLAGS
+#endif
+
+static void
+multicall_pad_push(pTHX_ AV *padlist, int depth)
+{
+    if (depth <= AvFILLp(padlist))
+       return;
+
+    {
+       SV** const svp = AvARRAY(padlist);
+       AV* const newpad = newAV();
+       SV** const oldpad = AvARRAY(svp[depth-1]);
+       I32 ix = AvFILLp((AV*)svp[1]);
+        const I32 names_fill = AvFILLp((AV*)svp[0]);
+       SV** const names = AvARRAY(svp[0]);
+       AV *av;
+
+       for ( ;ix > 0; ix--) {
+           if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+               const char sigil = SvPVX(names[ix])[0];
+               if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
+                   /* outer lexical or anon code */
+                   av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
+               }
+               else {          /* our own lexical */
+                   SV *sv; 
+                   if (sigil == '@')
+                       sv = (SV*)newAV();
+                   else if (sigil == '%')
+                       sv = (SV*)newHV();
+                   else
+                       sv = NEWSV(0, 0);
+                   av_store(newpad, ix, sv);
+                   SvPADMY_on(sv);
+               }
+           }
+           else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+               av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
+           }
+           else {
+               /* save temporaries on recursion? */
+               SV * const sv = NEWSV(0, 0);
+               av_store(newpad, ix, sv);
+               SvPADTMP_on(sv);
+           }
+       }
+       av = newAV();
+       av_extend(av, 0);
+       av_store(newpad, 0, (SV*)av);
+       AvFLAGS(av) = AVf_REIFY;
+
+       av_store(padlist, depth, (SV*)newpad);
+       AvFILLp(padlist) = depth;
+    }
+}
+
+#define dMULTICALL \
+    SV **newsp;                        /* set by POPBLOCK */                   
\
+    PERL_CONTEXT *cx;                                                  \
+    CV *multicall_cv;                                                  \
+    OP *multicall_cop;                                                 \
+    bool multicall_oldcatch;                                           \
+    U8 hasargs = 0
+
+/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
+   return op is now stored on the cxstack. */
+#define HAS_RETSTACK (\
+  PERL_REVISION < 5 || \
+  (PERL_REVISION == 5 && PERL_VERSION < 9) || \
+  (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
+)
+
+
+/* PUSHSUB is defined so differently on different versions of perl
+ * that it's easier to define our own version than code for all the
+ * different possibilities.
+ */
+#if HAS_RETSTACK
+#  define PUSHSUB_RETSTACK(cx)
+#else
+#  define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
+#endif
+#define MULTICALL_PUSHSUB(cx, the_cv) \
+        cx->blk_sub.cv = the_cv;                                       \
+        cx->blk_sub.olddepth = CvDEPTH(the_cv);                                
\
+        cx->blk_sub.hasargs = hasargs;                                 \
+        cx->blk_sub.lval = PL_op->op_private &                         \
+                              (OPpLVAL_INTRO|OPpENTERSUB_INARGS);      \
+       PUSHSUB_RETSTACK(cx)                                            \
+        if (!CvDEPTH(the_cv)) {                                                
\
+            (void)SvREFCNT_inc(the_cv);                                        
\
+            (void)SvREFCNT_inc(the_cv);                                        
\
+            SAVEFREESV(the_cv);                                                
\
+        }
+
+#define PUSH_MULTICALL(the_cv) \
+    STMT_START {                                                       \
+       CV *_nOnclAshIngNamE_ = the_cv;                                 \
+       AV* padlist = CvPADLIST(_nOnclAshIngNamE_);                     \
+       multicall_cv = _nOnclAshIngNamE_;                               \
+       ENTER;                                                          \
+       multicall_oldcatch = CATCH_GET;                                 \
+       SAVESPTR(CvROOT(multicall_cv)->op_ppaddr);                      \
+       CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL];           \
+       SAVETMPS; SAVEVPTR(PL_op);                                      \
+       CATCH_SET(TRUE);                                                \
+       PUSHSTACKi(PERLSI_SORT);                                        \
+       PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);                            \
+       MULTICALL_PUSHSUB(cx, multicall_cv);                            \
+       if (++CvDEPTH(multicall_cv) >= 2) {                             \
+           PERL_STACK_OVERFLOW_CHECK();                                \
+           multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv));   \
+       }                                                               \
+       SAVECOMPPAD();                                                  \
+       PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]);   \
+       PL_curpad = AvARRAY(PL_comppad);                                \
+       multicall_cop = CvSTART(multicall_cv);                          \
+    } STMT_END
+
+#define MULTICALL \
+    STMT_START {                                                       \
+       PL_op = multicall_cop;                                          \
+       CALLRUNOPS(aTHX);                                               \
+    } STMT_END
+
+#define POP_MULTICALL \
+    STMT_START {                                                       \
+       CvDEPTH(multicall_cv)--;                                        \
+       LEAVESUB(multicall_cv);                                         \
+       POPBLOCK(cx,PL_curpm);                                          \
+       POPSTACK;                                                       \
+       CATCH_SET(multicall_oldcatch);                                  \
+       LEAVE;                                                          \
+        SPAGAIN;                                                        \
+    } STMT_END
+
+#endif

-- 
Alioth's /usr/local/bin/git-commit-notice on 
/srv/git.debian.org/git/pkg-perl/packages/libmath-prime-util-perl.git

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to