[libmath-prime-util-perl] 02/11: Add forprimes multicall
Partha P. Mukherjee
ppm-guest at moszumanska.debian.org
Thu May 21 18:48:31 UTC 2015
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 <dana at 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
More information about the Pkg-perl-cvs-commits
mailing list