sR |OP* |search_const |NN OP *o
sR |OP* |new_logop |I32 type|I32 flags|NN OP **firstp|NN OP **otherp
s |void |simplify_sort |NN OP *o
+s |bool |simplify_sort_aelem |NN OP **o
s |const char* |gv_ename |NN GV *gv
sRn |bool |scalar_mod_type|NULLOK const OP *o|I32 type
s |OP * |my_kid |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp
#if defined(PERL_IN_PP_SORT_C)
s |I32 |sv_ncmp |NN SV *const a|NN SV *const b
+s |I32 |sv_ncmp_deref |NN SV *const a|NN SV *const b
s |I32 |sv_i_ncmp |NN SV *const a|NN SV *const b
+s |I32 |sv_i_ncmp_deref |NN SV *const a|NN SV *const b
+s |I32 |sv_cmp_deref |NN SV *const a|NN SV *const b
+s |I32 |sv_cmp_locale_deref |NN SV *const a|NN SV *const b
s |I32 |amagic_ncmp |NN SV *const a|NN SV *const b
s |I32 |amagic_i_ncmp |NN SV *const a|NN SV *const b
s |I32 |amagic_cmp |NN SV *const str1|NN SV *const str2
#define scalarseq(a) S_scalarseq(aTHX_ a)
#define search_const(a) S_search_const(aTHX_ a)
#define simplify_sort(a) S_simplify_sort(aTHX_ a)
+#define simplify_sort_aelem(a) S_simplify_sort_aelem(aTHX_ a)
#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
#define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b)
# endif
#define sortcv(a,b) S_sortcv(aTHX_ a,b)
#define sortcv_stacked(a,b) S_sortcv_stacked(aTHX_ a,b)
#define sortcv_xsub(a,b) S_sortcv_xsub(aTHX_ a,b)
+#define sv_cmp_deref(a,b) S_sv_cmp_deref(aTHX_ a,b)
+#define sv_cmp_locale_deref(a,b) S_sv_cmp_locale_deref(aTHX_ a,b)
#define sv_i_ncmp(a,b) S_sv_i_ncmp(aTHX_ a,b)
+#define sv_i_ncmp_deref(a,b) S_sv_i_ncmp_deref(aTHX_ a,b)
#define sv_ncmp(a,b) S_sv_ncmp(aTHX_ a,b)
+#define sv_ncmp_deref(a,b) S_sv_ncmp_deref(aTHX_ a,b)
# endif
# if defined(PERL_IN_PP_SYS_C)
#define doform(a,b,c) S_doform(aTHX_ a,b,c)
#include "perl.h"
#include "keywords.h"
+#include <stdio.h>
+#include <stdlib.h>
+
#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
return o;
}
+/* This function will modify *o only if
+ * it also returns TRUE, ie. if the array-deref sort
+ * optimization is (for this half of the comparison op)
+ * applicable.
+ */
+STATIC bool
+S_simplify_sort_aelem(pTHX_ OP **o)
+{
+ SV* const_sv;
+ IV const_val;
+ register OP *kid = *o;
+
+ PERL_ARGS_ASSERT_SIMPLIFY_SORT_AELEM;
+
+ /* check for the constant array index */
+ if (kBINOP->op_last->op_type != OP_CONST)
+ return FALSE;
+ /* TODO Shall we check the const_val only or can we
+ * somehow pass it to the optimized sort sub? If we check
+ * it only, we will optimize just the case where it's 0. */
+ /* FIXME Is SvIV needed or do we know for the SV in the OP_CONST
+ * that it's safe to access the IV more directly. Or can
+ * OP_CONST be other stuff? Do we need to check SvIOK or
+ * other stuff? */
+ /* FIXME Is the intermediate store in an SV necessary? Is an
+ * intermediate required for the ->op_last? Compiler fu
+ * failure on my part. */
+ const_sv = cSVOPx_sv(kBINOP->op_last);
+ const_val = SvIV(const_sv);
+ if (const_val != 0)
+ return FALSE;
+
+ if (kBINOP->op_first->op_type != OP_RV2AV)
+ return FALSE;
+ kid = kBINOP->op_first; /* get past aelem */
+ if (kBINOP->op_first->op_type != OP_RV2SV)
+ return FALSE;
+ kid = kBINOP->op_first; /* get past rv2av */
+ if (kUNOP->op_first->op_type != OP_GV)
+ return FALSE;
+ kid = kUNOP->op_first; /* get past rv2sv */
+ *o = kid;
+ return TRUE;
+}
+
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
int descending;
GV *gv;
const char *gvname;
+ bool is_aelem;
PERL_ARGS_ASSERT_SIMPLIFY_SORT;
return;
}
comparison_op = kid; /* remember this node*/
- if (kBINOP->op_first->op_type != OP_RV2SV)
- return;
- kid = kBINOP->op_first; /* get past cmp */
- if (kUNOP->op_first->op_type != OP_GV)
- return;
- kid = kUNOP->op_first; /* get past rv2sv */
+
+ is_aelem = kBINOP->op_first->op_type == OP_AELEM;
+ if (is_aelem) {
+ /* array-deref optimization path: $a->[0] <=> $b->[0] or similar */
+ OP *kid_arg;
+
+ kid = kBINOP->op_first; /* get past cmp */
+ /* check if this is an array deref with a constant */
+
+ kid_arg = kid; /* kid's a register, can't use address */
+ is_aelem = simplify_sort_aelem(&kid_arg);
+ if (!is_aelem)
+ return;
+ kid = kid_arg;
+ }
+ else { /* normal optimization path: $a <=> $b or similar */
+ if (kBINOP->op_first->op_type != OP_RV2SV)
+ return;
+ kid = kBINOP->op_first; /* get past cmp */
+ if (kUNOP->op_first->op_type != OP_GV)
+ return;
+ kid = kUNOP->op_first; /* get past rv2sv */
+ }
+
+ /* check if the variable of the left side is $a or $b */
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash)
return;
else
return;
+ /* check that the other side of the cmp is compatible... */
kid = comparison_op; /* back to cmp */
- if (kBINOP->op_last->op_type != OP_RV2SV)
- return;
- kid = kBINOP->op_last; /* down to 2nd arg */
- if (kUNOP->op_first->op_type != OP_GV)
- return;
- kid = kUNOP->op_first; /* get past rv2sv */
+ if (kBINOP->op_last->op_type == OP_AELEM) {
+ /* array-deref optimization path: $a->[0] <=> $b->[0] or similar */
+ OP *kid_arg;
+
+ kid = kBINOP->op_last; /* get past cmp */
+ /* check if this is an array deref with a constant */
+ kid_arg = kid; /* kid's a register, can't use address */
+ is_aelem = simplify_sort_aelem(&kid_arg);
+ if (!is_aelem)
+ return;
+ kid = kid_arg;
+ }
+ else { /* normal optimization path: $a <=> $b or similar */
+ if (kBINOP->op_last->op_type != OP_RV2SV)
+ return;
+ /* down to 2nd arg past cmp*/
+ kid = kBINOP->op_last;
+ if (kUNOP->op_first->op_type != OP_GV)
+ return;
+ kid = kUNOP->op_first; /* get past rv2sv */
+ }
+
+ /* check if the variable of the right side is $a or $b */
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash)
return;
gvname = GvNAME(gv);
+ /* expect the counterpart of $a or $b depending on 'descending' */
if ( descending
? !(*gvname == 'a' && gvname[1] == '\0')
: !(*gvname == 'b' && gvname[1] == '\0'))
return;
+
o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
+
if (descending)
o->op_private |= OPpSORT_DESCEND;
+
+ if (is_aelem) {
+ o->op_private |= OPpSORT_DEREF;
+ /* also re-fetch the OP_CONST from the second side
+ * since it's the last in the tree */
+ /* FIXME Rewalking the tree? This can't be the right way */
+ kid = comparison_op;
+ kid = kBINOP->op_last; /* cmp => aelem */
+ kid = kBINOP->op_last; /* aelem => const */
+ }
+
if (comparison_op->op_type == OP_NCMP)
o->op_private |= OPpSORT_NUMERIC;
- if (comparison_op->op_type == OP_I_NCMP)
+ else if (comparison_op->op_type == OP_I_NCMP)
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
+
kid = cLISTOPo->op_first->op_sibling;
cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
#ifdef PERL_MAD
#define OPpSORT_DESCEND 16 /* Descending sort */
#define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */
#define OPpSORT_STABLE 64 /* Use a stable algorithm */
+#define OPpSORT_DEREF 128 /* Optimized away {$a->[0] <=> $b->[0]}
+ or {$a->[0] cmp $b->[0]} */
/* Private for OP_REVERSE */
#define OPpREVERSE_INPLACE 8 /* reverse in-place (@a = reverse @a) */
else {
if (!SvNSIOK(*p1))
(void)sv_2nv_flags(*p1, SV_GMAGIC|SV_SKIP_OVERLOAD);
+ /* TODO Consider the following carefully:
+ * In the array-deref case, we could check whether the inner SV
+ * is IOK and auto-detect the integer sort. That could speed things
+ * up a little bit. But according to my simple benchmarks, the numeric
+ * sort on $a->[0] <=> $b->[0] is just < 2% slower than the integer
+ * sort, so we don't bother here as it might actually eat up much of the
+ * benefit.
+ */
if (all_SIVs && !SvSIOK(*p1))
all_SIVs = 0;
}
else {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
start = sorting_av ? AvARRAY(av) : ORIGMARK+1;
+ /* TODO triple nested ternary? We must be able to do better than that */
sortsvp(aTHX_ start, max,
(priv & OPpSORT_NUMERIC)
+ /* numeric cmp */
? ( ( ( priv & OPpSORT_INTEGER) || all_SIVs)
- ? ( overloading ? S_amagic_i_ncmp : S_sv_i_ncmp)
- : ( overloading ? S_amagic_ncmp : S_sv_ncmp ) )
+ /* integer cmp */
+ ? ( priv & OPpSORT_DEREF
+ ? S_sv_i_ncmp_deref /* currently honors magic no matter what */
+ : (overloading ? S_amagic_i_ncmp : S_sv_i_ncmp) )
+ /* float cmp */
+ : ( priv & OPpSORT_DEREF
+ ? S_sv_ncmp_deref /* currently honors magic no matter what */
+ : (overloading ? S_amagic_ncmp : S_sv_ncmp) ) )
+ /* string cmp */
: ( IN_LOCALE_RUNTIME
- ? ( overloading
- ? (SVCOMPARE_t)S_amagic_cmp_locale
- : (SVCOMPARE_t)sv_cmp_locale_static)
- : ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static)),
+ ? ( priv & OPpSORT_DEREF
+ ? S_sv_cmp_locale_deref /* currently honors magic no matter what */
+ : ( overloading ? (SVCOMPARE_t)S_amagic_cmp_locale : (SVCOMPARE_t)sv_cmp_locale_static) )
+ : ( priv & OPpSORT_DEREF
+ ? S_sv_cmp_deref /* currently honors magic no matter what */
+ : ( overloading ? (SVCOMPARE_t)S_amagic_cmp : (SVCOMPARE_t)sv_cmp_static) ) ),
sort_flags);
}
if ((priv & OPpSORT_REVERSE) != 0) {
#define SORT_NORMAL_RETURN_VALUE(val) (((val) > 0) ? 1 : ((val) ? -1 : 0))
+#define short_circuit_MAGIC_result(tmpsv) \
+ STMT_START { \
+ if (tmpsv) { \
+ if (SvIOK(tmpsv)) { \
+ const I32 i = SvIVX(tmpsv); \
+ return SORT_NORMAL_RETURN_VALUE(i); \
+ } \
+ else { \
+ const NV d = SvNV(tmpsv); \
+ return SORT_NORMAL_RETURN_VALUE(d); \
+ } \
+ } \
+ } STMT_END
+
static I32
S_amagic_ncmp(pTHX_ register SV *const a, register SV *const b)
{
PERL_ARGS_ASSERT_AMAGIC_NCMP;
- if (tmpsv) {
- if (SvIOK(tmpsv)) {
- const I32 i = SvIVX(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(i);
- }
- else {
- const NV d = SvNV(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(d);
- }
- }
- return S_sv_ncmp(aTHX_ a, b);
+ short_circuit_MAGIC_result(tmpsv);
+ return S_sv_ncmp(aTHX_ a, b);
}
static I32
PERL_ARGS_ASSERT_AMAGIC_I_NCMP;
- if (tmpsv) {
- if (SvIOK(tmpsv)) {
- const I32 i = SvIVX(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(i);
- }
- else {
- const NV d = SvNV(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(d);
- }
- }
+ short_circuit_MAGIC_result(tmpsv);
return S_sv_i_ncmp(aTHX_ a, b);
}
PERL_ARGS_ASSERT_AMAGIC_CMP;
- if (tmpsv) {
- if (SvIOK(tmpsv)) {
- const I32 i = SvIVX(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(i);
- }
- else {
- const NV d = SvNV(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(d);
- }
- }
+ short_circuit_MAGIC_result(tmpsv);
return sv_cmp(str1, str2);
}
PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE;
+ short_circuit_MAGIC_result(tmpsv);
+ return sv_cmp_locale(str1, str2);
+}
+
+/* Checks in the following code could be moved to the preprocessing
+ * step in pp_sort. In fact, that might make tons of sense since it
+ * could include moving the inner-magic check out of the O(nlogn) part.
+ */
+#define REUSABLE_DEREF_BODY \
+ STMT_START { \
+ SvGETMAGIC(a); /* FIXME check for this outside the */ \
+ SvGETMAGIC(b); /* sort function somehow */ \
+ if (!SvROK(a) || !SvROK(b)) { \
+ Perl_croak(aTHX_ "Not an ARRAY reference"); \
+ } \
+ a = SvRV(a); \
+ b = SvRV(b); \
+ if (SvTYPE(a) != SVt_PVAV || SvTYPE(a) != SVt_PVAV) { \
+ Perl_croak(aTHX_ "Not an ARRAY reference"); \
+ } \
+ elem1 = Perl_av_fetch(aTHX_ (AV*)a, 0, 0); \
+ elem2 = Perl_av_fetch(aTHX_ (AV*)b, 0, 0); \
+ if (*elem1 == &PL_sv_undef) { \
+ mg_get(*elem1); \
+ } \
+ if (*elem2 == &PL_sv_undef) { \
+ mg_get(*elem2); \
+ } \
+ } STMT_END
+
+/* sort function for float {$a->[0] <=> $b->[0]} */
+static I32
+S_sv_ncmp_deref(pTHX_ SV *a, SV *b)
+{
+ SV **elem1, **elem2;
+ SV *tmpsv;
+
+ PERL_ARGS_ASSERT_SV_NCMP_DEREF;
+
+ REUSABLE_DEREF_BODY;
+
+ tmpsv = tryCALL_AMAGICbin(*elem1,*elem2,ncmp_amg);
if (tmpsv) {
- if (SvIOK(tmpsv)) {
- const I32 i = SvIVX(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(i);
- }
- else {
- const NV d = SvNV(tmpsv);
- return SORT_NORMAL_RETURN_VALUE(d);
- }
+ short_circuit_MAGIC_result(tmpsv);
}
- return sv_cmp_locale(str1, str2);
+
+ return S_sv_ncmp(aTHX_ *elem1, *elem2);
+}
+
+/* sort function for 'use integer' {$a->[0] <=> $b->[0]} */
+static I32
+S_sv_i_ncmp_deref(pTHX_ SV *a, SV *b)
+{
+ SV **elem1, **elem2;
+ SV *tmpsv;
+
+ PERL_ARGS_ASSERT_SV_I_NCMP_DEREF;
+
+ REUSABLE_DEREF_BODY;
+
+ tmpsv = tryCALL_AMAGICbin(*elem1,*elem2,ncmp_amg);
+ if (tmpsv) {
+ short_circuit_MAGIC_result(tmpsv);
+ }
+
+ return S_sv_i_ncmp(aTHX_ *elem1, *elem2);
+}
+
+/* sort function for {$a->[0] cmp $b->[0]} */
+static I32
+S_sv_cmp_deref(pTHX_ SV *a, SV *b)
+{
+ SV **elem1, **elem2;
+ SV *tmpsv;
+
+ PERL_ARGS_ASSERT_SV_CMP_DEREF;
+
+ REUSABLE_DEREF_BODY;
+
+ tmpsv = tryCALL_AMAGICbin(*elem1,*elem2,scmp_amg);
+ if (tmpsv) {
+ short_circuit_MAGIC_result(tmpsv);
+ }
+
+ return ((SVCOMPARE_t)sv_cmp_static)(aTHX_ *elem1, *elem2);
+}
+
+/* sort function for {$a->[0] cmp $b->[0]} under locale */
+static I32
+S_sv_cmp_locale_deref(pTHX_ SV *a, SV *b)
+{
+ SV **elem1, **elem2;
+ SV *tmpsv;
+
+ PERL_ARGS_ASSERT_SV_CMP_LOCALE_DEREF;
+
+ REUSABLE_DEREF_BODY;
+
+ tmpsv = tryCALL_AMAGICbin(*elem1,*elem2,scmp_amg);
+ if (tmpsv) {
+ short_circuit_MAGIC_result(tmpsv);
+ }
+
+ return ((SVCOMPARE_t)sv_cmp_locale_static)(aTHX_ *elem1, *elem2);
}
/*
#define PERL_ARGS_ASSERT_SIMPLIFY_SORT \
assert(o)
+STATIC bool S_simplify_sort_aelem(pTHX_ OP **o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SIMPLIFY_SORT_AELEM \
+ assert(o)
+
STATIC OP* S_too_few_arguments(pTHX_ OP *o, const char* name)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
#define PERL_ARGS_ASSERT_SORTCV_XSUB \
assert(a); assert(b)
+STATIC I32 S_sv_cmp_deref(pTHX_ SV *const a, SV *const b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CMP_DEREF \
+ assert(a); assert(b)
+
+STATIC I32 S_sv_cmp_locale_deref(pTHX_ SV *const a, SV *const b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_CMP_LOCALE_DEREF \
+ assert(a); assert(b)
+
STATIC I32 S_sv_i_ncmp(pTHX_ SV *const a, SV *const b)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_SV_I_NCMP \
assert(a); assert(b)
+STATIC I32 S_sv_i_ncmp_deref(pTHX_ SV *const a, SV *const b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_I_NCMP_DEREF \
+ assert(a); assert(b)
+
STATIC I32 S_sv_ncmp(pTHX_ SV *const a, SV *const b)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_SV_NCMP \
assert(a); assert(b)
+STATIC I32 S_sv_ncmp_deref(pTHX_ SV *const a, SV *const b)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_NCMP_DEREF \
+ assert(a); assert(b)
+
#endif
#if defined(PERL_IN_PP_SYS_C)
STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
projects / perl.git / commitdiff
