From 5983a79d5f38082aa0cba7c8ab4e8a4472979e59 Mon Sep 17 00:00:00 2001 From: Ben Morrow Date: Mon, 11 Oct 2010 06:19:44 +0100 Subject: [PATCH] Add LINKLIST to the API. Also rename the underlying function to op_linklist, to match the other API op functions. --- embed.fnc | 2 +- embed.h | 2 +- ext/XS-APItest/APItest.xs | 115 ++++++++++++++++++++++++++++++++++++++++++++- ext/XS-APItest/t/op_list.t | 5 +- global.sym | 1 + op.c | 31 ++++++++---- op.h | 15 ++++++ proto.h | 10 ++-- 8 files changed, 162 insertions(+), 19 deletions(-) diff --git a/embed.fnc b/embed.fnc index 4ef49ba..e111448 100644 --- a/embed.fnc +++ b/embed.fnc @@ -175,6 +175,7 @@ Ap |int |Gv_AMupdate |NN HV* stash|bool destructing ApR |CV* |gv_handler |NULLOK HV* stash|I32 id Apd |OP* |op_append_elem |I32 optype|NULLOK OP* first|NULLOK OP* last Apd |OP* |op_append_list |I32 optype|NULLOK OP* first|NULLOK OP* last +Apd |OP* |op_linklist |NN OP *o Apd |OP* |op_prepend_elem|I32 optype|NULLOK OP* first|NULLOK OP* last : FIXME - this is only called by pp_chown. They should be merged. p |I32 |apply |I32 type|NN SV** mark|NN SV** sp @@ -637,7 +638,6 @@ EXp |void |op_clear |NN OP* o Ap |void |op_refcnt_lock Ap |void |op_refcnt_unlock #if defined(PERL_IN_OP_C) -s |OP* |linklist |NN OP *o s |OP* |listkids |NULLOK OP* o #endif : Used in S_doeval in pp_ctl.c diff --git a/embed.h b/embed.h index 72c16a4..f186c99 100644 --- a/embed.h +++ b/embed.h @@ -369,6 +369,7 @@ #define op_contextualize(a,b) Perl_op_contextualize(aTHX_ a,b) #define op_dump(a) Perl_op_dump(aTHX_ a) #define op_free(a) Perl_op_free(aTHX_ a) +#define op_linklist(a) Perl_op_linklist(aTHX_ a) #define op_null(a) Perl_op_null(aTHX_ a) #define op_prepend_elem(a,b,c) Perl_op_prepend_elem(aTHX_ a,b,c) #define op_refcnt_lock() Perl_op_refcnt_lock(aTHX) @@ -1639,7 +1640,6 @@ #define is_handle_constructor S_is_handle_constructor #define is_inplace_av(a,b) S_is_inplace_av(aTHX_ a,b) #define is_list_assignment(a) S_is_list_assignment(aTHX_ a) -#define linklist(a) S_linklist(aTHX_ a) #define listkids(a) S_listkids(aTHX_ a) #define looks_like_bool(a) S_looks_like_bool(aTHX_ a) #define modkids(a,b) S_modkids(aTHX_ a,b) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index cadfaa4..e39281f 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -448,6 +448,66 @@ test_op_list_describe(OP *o) return SvPVX(res); } +/* the real new*OP functions have a tendancy to call fold_constants, and + * other such unhelpful things, so we need our own versions for testing */ + +#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f)) +static OP * +THX_mkUNOP(pTHX_ U32 type, OP *first) +{ + UNOP *unop; + NewOp(1103, unop, 1, UNOP); + unop->op_type = (OPCODE)type; + unop->op_first = first; + unop->op_flags = OPf_KIDS; + return (OP *)unop; +} + +#define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l)) +static OP * +THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last) +{ + BINOP *binop; + NewOp(1103, binop, 1, BINOP); + binop->op_type = (OPCODE)type; + binop->op_first = first; + binop->op_flags = OPf_KIDS; + binop->op_last = last; + first->op_sibling = last; + return (OP *)binop; +} + +#define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l)) +static OP * +THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last) +{ + LISTOP *listop; + NewOp(1103, listop, 1, LISTOP); + listop->op_type = (OPCODE)type; + listop->op_flags = OPf_KIDS; + listop->op_first = first; + first->op_sibling = sib; + sib->op_sibling = last; + listop->op_last = last; + return (OP *)listop; +} + +static char * +test_op_linklist_describe(OP *start) +{ + SV *rv = sv_2mortal(newSVpvs("")); + OP *o; + o = start = LINKLIST(start); + do { + sv_catpvs(rv, "."); + sv_catpv(rv, OP_NAME(o)); + if (o->op_type == OP_CONST) + sv_catsv(rv, cSVOPo->op_sv); + o = o->op_next; + } while (o && o != start); + return SvPVX(rv); +} + /** RPN keyword parser **/ #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV) @@ -1932,10 +1992,63 @@ test_op_list() check_op(a, "lineseq[list[pushmark.const(1).const(2).]" "const(3).const(4).]"); op_free(a); -#undef iv_op #undef check_op void +test_op_linklist () + PREINIT: + OP *o; + CODE: +#define check_ll(o, expect) \ + STMT_START { \ + if (strNE(test_op_linklist_describe(o), (expect))) \ + croak("fail %s %s", test_op_linklist_describe(o), (expect)); \ + } STMT_END + o = iv_op(1); + check_ll(o, ".const1"); + op_free(o); + + o = mkUNOP(OP_NOT, iv_op(1)); + check_ll(o, ".const1.not"); + op_free(o); + + o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1))); + check_ll(o, ".const1.negate.not"); + op_free(o); + + o = mkBINOP(OP_ADD, iv_op(1), iv_op(2)); + check_ll(o, ".const1.const2.add"); + op_free(o); + + o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2)); + check_ll(o, ".const1.not.const2.add"); + op_free(o); + + o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2))); + check_ll(o, ".const1.const2.add.not"); + op_free(o); + + o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3)); + check_ll(o, ".const1.const2.const3.lineseq"); + op_free(o); + + o = mkLISTOP(OP_LINESEQ, + mkBINOP(OP_ADD, iv_op(1), iv_op(2)), + mkUNOP(OP_NOT, iv_op(3)), + mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6))); + check_ll(o, ".const1.const2.add.const3.not" + ".const4.const5.const6.substr.lineseq"); + op_free(o); + + o = mkBINOP(OP_ADD, iv_op(1), iv_op(2)); + LINKLIST(o); + o = mkBINOP(OP_SUBTRACT, o, iv_op(3)); + check_ll(o, ".const1.const2.add.const3.subtract"); + op_free(o); +#undef check_ll +#undef iv_op + +void peep_enable () PREINIT: dMY_CXT; diff --git a/ext/XS-APItest/t/op_list.t b/ext/XS-APItest/t/op_list.t index e5b55a9..c7b990a 100644 --- a/ext/XS-APItest/t/op_list.t +++ b/ext/XS-APItest/t/op_list.t @@ -1,10 +1,13 @@ use warnings; use strict; -use Test::More tests => 1; +use Test::More tests => 2; use XS::APItest; XS::APItest::test_op_list(); ok 1; +XS::APItest::test_op_linklist(); +ok 1; + 1; diff --git a/global.sym b/global.sym index 11a2961..d888892 100644 --- a/global.sym +++ b/global.sym @@ -414,6 +414,7 @@ Perl_op_clear Perl_op_contextualize Perl_op_dump Perl_op_free +Perl_op_linklist Perl_op_null Perl_op_prepend_elem Perl_op_refcnt_lock diff --git a/op.c b/op.c index ee2c9f3..aa33ba2 100644 --- a/op.c +++ b/op.c @@ -843,14 +843,22 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) } } -#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) +/* +=head1 Optree Manipulation Functions -static OP * -S_linklist(pTHX_ OP *o) +=for apidoc Am|OP*|op_linklist|OP *o +This function is the implementation of the L macro. It should +not be called directly. + +=cut +*/ + +OP * +Perl_op_linklist(pTHX_ OP *o) { OP *first; - PERL_ARGS_ASSERT_LINKLIST; + PERL_ARGS_ASSERT_OP_LINKLIST; if (o->op_next) return o->op_next; @@ -2417,7 +2425,10 @@ Perl_newPROG(pTHX_ OP *o) PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); - PL_eval_start = linklist(PL_eval_root); + /* don't use LINKLIST, since PL_eval_root might indirect through + * a rather expensive function call and LINKLIST evaluates its + * argument more than once */ + PL_eval_start = op_linklist(PL_eval_root); PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; @@ -2703,7 +2714,7 @@ S_gen_constant_list(pTHX_ register OP *o) #else op_free(curop); #endif - linklist(o); + LINKLIST(o); return list(o); } @@ -5180,7 +5191,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) flip = newUNOP(OP_FLIP, flags, (OP*)range); flop = newUNOP(OP_FLOP, 0, flip); o = newUNOP(OP_NULL, 0, flop); - linklist(flop); + LINKLIST(flop); range->op_next = leftstart; left->op_next = flip; @@ -5196,7 +5207,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) flip->op_next = o; if (!flip->op_private || !flop->op_private) - linklist(o); /* blow off optimizer unless constant */ + LINKLIST(o); /* blow off optimizer unless constant */ return o; } @@ -7434,7 +7445,7 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; - linklist(kid); + LINKLIST(kid); newop->op_next = newop; kid = newop; kid->op_sibling = sibl; @@ -8263,7 +8274,7 @@ Perl_ck_sort(pTHX_ OP *o) OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { - linklist(kid); + LINKLIST(kid); if (kid->op_type == OP_SCOPE) { k = kid->op_next; kid->op_next = 0; diff --git a/op.h b/op.h index 71bab3e..5135ff0 100644 --- a/op.h +++ b/op.h @@ -622,6 +622,21 @@ struct loop { #define ref(o, type) doref(o, type, TRUE) #endif +/* +=head1 Optree Manipulation Functions + +=for apidoc Am|OP*|LINKLIST|OP *o +Given the root of an optree, link the tree in execution order using the +C pointers and return the first op executed. If this has +already been done, it will not be redone, and C<< o->op_next >> will be +returned. If C<< o->op_next >> is not already set, I should be at +least an C. + +=cut +*/ + +#define LINKLIST(o) ((o)->op_next ? (o)->op_next : op_linklist((OP*)o)) + /* no longer used anywhere in core */ #ifndef PERL_CORE #define cv_ckproto(cv, gv, p) \ diff --git a/proto.h b/proto.h index 45483e9..aff9574 100644 --- a/proto.h +++ b/proto.h @@ -2694,6 +2694,11 @@ PERL_CALLCONV void Perl_op_dump(pTHX_ const OP *o) assert(o) PERL_CALLCONV void Perl_op_free(pTHX_ OP* arg); +PERL_CALLCONV OP* Perl_op_linklist(pTHX_ OP *o) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OP_LINKLIST \ + assert(o) + PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_NULL \ @@ -5689,11 +5694,6 @@ STATIC OP* S_is_inplace_av(pTHX_ OP* o, OP* oright) STATIC I32 S_is_list_assignment(pTHX_ const OP *o) __attribute__warn_unused_result__; -STATIC OP* S_linklist(pTHX_ OP *o) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_LINKLIST \ - assert(o) - STATIC OP* S_listkids(pTHX_ OP* o); STATIC bool S_looks_like_bool(pTHX_ const OP* o) __attribute__nonnull__(pTHX_1); -- 1.8.3.1