* The original code was written in conjunction with BSD Computer Software
* Research Group at University of California, Berkeley.
*
- * See also: "Optimistic Merge Sort" (SODA '92)
+ * See also: "Optimistic Sorting and Information Theoretic Complexity"
+ * Peter McIlroy
+ * SODA (Fourth Annual ACM-SIAM Symposium on Discrete Algorithms),
+ * pp 467-474, Austin, Texas, 25-27 January 1993.
*
- * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
+ * The integration to Perl is by John P. Linderman <jpl.jpl@gmail.com>.
*
* The code can be distributed under the same terms as Perl itself.
*
#define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
-/* Runs are identified by a pointer in the auxilliary list.
+/* Runs are identified by a pointer in the auxiliary list.
** The pointer is at the start of the list,
** and it points to the start of the next list.
** NEXT is used as an lvalue, too.
dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, const SVCOMPARE_t cmp)
{
I32 sense;
- register gptr *b, *p, *q, *t, *p2;
- register gptr *last, *r;
+ gptr *b, *p, *q, *t, *p2;
+ gptr *last, *r;
IV runs = 0;
b = list1;
static I32
cmp_desc(pTHX_ gptr const a, gptr const b)
{
- dVAR;
return -PL_sort_RealCmp(aTHX_ a, b);
}
STATIC void
S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
{
- dVAR;
IV i, run, offset;
I32 sense, level;
- register gptr *f1, *f2, *t, *b, *p;
+ gptr *f1, *f2, *t, *b, *p;
int iwhich;
gptr *aux;
gptr *p1;
}
if (nmemb <= SMALLSORT) aux = small; /* use stack for aux array */
- else { Newx(aux,nmemb,gptr); } /* allocate auxilliary array */
+ else { Newx(aux,nmemb,gptr); } /* allocate auxiliary array */
level = 0;
stackp = stack;
stackp->runs = dynprep(aTHX_ base, aux, nmemb, cmp);
list1 = which[iwhich]; /* area where runs are now */
list2 = which[++iwhich]; /* area for merged runs */
do {
- register gptr *l1, *l2, *tp2;
+ gptr *l1, *l2, *tp2;
offset = stackp->offset;
f1 = p1 = list1 + offset; /* start of first run */
p = tp2 = list2 + offset; /* where merged run will go */
** and -1 when equality should look high.
*/
- register gptr *q;
+ gptr *q;
if (cmp(aTHX_ *f1, *f2) <= 0) {
q = f2; b = f1; t = l1;
sense = -1;
t = NEXT(t); /* where second run will end */
t = PINDEX(base, PNELEM(aux, t)); /* where it now ends */
FROMTOUPTO(f1, f2, t); /* copy both runs */
- NEXT(b) = p; /* paralled pointer for 1st */
+ NEXT(b) = p; /* paralleled pointer for 1st */
NEXT(p) = t; /* ... and for second */
}
}
}
-done:
+ done:
if (aux != small) Safefree(aux); /* free iff allocated */
if (flags) {
PL_sort_RealCmp = savecmp; /* Restore current comparison routine, if any */
STATIC void /* the standard unstable (u) quicksort (qsort) */
S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
{
- register SV * temp;
+ SV * temp;
struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
int next_stack_entry = 0;
int part_left;
return;
}
- /* Innoculate large partitions against quadratic behavior */
+ /* Inoculate large partitions against quadratic behavior */
if (num_elts > QSORT_PLAY_SAFE) {
- register size_t n;
- register SV ** const q = array;
+ size_t n;
+ SV ** const q = array;
for (n = num_elts; n > 1; ) {
- register const size_t j = (size_t)(n-- * Drand01());
+ const size_t j = (size_t)(n-- * Drand01());
temp = q[j];
q[j] = q[n];
q[n] = temp;
elements in the middle of the partition, those are the ones we
pick here (conveniently pointed at by u_right, pc_left, and
u_left). The values of the left, center, and right elements
- are refered to as l c and r in the following comments.
+ are referred to as l c and r in the following comments.
*/
#ifdef QSORT_ORDER_GUESS
static I32
cmpindir(pTHX_ gptr const a, gptr const b)
{
- dVAR;
gptr * const ap = (gptr *)a;
gptr * const bp = (gptr *)b;
const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
static I32
cmpindir_desc(pTHX_ gptr const a, gptr const b)
{
- dVAR;
gptr * const ap = (gptr *)a;
gptr * const bp = (gptr *)b;
const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp);
STATIC void
S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
{
- dVAR;
if ((flags & SORTf_STABLE) != 0) {
- register gptr **pp, *q;
- register size_t n, j, i;
+ gptr **pp, *q;
+ size_t n, j, i;
gptr *small[SMALLSORT], **indir, tmp;
SVCOMPARE_t savecmp;
if (nmemb <= 1) return; /* sorted trivially */
q = list1;
for (n = nmemb; n--; ) {
/* Assert A: all elements of q with index > n are already
- * in place. This is vacuosly true at the start, and we
+ * in place. This is vacuously true at the start, and we
* put element n where it belongs below (if it wasn't
* already where it belonged). Assert B: we only move
* elements that aren't where they belong,
=for apidoc sortsv
-Sort an array. Here is an example:
+Sort an array. Here is an example:
- sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
+ sortsv(AvARRAY(av), av_top_index(av)+1, Perl_sv_cmp_locale);
-Currently this always uses mergesort. See sortsv_flags for a more
+Currently this always uses mergesort. See C<L</sortsv_flags>> for a more
flexible routine.
=cut
PP(pp_sort)
{
- dVAR; dSP; dMARK; dORIGMARK;
- register SV **p1 = ORIGMARK+1, **p2;
- register I32 max, i;
+ dSP; dMARK; dORIGMARK;
+ SV **p1 = ORIGMARK+1, **p2;
+ SSize_t max, i;
AV* av = NULL;
- HV *stash;
GV *gv;
CV *cv = NULL;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
OP* const nextop = PL_op->op_next;
I32 overloading = 0;
bool hasargs = FALSE;
+ bool copytmps;
I32 is_xsub = 0;
I32 sorting_av = 0;
const U8 priv = PL_op->op_private;
SAVEVPTR(PL_sortcop);
if (flags & OPf_STACKED) {
if (flags & OPf_SPECIAL) {
- OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
- kid = kUNOP->op_first; /* pass rv2gv */
- kid = kUNOP->op_first; /* pass leave */
- PL_sortcop = kid->op_next;
- stash = CopSTASH(PL_curcop);
+ OP *nullop = OpSIBLING(cLISTOP->op_first); /* pass pushmark */
+ assert(nullop->op_type == OP_NULL);
+ PL_sortcop = nullop->op_next;
}
else {
- cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ GV *autogv = NULL;
+ HV *stash;
+ cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
+ check_cv:
if (cv && SvPOK(cv)) {
const char * const proto = SvPV_nolen_const(MUTABLE_SV(cv));
if (proto && strEQ(proto, "$$")) {
hasargs = TRUE;
}
}
- if (!(cv && CvROOT(cv))) {
- if (cv && CvISXSUB(cv)) {
- is_xsub = 1;
+ if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
+ is_xsub = 1;
+ }
+ else if (!(cv && CvROOT(cv))) {
+ if (gv) {
+ goto autoload;
}
- else if (gv) {
+ else if (!CvANON(cv) && (gv = CvGV(cv))) {
+ if (cv != GvCV(gv)) cv = GvCV(gv);
+ autoload:
+ if (!autogv && (
+ autogv = gv_autoload_pvn(
+ GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0
+ )
+ )) {
+ cv = GvCVu(autogv);
+ goto check_cv;
+ }
+ else {
SV *tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called",
SVfARG(tmpstr));
+ }
}
else {
DIE(aTHX_ "Undefined subroutine in sort");
}
else {
PL_sortcop = NULL;
- stash = CopSTASH(PL_curcop);
}
/* optimiser converts "@a = sort @a" to "sort \@a";
}
else {
if (SvREADONLY(av))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
else
+ {
SvREADONLY_on(av);
+ save_pushptr((void *)av, SAVEt_READONLY_OFF);
+ }
p1 = p2 = AvARRAY(av);
sorting_av = 1;
}
/* shuffle stack down, removing optional initial cv (p1!=p2), plus
* any nulls; also stringify or converting to integer or number as
* required any args */
+ copytmps = !sorting_av && PL_sortcop;
for (i=max; i > 0 ; i--) {
if ((*p1 = *p2++)) { /* Weed out nulls. */
+ if (copytmps && SvPADTMP(*p1)) {
+ *p1 = sv_mortalcopy(*p1);
+ }
SvTEMP_off(*p1);
if (!PL_sortcop) {
if (priv & OPpSORT_NUMERIC) {
SV **start;
if (PL_sortcop) {
PERL_CONTEXT *cx;
- SV** newsp;
const bool oldcatch = CATCH_GET;
+ I32 old_savestack_ix = PL_savestack_ix;
- SAVETMPS;
SAVEOP();
CATCH_SET(TRUE);
PUSHSTACKi(PERLSI_SORT);
if (!hasargs && !is_xsub) {
- SAVESPTR(PL_firstgv);
- SAVESPTR(PL_secondgv);
- SAVESPTR(PL_sortstash);
- PL_firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV);
- PL_secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV);
- PL_sortstash = stash;
+ SAVEGENERICSV(PL_firstgv);
+ SAVEGENERICSV(PL_secondgv);
+ PL_firstgv = MUTABLE_GV(SvREFCNT_inc(
+ gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)
+ ));
+ PL_secondgv = MUTABLE_GV(SvREFCNT_inc(
+ gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)
+ ));
+ /* make sure the GP isn't removed out from under us for
+ * the SAVESPTR() */
+ save_gp(PL_firstgv, 0);
+ save_gp(PL_secondgv, 0);
+ /* we don't want modifications localized */
+ GvINTRO_off(PL_firstgv);
+ GvINTRO_off(PL_secondgv);
SAVESPTR(GvSV(PL_firstgv));
SAVESPTR(GvSV(PL_secondgv));
}
+ gimme = G_SCALAR;
PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
if (!(flags & OPf_SPECIAL)) {
- cx->cx_type = CXt_SUB;
- cx->blk_gimme = G_SCALAR;
- /* If our comparison routine is already active (CvDEPTH is
- * is not 0), then PUSHSUB does not increase the refcount,
- * so we have to do it ourselves, because the LEAVESUB fur-
- * ther down lowers it. */
- if (CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv);
+ cx->cx_type = CXt_SUB|CXp_MULTICALL;
PUSHSUB(cx);
if (!is_xsub) {
- AV* const padlist = CvPADLIST(cv);
+ PADLIST * const padlist = CvPADLIST(cv);
if (++CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv));
}
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (hasargs) {
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
- CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
}
}
}
- cx->cx_type |= CXp_MULTICALL;
-
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
+
start = p1 - max;
sortsvp(aTHX_ start, max,
(is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
sort_flags);
+ /* Reset cx, in case the context stack has been reallocated. */
+ cx = &cxstack[cxstack_ix];
+
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+
if (!(flags & OPf_SPECIAL)) {
- SV *sv;
- POPSUB(cx, sv);
- LEAVESUB(sv);
+ assert(CxTYPE(cx) == CXt_SUB);
+ POPSUB(cx);
}
- POPBLOCK(cx,PL_curpm);
- PL_stack_sp = newsp;
+ else {
+ assert(CxTYPE(cx) == CXt_NULL);
+ CX_LEAVE_SCOPE(cx);
+ }
+
+ POPBLOCK(cx);
+ cxstack_ix--;
POPSTACK;
CATCH_SET(oldcatch);
}
? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
: ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
- : ( IN_LOCALE_RUNTIME
+ : (
+#ifdef USE_LOCALE_COLLATE
+ IN_LC_RUNTIME(LC_COLLATE)
? ( overloading
? (SVCOMPARE_t)S_amagic_cmp_locale
: (SVCOMPARE_t)sv_cmp_locale_static)
- : ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
+ :
+#endif
+ ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
sort_flags);
}
if ((priv & OPpSORT_REVERSE) != 0) {
static I32
S_sortcv(pTHX_ SV *const a, SV *const b)
{
- dVAR;
const I32 oldsaveix = PL_savestack_ix;
const I32 oldscopeix = PL_scopestack_ix;
I32 result;
+ PMOP * const pm = PL_curpm;
+ COP * const cop = PL_curcop;
PERL_ARGS_ASSERT_SORTCV;
PL_stack_sp = PL_stack_base;
PL_op = PL_sortcop;
CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+ PL_curcop = cop;
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
+
while (PL_scopestack_ix > oldscopeix) {
LEAVE;
}
leave_scope(oldsaveix);
+ PL_curpm = pm;
return result;
}
static I32
S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
{
- dVAR;
const I32 oldsaveix = PL_savestack_ix;
const I32 oldscopeix = PL_scopestack_ix;
I32 result;
AV * const av = GvAV(PL_defgv);
+ PMOP * const pm = PL_curpm;
+ COP * const cop = PL_curcop;
PERL_ARGS_ASSERT_SORTCV_STACKED;
PL_stack_sp = PL_stack_base;
PL_op = PL_sortcop;
CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+ PL_curcop = cop;
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
+
while (PL_scopestack_ix > oldscopeix) {
LEAVE;
}
leave_scope(oldsaveix);
+ PL_curpm = pm;
return result;
}
static I32
S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
{
- dVAR; dSP;
+ dSP;
const I32 oldsaveix = PL_savestack_ix;
const I32 oldscopeix = PL_scopestack_ix;
CV * const cv=MUTABLE_CV(PL_sortcop);
I32 result;
+ PMOP * const pm = PL_curpm;
PERL_ARGS_ASSERT_SORTCV_XSUB;
*++SP = b;
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
result = SvIV(*PL_stack_sp);
+
while (PL_scopestack_ix > oldscopeix) {
LEAVE;
}
leave_scope(oldsaveix);
+ PL_curpm = pm;
return result;
}
PERL_ARGS_ASSERT_SV_NCMP;
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
+#else
+ if (nv1 != nv1 || nv2 != nv2) {
+#endif
+ if (ckWARN(WARN_UNINITIALIZED)) report_uninit(NULL);
+ return 0;
+ }
return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
}
}
#define tryCALL_AMAGICbin(left,right,meth) \
- (PL_amagic_generation && (SvAMAGIC(left)||SvAMAGIC(right))) \
- ? amagic_call(left, right, CAT2(meth,_amg), 0) \
+ (SvAMAGIC(left)||SvAMAGIC(right)) \
+ ? amagic_call(left, right, meth, 0) \
: NULL;
#define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
static I32
-S_amagic_ncmp(pTHX_ register SV *const a, register SV *const b)
+S_amagic_ncmp(pTHX_ SV *const a, SV *const b)
{
- dVAR;
- SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
+ SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
PERL_ARGS_ASSERT_AMAGIC_NCMP;
}
static I32
-S_amagic_i_ncmp(pTHX_ register SV *const a, register SV *const b)
+S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b)
{
- dVAR;
- SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp);
+ SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg);
PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
}
static I32
-S_amagic_cmp(pTHX_ register SV *const str1, register SV *const str2)
+S_amagic_cmp(pTHX_ SV *const str1, SV *const str2)
{
- dVAR;
- SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
+ SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
PERL_ARGS_ASSERT_AMAGIC_CMP;
return sv_cmp(str1, str2);
}
+#ifdef USE_LOCALE_COLLATE
+
static I32
-S_amagic_cmp_locale(pTHX_ register SV *const str1, register SV *const str2)
+S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2)
{
- dVAR;
- SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp);
+ SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg);
PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
return sv_cmp_locale(str1, str2);
}
+#endif
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: t
- * End:
- *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff