* 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.
*
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;
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;
}
}
}
-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;
/* 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 */
=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;
+ U8 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 {
GV *autogv = NULL;
+ HV *stash;
cv = sv_2cv(*++MARK, &stash, &gv, GV_ADD);
check_cv:
if (cv && SvPOK(cv)) {
hasargs = TRUE;
}
}
- if (!(cv && CvROOT(cv))) {
- if (cv && CvISXSUB(cv)) {
- is_xsub = 1;
- }
- else if (gv) {
+ if (cv && CvISXSUB(cv) && CvXSUB(cv)) {
+ is_xsub = 1;
+ }
+ else if (!(cv && CvROOT(cv))) {
+ if (gv) {
goto autoload;
}
else if (!CvANON(cv) && (gv = CvGV(cv))) {
}
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));
}
- PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
+ gimme = G_SCALAR;
+ cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix);
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);
- PUSHSUB(cx);
+ cx->cx_type = CXt_SUB|CXp_MULTICALL;
+ cx_pushsub(cx, cv, NULL, hasargs);
if (!is_xsub) {
- AV* const padlist = CvPADLIST(cv);
+ PADLIST * const padlist = CvPADLIST(cv);
- if (++CvDEPTH(cv) >= 2) {
- PERL_STACK_OVERFLOW_CHECK();
+ if (++CvDEPTH(cv) >= 2)
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;
-
+
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 = CX_CUR();
+
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+
+ CX_LEAVE_SCOPE(cx);
if (!(flags & OPf_SPECIAL)) {
- SV *sv;
- /* Reset cx, in case the context stack has been
- reallocated. */
- cx = &cxstack[cxstack_ix];
- POPSUB(cx, sv);
- LEAVESUB(sv);
+ assert(CxTYPE(cx) == CXt_SUB);
+ cx_popsub(cx);
}
- POPBLOCK(cx,PL_curpm);
- PL_stack_sp = newsp;
+ else
+ assert(CxTYPE(cx) == CXt_NULL);
+ /* there isn't a POPNULL ! */
+
+ cx_popblock(cx);
+ CX_POP(cx);
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;
- OP * const sortop = PL_op;
+ 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_op = sortop;
+ 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);
+
+ 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;
- OP * const sortop = PL_op;
+ 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_op = sortop;
+ 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);
+
+ 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;
*++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);
+
+ LEAVE_SCOPE(oldsaveix);
PL_curpm = pm;
return result;
}
PERL_ARGS_ASSERT_SV_NCMP;
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- if (Perl_isnan(right) || Perl_isnan(left)) {
+ if (Perl_isnan(nv1) || Perl_isnan(nv2)) {
#else
if (nv1 != nv1 || nv2 != nv2) {
#endif
#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_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_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_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_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:
*/