4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* remove any leading "empty" ops from the op_next chain whose first
175 * node's address is stored in op_p. Store the updated address of the
176 * first node in op_p.
180 S_prune_chain_head(OP** op_p)
183 && ( (*op_p)->op_type == OP_NULL
184 || (*op_p)->op_type == OP_SCOPE
185 || (*op_p)->op_type == OP_SCALAR
186 || (*op_p)->op_type == OP_LINESEQ)
188 *op_p = (*op_p)->op_next;
192 /* See the explanatory comments above struct opslab in op.h. */
194 #ifdef PERL_DEBUG_READONLY_OPS
195 # define PERL_SLAB_SIZE 128
196 # define PERL_MAX_SLAB_SIZE 4096
197 # include <sys/mman.h>
200 #ifndef PERL_SLAB_SIZE
201 # define PERL_SLAB_SIZE 64
203 #ifndef PERL_MAX_SLAB_SIZE
204 # define PERL_MAX_SLAB_SIZE 2048
207 /* rounds up to nearest pointer */
208 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
209 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
211 /* malloc a new op slab (suitable for attaching to PL_compcv) */
214 S_new_slab(pTHX_ size_t sz)
216 #ifdef PERL_DEBUG_READONLY_OPS
217 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
218 PROT_READ|PROT_WRITE,
219 MAP_ANON|MAP_PRIVATE, -1, 0);
220 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
221 (unsigned long) sz, slab));
222 if (slab == MAP_FAILED) {
223 perror("mmap failed");
226 slab->opslab_size = (U16)sz;
228 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
231 /* The context is unused in non-Windows */
234 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
238 /* requires double parens and aTHX_ */
239 #define DEBUG_S_warn(args) \
241 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
244 /* Returns a sz-sized block of memory (suitable for holding an op) from
245 * a free slot in the chain of op slabs attached to PL_compcv.
246 * Allocates a new slab if necessary.
247 * if PL_compcv isn't compiling, malloc() instead.
251 Perl_Slab_Alloc(pTHX_ size_t sz)
259 /* We only allocate ops from the slab during subroutine compilation.
260 We find the slab via PL_compcv, hence that must be non-NULL. It could
261 also be pointing to a subroutine which is now fully set up (CvROOT()
262 pointing to the top of the optree for that sub), or a subroutine
263 which isn't using the slab allocator. If our sanity checks aren't met,
264 don't use a slab, but allocate the OP directly from the heap. */
265 if (!PL_compcv || CvROOT(PL_compcv)
266 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
268 o = (OP*)PerlMemShared_calloc(1, sz);
272 /* While the subroutine is under construction, the slabs are accessed via
273 CvSTART(), to avoid needing to expand PVCV by one pointer for something
274 unneeded at runtime. Once a subroutine is constructed, the slabs are
275 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
276 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
278 if (!CvSTART(PL_compcv)) {
280 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
281 CvSLABBED_on(PL_compcv);
282 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
284 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
286 opsz = SIZE_TO_PSIZE(sz);
287 sz = opsz + OPSLOT_HEADER_P;
289 /* The slabs maintain a free list of OPs. In particular, constant folding
290 will free up OPs, so it makes sense to re-use them where possible. A
291 freed up slot is used in preference to a new allocation. */
292 if (slab->opslab_freed) {
293 OP **too = &slab->opslab_freed;
295 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
296 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
297 DEBUG_S_warn((aTHX_ "Alas! too small"));
298 o = *(too = &o->op_next);
299 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
303 Zero(o, opsz, I32 *);
309 #define INIT_OPSLOT \
310 slot->opslot_slab = slab; \
311 slot->opslot_next = slab2->opslab_first; \
312 slab2->opslab_first = slot; \
313 o = &slot->opslot_op; \
316 /* The partially-filled slab is next in the chain. */
317 slab2 = slab->opslab_next ? slab->opslab_next : slab;
318 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
319 /* Remaining space is too small. */
321 /* If we can fit a BASEOP, add it to the free chain, so as not
323 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
324 slot = &slab2->opslab_slots;
326 o->op_type = OP_FREED;
327 o->op_next = slab->opslab_freed;
328 slab->opslab_freed = o;
331 /* Create a new slab. Make this one twice as big. */
332 slot = slab2->opslab_first;
333 while (slot->opslot_next) slot = slot->opslot_next;
334 slab2 = S_new_slab(aTHX_
335 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
337 : (DIFF(slab2, slot)+1)*2);
338 slab2->opslab_next = slab->opslab_next;
339 slab->opslab_next = slab2;
341 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
343 /* Create a new op slot */
344 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
345 assert(slot >= &slab2->opslab_slots);
346 if (DIFF(&slab2->opslab_slots, slot)
347 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
348 slot = &slab2->opslab_slots;
350 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
353 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
354 assert(!o->op_moresib);
355 assert(!o->op_sibparent);
362 #ifdef PERL_DEBUG_READONLY_OPS
364 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
366 PERL_ARGS_ASSERT_SLAB_TO_RO;
368 if (slab->opslab_readonly) return;
369 slab->opslab_readonly = 1;
370 for (; slab; slab = slab->opslab_next) {
371 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
372 (unsigned long) slab->opslab_size, slab));*/
373 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
374 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
375 (unsigned long)slab->opslab_size, errno);
380 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
384 PERL_ARGS_ASSERT_SLAB_TO_RW;
386 if (!slab->opslab_readonly) return;
388 for (; slab2; slab2 = slab2->opslab_next) {
389 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
390 (unsigned long) size, slab2));*/
391 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
392 PROT_READ|PROT_WRITE)) {
393 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
394 (unsigned long)slab2->opslab_size, errno);
397 slab->opslab_readonly = 0;
401 # define Slab_to_rw(op) NOOP
404 /* This cannot possibly be right, but it was copied from the old slab
405 allocator, to which it was originally added, without explanation, in
408 # define PerlMemShared PerlMem
411 /* make freed ops die if they're inadvertently executed */
416 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
421 /* Return the block of memory used by an op to the free list of
422 * the OP slab associated with that op.
426 Perl_Slab_Free(pTHX_ void *op)
428 OP * const o = (OP *)op;
431 PERL_ARGS_ASSERT_SLAB_FREE;
434 o->op_ppaddr = S_pp_freed;
437 if (!o->op_slabbed) {
439 PerlMemShared_free(op);
444 /* If this op is already freed, our refcount will get screwy. */
445 assert(o->op_type != OP_FREED);
446 o->op_type = OP_FREED;
447 o->op_next = slab->opslab_freed;
448 slab->opslab_freed = o;
449 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
450 OpslabREFCNT_dec_padok(slab);
454 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
456 const bool havepad = !!PL_comppad;
457 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
460 PAD_SAVE_SETNULLPAD();
466 /* Free a chain of OP slabs. Should only be called after all ops contained
467 * in it have been freed. At this point, its reference count should be 1,
468 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
469 * and just directly calls opslab_free().
470 * (Note that the reference count which PL_compcv held on the slab should
471 * have been removed once compilation of the sub was complete).
477 Perl_opslab_free(pTHX_ OPSLAB *slab)
480 PERL_ARGS_ASSERT_OPSLAB_FREE;
482 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
483 assert(slab->opslab_refcnt == 1);
485 slab2 = slab->opslab_next;
487 slab->opslab_refcnt = ~(size_t)0;
489 #ifdef PERL_DEBUG_READONLY_OPS
490 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
492 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
493 perror("munmap failed");
497 PerlMemShared_free(slab);
503 /* like opslab_free(), but first calls op_free() on any ops in the slab
504 * not marked as OP_FREED
508 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
512 size_t savestack_count = 0;
514 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
518 for (slot = slab2->opslab_first;
520 slot = slot->opslot_next) {
521 if (slot->opslot_op.op_type != OP_FREED
522 && !(slot->opslot_op.op_savefree
528 assert(slot->opslot_op.op_slabbed);
529 op_free(&slot->opslot_op);
530 if (slab->opslab_refcnt == 1) goto free;
533 } while ((slab2 = slab2->opslab_next));
534 /* > 1 because the CV still holds a reference count. */
535 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
537 assert(savestack_count == slab->opslab_refcnt-1);
539 /* Remove the CV’s reference count. */
540 slab->opslab_refcnt--;
547 #ifdef PERL_DEBUG_READONLY_OPS
549 Perl_op_refcnt_inc(pTHX_ OP *o)
552 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
553 if (slab && slab->opslab_readonly) {
566 Perl_op_refcnt_dec(pTHX_ OP *o)
569 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
571 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
573 if (slab && slab->opslab_readonly) {
575 result = --o->op_targ;
578 result = --o->op_targ;
584 * In the following definition, the ", (OP*)0" is just to make the compiler
585 * think the expression is of the right type: croak actually does a Siglongjmp.
587 #define CHECKOP(type,o) \
588 ((PL_op_mask && PL_op_mask[type]) \
589 ? ( op_free((OP*)o), \
590 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
592 : PL_check[type](aTHX_ (OP*)o))
594 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
596 #define OpTYPE_set(o,type) \
598 o->op_type = (OPCODE)type; \
599 o->op_ppaddr = PL_ppaddr[type]; \
603 S_no_fh_allowed(pTHX_ OP *o)
605 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
607 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
613 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
615 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
616 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
621 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
623 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
625 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
630 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
632 PERL_ARGS_ASSERT_BAD_TYPE_PV;
634 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
635 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
638 /* remove flags var, its unused in all callers, move to to right end since gv
639 and kid are always the same */
641 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
643 SV * const namesv = cv_name((CV *)gv, NULL, 0);
644 PERL_ARGS_ASSERT_BAD_TYPE_GV;
646 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
647 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
651 S_no_bareword_allowed(pTHX_ OP *o)
653 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
655 qerror(Perl_mess(aTHX_
656 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
658 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
661 /* "register" allocation */
664 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
667 const bool is_our = (PL_parser->in_my == KEY_our);
669 PERL_ARGS_ASSERT_ALLOCMY;
671 if (flags & ~SVf_UTF8)
672 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
675 /* complain about "my $<special_var>" etc etc */
679 || ( (flags & SVf_UTF8)
680 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
681 || (name[1] == '_' && len > 2)))
683 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
685 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
686 /* diag_listed_as: Can't use global %s in "%s" */
687 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
688 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
689 PL_parser->in_my == KEY_state ? "state" : "my"));
691 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
692 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
696 /* allocate a spare slot and store the name in that slot */
698 off = pad_add_name_pvn(name, len,
699 (is_our ? padadd_OUR :
700 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
701 PL_parser->in_my_stash,
703 /* $_ is always in main::, even with our */
704 ? (PL_curstash && !memEQs(name,len,"$_")
710 /* anon sub prototypes contains state vars should always be cloned,
711 * otherwise the state var would be shared between anon subs */
713 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
714 CvCLONE_on(PL_compcv);
720 =head1 Optree Manipulation Functions
722 =for apidoc alloccopstash
724 Available only under threaded builds, this function allocates an entry in
725 C<PL_stashpad> for the stash passed to it.
732 Perl_alloccopstash(pTHX_ HV *hv)
734 PADOFFSET off = 0, o = 1;
735 bool found_slot = FALSE;
737 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
739 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
741 for (; o < PL_stashpadmax; ++o) {
742 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
743 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
744 found_slot = TRUE, off = o;
747 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
748 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
749 off = PL_stashpadmax;
750 PL_stashpadmax += 10;
753 PL_stashpad[PL_stashpadix = off] = hv;
758 /* free the body of an op without examining its contents.
759 * Always use this rather than FreeOp directly */
762 S_op_destroy(pTHX_ OP *o)
772 Free an op and its children. Only use this when an op is no longer linked
779 Perl_op_free(pTHX_ OP *o)
785 bool went_up = FALSE; /* whether we reached the current node by
786 following the parent pointer from a child, and
787 so have already seen this node */
789 if (!o || o->op_type == OP_FREED)
792 if (o->op_private & OPpREFCOUNTED) {
793 /* if base of tree is refcounted, just decrement */
794 switch (o->op_type) {
804 refcnt = OpREFCNT_dec(o);
807 /* Need to find and remove any pattern match ops from
808 * the list we maintain for reset(). */
809 find_and_forget_pmops(o);
822 /* free child ops before ourself, (then free ourself "on the
825 if (!went_up && o->op_flags & OPf_KIDS) {
826 next_op = cUNOPo->op_first;
830 /* find the next node to visit, *then* free the current node
831 * (can't rely on o->op_* fields being valid after o has been
834 /* The next node to visit will be either the sibling, or the
835 * parent if no siblings left, or NULL if we've worked our way
836 * back up to the top node in the tree */
837 next_op = (o == top_op) ? NULL : o->op_sibparent;
838 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
840 /* Now process the current node */
842 /* Though ops may be freed twice, freeing the op after its slab is a
844 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
845 /* During the forced freeing of ops after compilation failure, kidops
846 may be freed before their parents. */
847 if (!o || o->op_type == OP_FREED)
852 /* an op should only ever acquire op_private flags that we know about.
853 * If this fails, you may need to fix something in regen/op_private.
854 * Don't bother testing if:
855 * * the op_ppaddr doesn't match the op; someone may have
856 * overridden the op and be doing strange things with it;
857 * * we've errored, as op flags are often left in an
858 * inconsistent state then. Note that an error when
859 * compiling the main program leaves PL_parser NULL, so
860 * we can't spot faults in the main code, only
861 * evaled/required code */
863 if ( o->op_ppaddr == PL_ppaddr[type]
865 && !PL_parser->error_count)
867 assert(!(o->op_private & ~PL_op_private_valid[type]));
872 /* Call the op_free hook if it has been set. Do it now so that it's called
873 * at the right time for refcounted ops, but still before all of the kids
878 type = (OPCODE)o->op_targ;
881 Slab_to_rw(OpSLAB(o));
883 /* COP* is not cleared by op_clear() so that we may track line
884 * numbers etc even after null() */
885 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
897 /* S_op_clear_gv(): free a GV attached to an OP */
901 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
903 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
907 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
908 || o->op_type == OP_MULTIDEREF)
911 ? ((GV*)PAD_SVl(*ixp)) : NULL;
913 ? (GV*)(*svp) : NULL;
915 /* It's possible during global destruction that the GV is freed
916 before the optree. Whilst the SvREFCNT_inc is happy to bump from
917 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
918 will trigger an assertion failure, because the entry to sv_clear
919 checks that the scalar is not already freed. A check of for
920 !SvIS_FREED(gv) turns out to be invalid, because during global
921 destruction the reference count can be forced down to zero
922 (with SVf_BREAK set). In which case raising to 1 and then
923 dropping to 0 triggers cleanup before it should happen. I
924 *think* that this might actually be a general, systematic,
925 weakness of the whole idea of SVf_BREAK, in that code *is*
926 allowed to raise and lower references during global destruction,
927 so any *valid* code that happens to do this during global
928 destruction might well trigger premature cleanup. */
929 bool still_valid = gv && SvREFCNT(gv);
932 SvREFCNT_inc_simple_void(gv);
935 pad_swipe(*ixp, TRUE);
943 int try_downgrade = SvREFCNT(gv) == 2;
946 gv_try_downgrade(gv);
952 Perl_op_clear(pTHX_ OP *o)
957 PERL_ARGS_ASSERT_OP_CLEAR;
959 switch (o->op_type) {
960 case OP_NULL: /* Was holding old type, if any. */
963 case OP_ENTEREVAL: /* Was holding hints. */
964 case OP_ARGDEFELEM: /* Was holding signature index. */
968 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
975 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
977 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
980 case OP_METHOD_REDIR:
981 case OP_METHOD_REDIR_SUPER:
983 if (cMETHOPx(o)->op_rclass_targ) {
984 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
985 cMETHOPx(o)->op_rclass_targ = 0;
988 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
989 cMETHOPx(o)->op_rclass_sv = NULL;
992 case OP_METHOD_NAMED:
993 case OP_METHOD_SUPER:
994 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
995 cMETHOPx(o)->op_u.op_meth_sv = NULL;
998 pad_swipe(o->op_targ, 1);
1005 SvREFCNT_dec(cSVOPo->op_sv);
1006 cSVOPo->op_sv = NULL;
1009 Even if op_clear does a pad_free for the target of the op,
1010 pad_free doesn't actually remove the sv that exists in the pad;
1011 instead it lives on. This results in that it could be reused as
1012 a target later on when the pad was reallocated.
1015 pad_swipe(o->op_targ,1);
1025 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1030 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1031 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1034 if (cPADOPo->op_padix > 0) {
1035 pad_swipe(cPADOPo->op_padix, TRUE);
1036 cPADOPo->op_padix = 0;
1039 SvREFCNT_dec(cSVOPo->op_sv);
1040 cSVOPo->op_sv = NULL;
1044 PerlMemShared_free(cPVOPo->op_pv);
1045 cPVOPo->op_pv = NULL;
1049 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1053 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1054 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1056 if (o->op_private & OPpSPLIT_LEX)
1057 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1060 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1062 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1069 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1070 op_free(cPMOPo->op_code_list);
1071 cPMOPo->op_code_list = NULL;
1072 forget_pmop(cPMOPo);
1073 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1074 /* we use the same protection as the "SAFE" version of the PM_ macros
1075 * here since sv_clean_all might release some PMOPs
1076 * after PL_regex_padav has been cleared
1077 * and the clearing of PL_regex_padav needs to
1078 * happen before sv_clean_all
1081 if(PL_regex_pad) { /* We could be in destruction */
1082 const IV offset = (cPMOPo)->op_pmoffset;
1083 ReREFCNT_dec(PM_GETRE(cPMOPo));
1084 PL_regex_pad[offset] = &PL_sv_undef;
1085 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1089 ReREFCNT_dec(PM_GETRE(cPMOPo));
1090 PM_SETRE(cPMOPo, NULL);
1096 PerlMemShared_free(cUNOP_AUXo->op_aux);
1099 case OP_MULTICONCAT:
1101 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1102 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1103 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1104 * utf8 shared strings */
1105 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1106 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1108 PerlMemShared_free(p1);
1110 PerlMemShared_free(p2);
1111 PerlMemShared_free(aux);
1117 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118 UV actions = items->uv;
1120 bool is_hash = FALSE;
1123 switch (actions & MDEREF_ACTION_MASK) {
1126 actions = (++items)->uv;
1129 case MDEREF_HV_padhv_helem:
1132 case MDEREF_AV_padav_aelem:
1133 pad_free((++items)->pad_offset);
1136 case MDEREF_HV_gvhv_helem:
1139 case MDEREF_AV_gvav_aelem:
1141 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1143 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1147 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1150 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1152 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1154 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1156 goto do_vivify_rv2xv_elem;
1158 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1161 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1162 pad_free((++items)->pad_offset);
1163 goto do_vivify_rv2xv_elem;
1165 case MDEREF_HV_pop_rv2hv_helem:
1166 case MDEREF_HV_vivify_rv2hv_helem:
1169 do_vivify_rv2xv_elem:
1170 case MDEREF_AV_pop_rv2av_aelem:
1171 case MDEREF_AV_vivify_rv2av_aelem:
1173 switch (actions & MDEREF_INDEX_MASK) {
1174 case MDEREF_INDEX_none:
1177 case MDEREF_INDEX_const:
1181 pad_swipe((++items)->pad_offset, 1);
1183 SvREFCNT_dec((++items)->sv);
1189 case MDEREF_INDEX_padsv:
1190 pad_free((++items)->pad_offset);
1192 case MDEREF_INDEX_gvsv:
1194 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1196 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1201 if (actions & MDEREF_FLAG_last)
1214 actions >>= MDEREF_SHIFT;
1217 /* start of malloc is at op_aux[-1], where the length is
1219 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1224 if (o->op_targ > 0) {
1225 pad_free(o->op_targ);
1231 S_cop_free(pTHX_ COP* cop)
1233 PERL_ARGS_ASSERT_COP_FREE;
1236 if (! specialWARN(cop->cop_warnings))
1237 PerlMemShared_free(cop->cop_warnings);
1238 cophh_free(CopHINTHASH_get(cop));
1239 if (PL_curcop == cop)
1244 S_forget_pmop(pTHX_ PMOP *const o)
1246 HV * const pmstash = PmopSTASH(o);
1248 PERL_ARGS_ASSERT_FORGET_PMOP;
1250 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1251 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1253 PMOP **const array = (PMOP**) mg->mg_ptr;
1254 U32 count = mg->mg_len / sizeof(PMOP**);
1258 if (array[i] == o) {
1259 /* Found it. Move the entry at the end to overwrite it. */
1260 array[i] = array[--count];
1261 mg->mg_len = count * sizeof(PMOP**);
1262 /* Could realloc smaller at this point always, but probably
1263 not worth it. Probably worth free()ing if we're the
1266 Safefree(mg->mg_ptr);
1279 S_find_and_forget_pmops(pTHX_ OP *o)
1281 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1283 if (o->op_flags & OPf_KIDS) {
1284 OP *kid = cUNOPo->op_first;
1286 switch (kid->op_type) {
1291 forget_pmop((PMOP*)kid);
1293 find_and_forget_pmops(kid);
1294 kid = OpSIBLING(kid);
1302 Neutralizes an op when it is no longer needed, but is still linked to from
1309 Perl_op_null(pTHX_ OP *o)
1313 PERL_ARGS_ASSERT_OP_NULL;
1315 if (o->op_type == OP_NULL)
1318 o->op_targ = o->op_type;
1319 OpTYPE_set(o, OP_NULL);
1323 Perl_op_refcnt_lock(pTHX)
1324 PERL_TSA_ACQUIRE(PL_op_mutex)
1329 PERL_UNUSED_CONTEXT;
1334 Perl_op_refcnt_unlock(pTHX)
1335 PERL_TSA_RELEASE(PL_op_mutex)
1340 PERL_UNUSED_CONTEXT;
1346 =for apidoc op_sibling_splice
1348 A general function for editing the structure of an existing chain of
1349 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1350 you to delete zero or more sequential nodes, replacing them with zero or
1351 more different nodes. Performs the necessary op_first/op_last
1352 housekeeping on the parent node and op_sibling manipulation on the
1353 children. The last deleted node will be marked as as the last node by
1354 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1356 Note that op_next is not manipulated, and nodes are not freed; that is the
1357 responsibility of the caller. It also won't create a new list op for an
1358 empty list etc; use higher-level functions like op_append_elem() for that.
1360 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1361 the splicing doesn't affect the first or last op in the chain.
1363 C<start> is the node preceding the first node to be spliced. Node(s)
1364 following it will be deleted, and ops will be inserted after it. If it is
1365 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1368 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1369 If -1 or greater than or equal to the number of remaining kids, all
1370 remaining kids are deleted.
1372 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1373 If C<NULL>, no nodes are inserted.
1375 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1380 action before after returns
1381 ------ ----- ----- -------
1384 splice(P, A, 2, X-Y-Z) | | B-C
1388 splice(P, NULL, 1, X-Y) | | A
1392 splice(P, NULL, 3, NULL) | | A-B-C
1396 splice(P, B, 0, X-Y) | | NULL
1400 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1401 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1407 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1411 OP *last_del = NULL;
1412 OP *last_ins = NULL;
1415 first = OpSIBLING(start);
1419 first = cLISTOPx(parent)->op_first;
1421 assert(del_count >= -1);
1423 if (del_count && first) {
1425 while (--del_count && OpHAS_SIBLING(last_del))
1426 last_del = OpSIBLING(last_del);
1427 rest = OpSIBLING(last_del);
1428 OpLASTSIB_set(last_del, NULL);
1435 while (OpHAS_SIBLING(last_ins))
1436 last_ins = OpSIBLING(last_ins);
1437 OpMAYBESIB_set(last_ins, rest, NULL);
1443 OpMAYBESIB_set(start, insert, NULL);
1447 cLISTOPx(parent)->op_first = insert;
1449 parent->op_flags |= OPf_KIDS;
1451 parent->op_flags &= ~OPf_KIDS;
1455 /* update op_last etc */
1462 /* ought to use OP_CLASS(parent) here, but that can't handle
1463 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1465 type = parent->op_type;
1466 if (type == OP_CUSTOM) {
1468 type = XopENTRYCUSTOM(parent, xop_class);
1471 if (type == OP_NULL)
1472 type = parent->op_targ;
1473 type = PL_opargs[type] & OA_CLASS_MASK;
1476 lastop = last_ins ? last_ins : start ? start : NULL;
1477 if ( type == OA_BINOP
1478 || type == OA_LISTOP
1482 cLISTOPx(parent)->op_last = lastop;
1485 OpLASTSIB_set(lastop, parent);
1487 return last_del ? first : NULL;
1490 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1494 =for apidoc op_parent
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1502 Perl_op_parent(OP *o)
1504 PERL_ARGS_ASSERT_OP_PARENT;
1505 while (OpHAS_SIBLING(o))
1507 return o->op_sibparent;
1510 /* replace the sibling following start with a new UNOP, which becomes
1511 * the parent of the original sibling; e.g.
1513 * op_sibling_newUNOP(P, A, unop-args...)
1521 * where U is the new UNOP.
1523 * parent and start args are the same as for op_sibling_splice();
1524 * type and flags args are as newUNOP().
1526 * Returns the new UNOP.
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1534 kid = op_sibling_splice(parent, start, 1, NULL);
1535 newop = newUNOP(type, flags, kid);
1536 op_sibling_splice(parent, start, 0, newop);
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542 * the struct. Higher-level stuff should be done by S_new_logop() /
1543 * newLOGOP(). This function exists mainly to avoid op_first assignment
1544 * being spread throughout this file.
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1553 NewOp(1101, logop, 1, LOGOP);
1554 OpTYPE_set(logop, type);
1555 logop->op_first = first;
1556 logop->op_other = other;
1558 logop->op_flags = OPf_KIDS;
1559 while (kid && OpHAS_SIBLING(kid))
1560 kid = OpSIBLING(kid);
1562 OpLASTSIB_set(kid, (OP*)logop);
1567 /* Contextualizers */
1570 =for apidoc op_contextualize
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply. The modified op tree
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1583 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1585 case G_SCALAR: return scalar(o);
1586 case G_ARRAY: return list(o);
1587 case G_VOID: return scalarvoid(o);
1589 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1596 =for apidoc op_linklist
1597 This function is the implementation of the L</LINKLIST> macro. It should
1598 not be called directly.
1604 Perl_op_linklist(pTHX_ OP *o)
1608 PERL_ARGS_ASSERT_OP_LINKLIST;
1613 /* establish postfix order */
1614 first = cUNOPo->op_first;
1617 o->op_next = LINKLIST(first);
1620 OP *sibl = OpSIBLING(kid);
1622 kid->op_next = LINKLIST(sibl);
1637 S_scalarkids(pTHX_ OP *o)
1639 if (o && o->op_flags & OPf_KIDS) {
1641 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1648 S_scalarboolean(pTHX_ OP *o)
1650 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1652 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657 if (ckWARN(WARN_SYNTAX)) {
1658 const line_t oldline = CopLINE(PL_curcop);
1660 if (PL_parser && PL_parser->copline != NOLINE) {
1661 /* This ensures that warnings are reported at the first line
1662 of the conditional, not the last. */
1663 CopLINE_set(PL_curcop, PL_parser->copline);
1665 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666 CopLINE_set(PL_curcop, oldline);
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1676 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1679 const char funny = o->op_type == OP_PADAV
1680 || o->op_type == OP_RV2AV ? '@' : '%';
1681 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1683 if (cUNOPo->op_first->op_type != OP_GV
1684 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1686 return varname(gv, funny, 0, NULL, 0, subscript_type);
1689 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1694 S_op_varname(pTHX_ const OP *o)
1696 return S_op_varname_subscript(aTHX_ o, 1);
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702 if (o->op_type == OP_CONST) {
1704 if (SvPOK(*retsv)) {
1706 *retsv = sv_newmortal();
1707 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1710 else if (!SvOK(*retsv))
1713 else *retpv = "...";
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1720 const bool h = o->op_type == OP_HSLICE
1721 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1727 SV *keysv = NULL; /* just to silence compiler warnings */
1728 const char *key = NULL;
1730 if (!(o->op_private & OPpSLICEWARNING))
1732 if (PL_parser && PL_parser->error_count)
1733 /* This warning can be nonsensical when there is a syntax error. */
1736 kid = cLISTOPo->op_first;
1737 kid = OpSIBLING(kid); /* get past pushmark */
1738 /* weed out false positives: any ops that can return lists */
1739 switch (kid->op_type) {
1765 /* Don't warn if we have a nulled list either. */
1766 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1769 assert(OpSIBLING(kid));
1770 name = S_op_varname(aTHX_ OpSIBLING(kid));
1771 if (!name) /* XS module fiddling with the op tree */
1773 S_op_pretty(aTHX_ kid, &keysv, &key);
1774 assert(SvPOK(name));
1775 sv_chop(name,SvPVX(name)+1);
1777 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1781 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782 lbrack, key, rbrack);
1784 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1788 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1794 /* apply scalar context to the o subtree */
1797 Perl_scalar(pTHX_ OP *o)
1802 OP *next_kid = NULL; /* what op (if any) to process next */
1805 /* assumes no premature commitment */
1806 if (!o || (PL_parser && PL_parser->error_count)
1807 || (o->op_flags & OPf_WANT)
1808 || o->op_type == OP_RETURN)
1813 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1815 switch (o->op_type) {
1817 scalar(cBINOPo->op_first);
1818 /* convert what initially looked like a list repeat into a
1819 * scalar repeat, e.g. $s = (1) x $n
1821 if (o->op_private & OPpREPEAT_DOLIST) {
1822 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1823 assert(kid->op_type == OP_PUSHMARK);
1824 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1825 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1826 o->op_private &=~ OPpREPEAT_DOLIST;
1834 /* impose scalar context on everything except the condition */
1835 next_kid = OpSIBLING(cUNOPo->op_first);
1839 if (o->op_flags & OPf_KIDS)
1840 next_kid = cUNOPo->op_first; /* do all kids */
1843 /* the children of these ops are usually a list of statements,
1844 * except the leaves, whose first child is a corresponding enter
1849 kid = cLISTOPo->op_first;
1853 kid = cLISTOPo->op_first;
1855 kid = OpSIBLING(kid);
1858 OP *sib = OpSIBLING(kid);
1859 /* Apply void context to all kids except the last, which
1860 * is scalar (ignoring a trailing ex-nextstate in determining
1861 * if it's the last kid). E.g.
1862 * $scalar = do { void; void; scalar }
1863 * Except that 'when's are always scalar, e.g.
1864 * $scalar = do { given(..) {
1865 * when (..) { scalar }
1866 * when (..) { scalar }
1871 || ( !OpHAS_SIBLING(sib)
1872 && sib->op_type == OP_NULL
1873 && ( sib->op_targ == OP_NEXTSTATE
1874 || sib->op_targ == OP_DBSTATE )
1878 /* tail call optimise calling scalar() on the last kid */
1882 else if (kid->op_type == OP_LEAVEWHEN)
1888 NOT_REACHED; /* NOTREACHED */
1892 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1898 /* Warn about scalar context */
1899 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1900 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1903 const char *key = NULL;
1905 /* This warning can be nonsensical when there is a syntax error. */
1906 if (PL_parser && PL_parser->error_count)
1909 if (!ckWARN(WARN_SYNTAX)) break;
1911 kid = cLISTOPo->op_first;
1912 kid = OpSIBLING(kid); /* get past pushmark */
1913 assert(OpSIBLING(kid));
1914 name = S_op_varname(aTHX_ OpSIBLING(kid));
1915 if (!name) /* XS module fiddling with the op tree */
1917 S_op_pretty(aTHX_ kid, &keysv, &key);
1918 assert(SvPOK(name));
1919 sv_chop(name,SvPVX(name)+1);
1921 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1922 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1923 "%%%" SVf "%c%s%c in scalar context better written "
1924 "as $%" SVf "%c%s%c",
1925 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1926 lbrack, key, rbrack);
1928 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1930 "%%%" SVf "%c%" SVf "%c in scalar context better "
1931 "written as $%" SVf "%c%" SVf "%c",
1932 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1933 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1937 /* If next_kid is set, someone in the code above wanted us to process
1938 * that kid and all its remaining siblings. Otherwise, work our way
1939 * back up the tree */
1943 return top_op; /* at top; no parents/siblings to try */
1944 if (OpHAS_SIBLING(o))
1945 next_kid = o->op_sibparent;
1947 o = o->op_sibparent; /*try parent's next sibling */
1948 switch (o->op_type) {
1954 /* should really restore PL_curcop to its old value, but
1955 * setting it to PL_compiling is better than do nothing */
1956 PL_curcop = &PL_compiling;
1965 /* apply void context to the optree arg */
1968 Perl_scalarvoid(pTHX_ OP *arg)
1975 PERL_ARGS_ASSERT_SCALARVOID;
1979 SV *useless_sv = NULL;
1980 const char* useless = NULL;
1981 OP * next_kid = NULL;
1983 if (o->op_type == OP_NEXTSTATE
1984 || o->op_type == OP_DBSTATE
1985 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1986 || o->op_targ == OP_DBSTATE)))
1987 PL_curcop = (COP*)o; /* for warning below */
1989 /* assumes no premature commitment */
1990 want = o->op_flags & OPf_WANT;
1991 if ((want && want != OPf_WANT_SCALAR)
1992 || (PL_parser && PL_parser->error_count)
1993 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1998 if ((o->op_private & OPpTARGET_MY)
1999 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2001 /* newASSIGNOP has already applied scalar context, which we
2002 leave, as if this op is inside SASSIGN. */
2006 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2008 switch (o->op_type) {
2010 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2014 if (o->op_flags & OPf_STACKED)
2016 if (o->op_type == OP_REPEAT)
2017 scalar(cBINOPo->op_first);
2020 if ((o->op_flags & OPf_STACKED) &&
2021 !(o->op_private & OPpCONCAT_NESTED))
2025 if (o->op_private == 4)
2060 case OP_GETSOCKNAME:
2061 case OP_GETPEERNAME:
2066 case OP_GETPRIORITY:
2091 useless = OP_DESC(o);
2101 case OP_AELEMFAST_LEX:
2105 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2106 /* Otherwise it's "Useless use of grep iterator" */
2107 useless = OP_DESC(o);
2111 if (!(o->op_private & OPpSPLIT_ASSIGN))
2112 useless = OP_DESC(o);
2116 kid = cUNOPo->op_first;
2117 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2118 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2121 useless = "negative pattern binding (!~)";
2125 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2126 useless = "non-destructive substitution (s///r)";
2130 useless = "non-destructive transliteration (tr///r)";
2137 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2138 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2139 useless = "a variable";
2144 if (cSVOPo->op_private & OPpCONST_STRICT)
2145 no_bareword_allowed(o);
2147 if (ckWARN(WARN_VOID)) {
2149 /* don't warn on optimised away booleans, eg
2150 * use constant Foo, 5; Foo || print; */
2151 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2153 /* the constants 0 and 1 are permitted as they are
2154 conventionally used as dummies in constructs like
2155 1 while some_condition_with_side_effects; */
2156 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2158 else if (SvPOK(sv)) {
2159 SV * const dsv = newSVpvs("");
2161 = Perl_newSVpvf(aTHX_
2163 pv_pretty(dsv, SvPVX_const(sv),
2164 SvCUR(sv), 32, NULL, NULL,
2166 | PERL_PV_ESCAPE_NOCLEAR
2167 | PERL_PV_ESCAPE_UNI_DETECT));
2168 SvREFCNT_dec_NN(dsv);
2170 else if (SvOK(sv)) {
2171 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2174 useless = "a constant (undef)";
2177 op_null(o); /* don't execute or even remember it */
2181 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2185 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2189 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2193 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2198 UNOP *refgen, *rv2cv;
2201 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2204 rv2gv = ((BINOP *)o)->op_last;
2205 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2208 refgen = (UNOP *)((BINOP *)o)->op_first;
2210 if (!refgen || (refgen->op_type != OP_REFGEN
2211 && refgen->op_type != OP_SREFGEN))
2214 exlist = (LISTOP *)refgen->op_first;
2215 if (!exlist || exlist->op_type != OP_NULL
2216 || exlist->op_targ != OP_LIST)
2219 if (exlist->op_first->op_type != OP_PUSHMARK
2220 && exlist->op_first != exlist->op_last)
2223 rv2cv = (UNOP*)exlist->op_last;
2225 if (rv2cv->op_type != OP_RV2CV)
2228 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2229 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2230 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2232 o->op_private |= OPpASSIGN_CV_TO_GV;
2233 rv2gv->op_private |= OPpDONT_INIT_GV;
2234 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2246 kid = cLOGOPo->op_first;
2247 if (kid->op_type == OP_NOT
2248 && (kid->op_flags & OPf_KIDS)) {
2249 if (o->op_type == OP_AND) {
2250 OpTYPE_set(o, OP_OR);
2252 OpTYPE_set(o, OP_AND);
2262 next_kid = OpSIBLING(cUNOPo->op_first);
2266 if (o->op_flags & OPf_STACKED)
2273 if (!(o->op_flags & OPf_KIDS))
2284 next_kid = cLISTOPo->op_first;
2287 /* If the first kid after pushmark is something that the padrange
2288 optimisation would reject, then null the list and the pushmark.
2290 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2291 && ( !(kid = OpSIBLING(kid))
2292 || ( kid->op_type != OP_PADSV
2293 && kid->op_type != OP_PADAV
2294 && kid->op_type != OP_PADHV)
2295 || kid->op_private & ~OPpLVAL_INTRO
2296 || !(kid = OpSIBLING(kid))
2297 || ( kid->op_type != OP_PADSV
2298 && kid->op_type != OP_PADAV
2299 && kid->op_type != OP_PADHV)
2300 || kid->op_private & ~OPpLVAL_INTRO)
2302 op_null(cUNOPo->op_first); /* NULL the pushmark */
2303 op_null(o); /* NULL the list */
2315 /* mortalise it, in case warnings are fatal. */
2316 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2317 "Useless use of %" SVf " in void context",
2318 SVfARG(sv_2mortal(useless_sv)));
2321 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2322 "Useless use of %s in void context",
2327 /* if a kid hasn't been nominated to process, continue with the
2328 * next sibling, or if no siblings left, go back to the parent's
2329 * siblings and so on
2333 return arg; /* at top; no parents/siblings to try */
2334 if (OpHAS_SIBLING(o))
2335 next_kid = o->op_sibparent;
2337 o = o->op_sibparent; /*try parent's next sibling */
2347 S_listkids(pTHX_ OP *o)
2349 if (o && o->op_flags & OPf_KIDS) {
2351 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2358 /* apply list context to the o subtree */
2361 Perl_list(pTHX_ OP *o)
2366 OP *next_kid = NULL; /* what op (if any) to process next */
2370 /* assumes no premature commitment */
2371 if (!o || (o->op_flags & OPf_WANT)
2372 || (PL_parser && PL_parser->error_count)
2373 || o->op_type == OP_RETURN)
2378 if ((o->op_private & OPpTARGET_MY)
2379 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2381 goto do_next; /* As if inside SASSIGN */
2384 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2386 switch (o->op_type) {
2388 if (o->op_private & OPpREPEAT_DOLIST
2389 && !(o->op_flags & OPf_STACKED))
2391 list(cBINOPo->op_first);
2392 kid = cBINOPo->op_last;
2393 /* optimise away (.....) x 1 */
2394 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2395 && SvIVX(kSVOP_sv) == 1)
2397 op_null(o); /* repeat */
2398 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2400 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2408 /* impose list context on everything except the condition */
2409 next_kid = OpSIBLING(cUNOPo->op_first);
2413 if (!(o->op_flags & OPf_KIDS))
2415 /* possibly flatten 1..10 into a constant array */
2416 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2417 list(cBINOPo->op_first);
2418 gen_constant_list(o);
2421 next_kid = cUNOPo->op_first; /* do all kids */
2425 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2426 op_null(cUNOPo->op_first); /* NULL the pushmark */
2427 op_null(o); /* NULL the list */
2429 if (o->op_flags & OPf_KIDS)
2430 next_kid = cUNOPo->op_first; /* do all kids */
2433 /* the children of these ops are usually a list of statements,
2434 * except the leaves, whose first child is a corresponding enter
2438 kid = cLISTOPo->op_first;
2442 kid = cLISTOPo->op_first;
2444 kid = OpSIBLING(kid);
2447 OP *sib = OpSIBLING(kid);
2448 /* Apply void context to all kids except the last, which
2450 * @a = do { void; void; list }
2451 * Except that 'when's are always list context, e.g.
2452 * @a = do { given(..) {
2453 * when (..) { list }
2454 * when (..) { list }
2459 /* tail call optimise calling list() on the last kid */
2463 else if (kid->op_type == OP_LEAVEWHEN)
2469 NOT_REACHED; /* NOTREACHED */
2474 /* If next_kid is set, someone in the code above wanted us to process
2475 * that kid and all its remaining siblings. Otherwise, work our way
2476 * back up the tree */
2480 return top_op; /* at top; no parents/siblings to try */
2481 if (OpHAS_SIBLING(o))
2482 next_kid = o->op_sibparent;
2484 o = o->op_sibparent; /*try parent's next sibling */
2485 switch (o->op_type) {
2491 /* should really restore PL_curcop to its old value, but
2492 * setting it to PL_compiling is better than do nothing */
2493 PL_curcop = &PL_compiling;
2505 S_scalarseq(pTHX_ OP *o)
2508 const OPCODE type = o->op_type;
2510 if (type == OP_LINESEQ || type == OP_SCOPE ||
2511 type == OP_LEAVE || type == OP_LEAVETRY)
2514 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2515 if ((sib = OpSIBLING(kid))
2516 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2517 || ( sib->op_targ != OP_NEXTSTATE
2518 && sib->op_targ != OP_DBSTATE )))
2523 PL_curcop = &PL_compiling;
2525 o->op_flags &= ~OPf_PARENS;
2526 if (PL_hints & HINT_BLOCK_SCOPE)
2527 o->op_flags |= OPf_PARENS;
2530 o = newOP(OP_STUB, 0);
2535 S_modkids(pTHX_ OP *o, I32 type)
2537 if (o && o->op_flags & OPf_KIDS) {
2539 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2540 op_lvalue(kid, type);
2546 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2547 * const fields. Also, convert CONST keys to HEK-in-SVs.
2548 * rop is the op that retrieves the hash;
2549 * key_op is the first key
2550 * real if false, only check (and possibly croak); don't update op
2554 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2560 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2562 if (rop->op_first->op_type == OP_PADSV)
2563 /* @$hash{qw(keys here)} */
2564 rop = (UNOP*)rop->op_first;
2566 /* @{$hash}{qw(keys here)} */
2567 if (rop->op_first->op_type == OP_SCOPE
2568 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2570 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2577 lexname = NULL; /* just to silence compiler warnings */
2578 fields = NULL; /* just to silence compiler warnings */
2582 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2583 SvPAD_TYPED(lexname))
2584 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2585 && isGV(*fields) && GvHV(*fields);
2587 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2589 if (key_op->op_type != OP_CONST)
2591 svp = cSVOPx_svp(key_op);
2593 /* make sure it's not a bareword under strict subs */
2594 if (key_op->op_private & OPpCONST_BARE &&
2595 key_op->op_private & OPpCONST_STRICT)
2597 no_bareword_allowed((OP*)key_op);
2600 /* Make the CONST have a shared SV */
2601 if ( !SvIsCOW_shared_hash(sv = *svp)
2602 && SvTYPE(sv) < SVt_PVMG
2608 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2609 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2610 SvREFCNT_dec_NN(sv);
2615 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2617 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2618 "in variable %" PNf " of type %" HEKf,
2619 SVfARG(*svp), PNfARG(lexname),
2620 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2625 /* info returned by S_sprintf_is_multiconcatable() */
2627 struct sprintf_ismc_info {
2628 SSize_t nargs; /* num of args to sprintf (not including the format) */
2629 char *start; /* start of raw format string */
2630 char *end; /* bytes after end of raw format string */
2631 STRLEN total_len; /* total length (in bytes) of format string, not
2632 including '%s' and half of '%%' */
2633 STRLEN variant; /* number of bytes by which total_len_p would grow
2634 if upgraded to utf8 */
2635 bool utf8; /* whether the format is utf8 */
2639 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2640 * i.e. its format argument is a const string with only '%s' and '%%'
2641 * formats, and the number of args is known, e.g.
2642 * sprintf "a=%s f=%s", $a[0], scalar(f());
2644 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2646 * If successful, the sprintf_ismc_info struct pointed to by info will be
2651 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2653 OP *pm, *constop, *kid;
2656 SSize_t nargs, nformats;
2657 STRLEN cur, total_len, variant;
2660 /* if sprintf's behaviour changes, die here so that someone
2661 * can decide whether to enhance this function or skip optimising
2662 * under those new circumstances */
2663 assert(!(o->op_flags & OPf_STACKED));
2664 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2665 assert(!(o->op_private & ~OPpARG4_MASK));
2667 pm = cUNOPo->op_first;
2668 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2670 constop = OpSIBLING(pm);
2671 if (!constop || constop->op_type != OP_CONST)
2673 sv = cSVOPx_sv(constop);
2674 if (SvMAGICAL(sv) || !SvPOK(sv))
2680 /* Scan format for %% and %s and work out how many %s there are.
2681 * Abandon if other format types are found.
2688 for (p = s; p < e; p++) {
2691 if (!UTF8_IS_INVARIANT(*p))
2697 return FALSE; /* lone % at end gives "Invalid conversion" */
2706 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2709 utf8 = cBOOL(SvUTF8(sv));
2713 /* scan args; they must all be in scalar cxt */
2716 kid = OpSIBLING(constop);
2719 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2722 kid = OpSIBLING(kid);
2725 if (nargs != nformats)
2726 return FALSE; /* e.g. sprintf("%s%s", $a); */
2729 info->nargs = nargs;
2732 info->total_len = total_len;
2733 info->variant = variant;
2741 /* S_maybe_multiconcat():
2743 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2744 * convert it (and its children) into an OP_MULTICONCAT. See the code
2745 * comments just before pp_multiconcat() for the full details of what
2746 * OP_MULTICONCAT supports.
2748 * Basically we're looking for an optree with a chain of OP_CONCATS down
2749 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2750 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2758 * STRINGIFY -- PADSV[$x]
2761 * ex-PUSHMARK -- CONCAT/S
2763 * CONCAT/S -- PADSV[$d]
2765 * CONCAT -- CONST["-"]
2767 * PADSV[$a] -- PADSV[$b]
2769 * Note that at this stage the OP_SASSIGN may have already been optimised
2770 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2774 S_maybe_multiconcat(pTHX_ OP *o)
2777 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2778 OP *topop; /* the top-most op in the concat tree (often equals o,
2779 unless there are assign/stringify ops above it */
2780 OP *parentop; /* the parent op of topop (or itself if no parent) */
2781 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2782 OP *targetop; /* the op corresponding to target=... or target.=... */
2783 OP *stringop; /* the OP_STRINGIFY op, if any */
2784 OP *nextop; /* used for recreating the op_next chain without consts */
2785 OP *kid; /* general-purpose op pointer */
2787 UNOP_AUX_item *lenp;
2788 char *const_str, *p;
2789 struct sprintf_ismc_info sprintf_info;
2791 /* store info about each arg in args[];
2792 * toparg is the highest used slot; argp is a general
2793 * pointer to args[] slots */
2795 void *p; /* initially points to const sv (or null for op);
2796 later, set to SvPV(constsv), with ... */
2797 STRLEN len; /* ... len set to SvPV(..., len) */
2798 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2802 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2805 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2806 the last-processed arg will the LHS of one,
2807 as args are processed in reverse order */
2808 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2809 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2810 U8 flags = 0; /* what will become the op_flags and ... */
2811 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2812 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2813 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2814 bool prev_was_const = FALSE; /* previous arg was a const */
2816 /* -----------------------------------------------------------------
2819 * Examine the optree non-destructively to determine whether it's
2820 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2821 * information about the optree in args[].
2831 assert( o->op_type == OP_SASSIGN
2832 || o->op_type == OP_CONCAT
2833 || o->op_type == OP_SPRINTF
2834 || o->op_type == OP_STRINGIFY);
2836 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2838 /* first see if, at the top of the tree, there is an assign,
2839 * append and/or stringify */
2841 if (topop->op_type == OP_SASSIGN) {
2843 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2845 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2847 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2850 topop = cBINOPo->op_first;
2851 targetop = OpSIBLING(topop);
2852 if (!targetop) /* probably some sort of syntax error */
2855 else if ( topop->op_type == OP_CONCAT
2856 && (topop->op_flags & OPf_STACKED)
2857 && (!(topop->op_private & OPpCONCAT_NESTED))
2862 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2863 * decide what to do about it */
2864 assert(!(o->op_private & OPpTARGET_MY));
2866 /* barf on unknown flags */
2867 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2868 private_flags |= OPpMULTICONCAT_APPEND;
2869 targetop = cBINOPo->op_first;
2871 topop = OpSIBLING(targetop);
2873 /* $x .= <FOO> gets optimised to rcatline instead */
2874 if (topop->op_type == OP_READLINE)
2879 /* Can targetop (the LHS) if it's a padsv, be be optimised
2880 * away and use OPpTARGET_MY instead?
2882 if ( (targetop->op_type == OP_PADSV)
2883 && !(targetop->op_private & OPpDEREF)
2884 && !(targetop->op_private & OPpPAD_STATE)
2885 /* we don't support 'my $x .= ...' */
2886 && ( o->op_type == OP_SASSIGN
2887 || !(targetop->op_private & OPpLVAL_INTRO))
2892 if (topop->op_type == OP_STRINGIFY) {
2893 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2897 /* barf on unknown flags */
2898 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2900 if ((topop->op_private & OPpTARGET_MY)) {
2901 if (o->op_type == OP_SASSIGN)
2902 return; /* can't have two assigns */
2906 private_flags |= OPpMULTICONCAT_STRINGIFY;
2908 topop = cBINOPx(topop)->op_first;
2909 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2910 topop = OpSIBLING(topop);
2913 if (topop->op_type == OP_SPRINTF) {
2914 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2916 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2917 nargs = sprintf_info.nargs;
2918 total_len = sprintf_info.total_len;
2919 variant = sprintf_info.variant;
2920 utf8 = sprintf_info.utf8;
2922 private_flags |= OPpMULTICONCAT_FAKE;
2924 /* we have an sprintf op rather than a concat optree.
2925 * Skip most of the code below which is associated with
2926 * processing that optree. We also skip phase 2, determining
2927 * whether its cost effective to optimise, since for sprintf,
2928 * multiconcat is *always* faster */
2931 /* note that even if the sprintf itself isn't multiconcatable,
2932 * the expression as a whole may be, e.g. in
2933 * $x .= sprintf("%d",...)
2934 * the sprintf op will be left as-is, but the concat/S op may
2935 * be upgraded to multiconcat
2938 else if (topop->op_type == OP_CONCAT) {
2939 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2942 if ((topop->op_private & OPpTARGET_MY)) {
2943 if (o->op_type == OP_SASSIGN || targmyop)
2944 return; /* can't have two assigns */
2949 /* Is it safe to convert a sassign/stringify/concat op into
2951 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2952 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2953 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2954 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2955 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2956 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2957 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2958 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2960 /* Now scan the down the tree looking for a series of
2961 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2962 * stacked). For example this tree:
2967 * CONCAT/STACKED -- EXPR5
2969 * CONCAT/STACKED -- EXPR4
2975 * corresponds to an expression like
2977 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2979 * Record info about each EXPR in args[]: in particular, whether it is
2980 * a stringifiable OP_CONST and if so what the const sv is.
2982 * The reason why the last concat can't be STACKED is the difference
2985 * ((($a .= $a) .= $a) .= $a) .= $a
2988 * $a . $a . $a . $a . $a
2990 * The main difference between the optrees for those two constructs
2991 * is the presence of the last STACKED. As well as modifying $a,
2992 * the former sees the changed $a between each concat, so if $s is
2993 * initially 'a', the first returns 'a' x 16, while the latter returns
2994 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3004 if ( kid->op_type == OP_CONCAT
3008 k1 = cUNOPx(kid)->op_first;
3010 /* shouldn't happen except maybe after compile err? */
3014 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3015 if (kid->op_private & OPpTARGET_MY)
3018 stacked_last = (kid->op_flags & OPf_STACKED);
3030 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3031 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3033 /* At least two spare slots are needed to decompose both
3034 * concat args. If there are no slots left, continue to
3035 * examine the rest of the optree, but don't push new values
3036 * on args[]. If the optree as a whole is legal for conversion
3037 * (in particular that the last concat isn't STACKED), then
3038 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3039 * can be converted into an OP_MULTICONCAT now, with the first
3040 * child of that op being the remainder of the optree -
3041 * which may itself later be converted to a multiconcat op
3045 /* the last arg is the rest of the optree */
3050 else if ( argop->op_type == OP_CONST
3051 && ((sv = cSVOPx_sv(argop)))
3052 /* defer stringification until runtime of 'constant'
3053 * things that might stringify variantly, e.g. the radix
3054 * point of NVs, or overloaded RVs */
3055 && (SvPOK(sv) || SvIOK(sv))
3056 && (!SvGMAGICAL(sv))
3059 utf8 |= cBOOL(SvUTF8(sv));
3062 /* this const may be demoted back to a plain arg later;
3063 * make sure we have enough arg slots left */
3065 prev_was_const = !prev_was_const;
3070 prev_was_const = FALSE;
3080 return; /* we don't support ((A.=B).=C)...) */
3082 /* look for two adjacent consts and don't fold them together:
3085 * $o->concat("a")->concat("b")
3088 * (but $o .= "a" . "b" should still fold)
3091 bool seen_nonconst = FALSE;
3092 for (argp = toparg; argp >= args; argp--) {
3093 if (argp->p == NULL) {
3094 seen_nonconst = TRUE;
3100 /* both previous and current arg were constants;
3101 * leave the current OP_CONST as-is */
3109 /* -----------------------------------------------------------------
3112 * At this point we have determined that the optree *can* be converted
3113 * into a multiconcat. Having gathered all the evidence, we now decide
3114 * whether it *should*.
3118 /* we need at least one concat action, e.g.:
3124 * otherwise we could be doing something like $x = "foo", which
3125 * if treated as as a concat, would fail to COW.
3127 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3130 /* Benchmarking seems to indicate that we gain if:
3131 * * we optimise at least two actions into a single multiconcat
3132 * (e.g concat+concat, sassign+concat);
3133 * * or if we can eliminate at least 1 OP_CONST;
3134 * * or if we can eliminate a padsv via OPpTARGET_MY
3138 /* eliminated at least one OP_CONST */
3140 /* eliminated an OP_SASSIGN */
3141 || o->op_type == OP_SASSIGN
3142 /* eliminated an OP_PADSV */
3143 || (!targmyop && is_targable)
3145 /* definitely a net gain to optimise */
3148 /* ... if not, what else? */
3150 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3151 * multiconcat is faster (due to not creating a temporary copy of
3152 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3158 && topop->op_type == OP_CONCAT
3160 PADOFFSET t = targmyop->op_targ;
3161 OP *k1 = cBINOPx(topop)->op_first;
3162 OP *k2 = cBINOPx(topop)->op_last;
3163 if ( k2->op_type == OP_PADSV
3165 && ( k1->op_type != OP_PADSV
3166 || k1->op_targ != t)
3171 /* need at least two concats */
3172 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3177 /* -----------------------------------------------------------------
3180 * At this point the optree has been verified as ok to be optimised
3181 * into an OP_MULTICONCAT. Now start changing things.
3186 /* stringify all const args and determine utf8ness */
3189 for (argp = args; argp <= toparg; argp++) {
3190 SV *sv = (SV*)argp->p;
3192 continue; /* not a const op */
3193 if (utf8 && !SvUTF8(sv))
3194 sv_utf8_upgrade_nomg(sv);
3195 argp->p = SvPV_nomg(sv, argp->len);
3196 total_len += argp->len;
3198 /* see if any strings would grow if converted to utf8 */
3200 variant += variant_under_utf8_count((U8 *) argp->p,
3201 (U8 *) argp->p + argp->len);
3205 /* create and populate aux struct */
3209 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3210 sizeof(UNOP_AUX_item)
3212 PERL_MULTICONCAT_HEADER_SIZE
3213 + ((nargs + 1) * (variant ? 2 : 1))
3216 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3218 /* Extract all the non-const expressions from the concat tree then
3219 * dispose of the old tree, e.g. convert the tree from this:
3223 * STRINGIFY -- TARGET
3225 * ex-PUSHMARK -- CONCAT
3240 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3242 * except that if EXPRi is an OP_CONST, it's discarded.
3244 * During the conversion process, EXPR ops are stripped from the tree
3245 * and unshifted onto o. Finally, any of o's remaining original
3246 * childen are discarded and o is converted into an OP_MULTICONCAT.
3248 * In this middle of this, o may contain both: unshifted args on the
3249 * left, and some remaining original args on the right. lastkidop
3250 * is set to point to the right-most unshifted arg to delineate
3251 * between the two sets.
3256 /* create a copy of the format with the %'s removed, and record
3257 * the sizes of the const string segments in the aux struct */
3259 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3261 p = sprintf_info.start;
3264 for (; p < sprintf_info.end; p++) {
3268 (lenp++)->ssize = q - oldq;
3275 lenp->ssize = q - oldq;
3276 assert((STRLEN)(q - const_str) == total_len);
3278 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3279 * may or may not be topop) The pushmark and const ops need to be
3280 * kept in case they're an op_next entry point.
3282 lastkidop = cLISTOPx(topop)->op_last;
3283 kid = cUNOPx(topop)->op_first; /* pushmark */
3285 op_null(OpSIBLING(kid)); /* const */
3287 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3288 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3289 lastkidop->op_next = o;
3294 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3298 /* Concatenate all const strings into const_str.
3299 * Note that args[] contains the RHS args in reverse order, so
3300 * we scan args[] from top to bottom to get constant strings
3303 for (argp = toparg; argp >= args; argp--) {
3305 /* not a const op */
3306 (++lenp)->ssize = -1;
3308 STRLEN l = argp->len;
3309 Copy(argp->p, p, l, char);
3311 if (lenp->ssize == -1)
3322 for (argp = args; argp <= toparg; argp++) {
3323 /* only keep non-const args, except keep the first-in-next-chain
3324 * arg no matter what it is (but nulled if OP_CONST), because it
3325 * may be the entry point to this subtree from the previous
3328 bool last = (argp == toparg);
3331 /* set prev to the sibling *before* the arg to be cut out,
3332 * e.g. when cutting EXPR:
3337 * prev= CONCAT -- EXPR
3340 if (argp == args && kid->op_type != OP_CONCAT) {
3341 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3342 * so the expression to be cut isn't kid->op_last but
3345 /* find the op before kid */
3347 o2 = cUNOPx(parentop)->op_first;
3348 while (o2 && o2 != kid) {
3356 else if (kid == o && lastkidop)
3357 prev = last ? lastkidop : OpSIBLING(lastkidop);
3359 prev = last ? NULL : cUNOPx(kid)->op_first;
3361 if (!argp->p || last) {
3363 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3364 /* and unshift to front of o */
3365 op_sibling_splice(o, NULL, 0, aop);
3366 /* record the right-most op added to o: later we will
3367 * free anything to the right of it */
3370 aop->op_next = nextop;
3373 /* null the const at start of op_next chain */
3377 nextop = prev->op_next;
3380 /* the last two arguments are both attached to the same concat op */
3381 if (argp < toparg - 1)
3386 /* Populate the aux struct */
3388 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3389 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3390 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3391 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3392 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3394 /* if variant > 0, calculate a variant const string and lengths where
3395 * the utf8 version of the string will take 'variant' more bytes than
3399 char *p = const_str;
3400 STRLEN ulen = total_len + variant;
3401 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3402 UNOP_AUX_item *ulens = lens + (nargs + 1);
3403 char *up = (char*)PerlMemShared_malloc(ulen);
3406 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3407 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3409 for (n = 0; n < (nargs + 1); n++) {
3411 char * orig_up = up;
3412 for (i = (lens++)->ssize; i > 0; i--) {
3414 append_utf8_from_native_byte(c, (U8**)&up);
3416 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3421 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3422 * that op's first child - an ex-PUSHMARK - because the op_next of
3423 * the previous op may point to it (i.e. it's the entry point for
3428 ? op_sibling_splice(o, lastkidop, 1, NULL)
3429 : op_sibling_splice(stringop, NULL, 1, NULL);
3430 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3431 op_sibling_splice(o, NULL, 0, pmop);
3438 * target .= A.B.C...
3444 if (o->op_type == OP_SASSIGN) {
3445 /* Move the target subtree from being the last of o's children
3446 * to being the last of o's preserved children.
3447 * Note the difference between 'target = ...' and 'target .= ...':
3448 * for the former, target is executed last; for the latter,
3451 kid = OpSIBLING(lastkidop);
3452 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3453 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3454 lastkidop->op_next = kid->op_next;
3455 lastkidop = targetop;
3458 /* Move the target subtree from being the first of o's
3459 * original children to being the first of *all* o's children.
3462 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3463 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3466 /* if the RHS of .= doesn't contain a concat (e.g.
3467 * $x .= "foo"), it gets missed by the "strip ops from the
3468 * tree and add to o" loop earlier */
3469 assert(topop->op_type != OP_CONCAT);
3471 /* in e.g. $x .= "$y", move the $y expression
3472 * from being a child of OP_STRINGIFY to being the
3473 * second child of the OP_CONCAT
3475 assert(cUNOPx(stringop)->op_first == topop);
3476 op_sibling_splice(stringop, NULL, 1, NULL);
3477 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3479 assert(topop == OpSIBLING(cBINOPo->op_first));
3488 * my $lex = A.B.C...
3491 * The original padsv op is kept but nulled in case it's the
3492 * entry point for the optree (which it will be for
3495 private_flags |= OPpTARGET_MY;
3496 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3497 o->op_targ = targetop->op_targ;
3498 targetop->op_targ = 0;
3502 flags |= OPf_STACKED;
3504 else if (targmyop) {
3505 private_flags |= OPpTARGET_MY;
3506 if (o != targmyop) {
3507 o->op_targ = targmyop->op_targ;
3508 targmyop->op_targ = 0;
3512 /* detach the emaciated husk of the sprintf/concat optree and free it */
3514 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3520 /* and convert o into a multiconcat */
3522 o->op_flags = (flags|OPf_KIDS|stacked_last
3523 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3524 o->op_private = private_flags;
3525 o->op_type = OP_MULTICONCAT;
3526 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3527 cUNOP_AUXo->op_aux = aux;
3531 /* do all the final processing on an optree (e.g. running the peephole
3532 * optimiser on it), then attach it to cv (if cv is non-null)
3536 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3540 /* XXX for some reason, evals, require and main optrees are
3541 * never attached to their CV; instead they just hang off
3542 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3543 * and get manually freed when appropriate */
3545 startp = &CvSTART(cv);
3547 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3550 optree->op_private |= OPpREFCOUNTED;
3551 OpREFCNT_set(optree, 1);
3552 optimize_optree(optree);
3554 finalize_optree(optree);
3555 S_prune_chain_head(startp);
3558 /* now that optimizer has done its work, adjust pad values */
3559 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3560 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3566 =for apidoc optimize_optree
3568 This function applies some optimisations to the optree in top-down order.
3569 It is called before the peephole optimizer, which processes ops in
3570 execution order. Note that finalize_optree() also does a top-down scan,
3571 but is called *after* the peephole optimizer.
3577 Perl_optimize_optree(pTHX_ OP* o)
3579 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3582 SAVEVPTR(PL_curcop);
3590 /* helper for optimize_optree() which optimises one op then recurses
3591 * to optimise any children.
3595 S_optimize_op(pTHX_ OP* o)
3599 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3602 OP * next_kid = NULL;
3604 assert(o->op_type != OP_FREED);
3606 switch (o->op_type) {
3609 PL_curcop = ((COP*)o); /* for warnings */
3617 S_maybe_multiconcat(aTHX_ o);
3621 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3622 /* we can't assume that op_pmreplroot->op_sibparent == o
3623 * and that it is thus possible to walk back up the tree
3624 * past op_pmreplroot. So, although we try to avoid
3625 * recursing through op trees, do it here. After all,
3626 * there are unlikely to be many nested s///e's within
3627 * the replacement part of a s///e.
3629 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3637 if (o->op_flags & OPf_KIDS)
3638 next_kid = cUNOPo->op_first;
3640 /* if a kid hasn't been nominated to process, continue with the
3641 * next sibling, or if no siblings left, go back to the parent's
3642 * siblings and so on
3646 return; /* at top; no parents/siblings to try */
3647 if (OpHAS_SIBLING(o))
3648 next_kid = o->op_sibparent;
3650 o = o->op_sibparent; /*try parent's next sibling */
3653 /* this label not yet used. Goto here if any code above sets
3663 =for apidoc finalize_optree
3665 This function finalizes the optree. Should be called directly after
3666 the complete optree is built. It does some additional
3667 checking which can't be done in the normal C<ck_>xxx functions and makes
3668 the tree thread-safe.
3673 Perl_finalize_optree(pTHX_ OP* o)
3675 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3678 SAVEVPTR(PL_curcop);
3686 /* Relocate sv to the pad for thread safety.
3687 * Despite being a "constant", the SV is written to,
3688 * for reference counts, sv_upgrade() etc. */
3689 PERL_STATIC_INLINE void
3690 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3693 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3695 ix = pad_alloc(OP_CONST, SVf_READONLY);
3696 SvREFCNT_dec(PAD_SVl(ix));
3697 PAD_SETSV(ix, *svp);
3698 /* XXX I don't know how this isn't readonly already. */
3699 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3706 =for apidoc traverse_op_tree
3708 Return the next op in a depth-first traversal of the op tree,
3709 returning NULL when the traversal is complete.
3711 The initial call must supply the root of the tree as both top and o.
3713 For now it's static, but it may be exposed to the API in the future.
3719 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3722 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3724 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3725 return cUNOPo->op_first;
3727 else if ((sib = OpSIBLING(o))) {
3731 OP *parent = o->op_sibparent;
3732 assert(!(o->op_moresib));
3733 while (parent && parent != top) {
3734 OP *sib = OpSIBLING(parent);
3737 parent = parent->op_sibparent;
3745 S_finalize_op(pTHX_ OP* o)
3748 PERL_ARGS_ASSERT_FINALIZE_OP;
3751 assert(o->op_type != OP_FREED);
3753 switch (o->op_type) {
3756 PL_curcop = ((COP*)o); /* for warnings */
3759 if (OpHAS_SIBLING(o)) {
3760 OP *sib = OpSIBLING(o);
3761 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3762 && ckWARN(WARN_EXEC)
3763 && OpHAS_SIBLING(sib))
3765 const OPCODE type = OpSIBLING(sib)->op_type;
3766 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3767 const line_t oldline = CopLINE(PL_curcop);
3768 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3769 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3770 "Statement unlikely to be reached");
3771 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3772 "\t(Maybe you meant system() when you said exec()?)\n");
3773 CopLINE_set(PL_curcop, oldline);
3780 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3781 GV * const gv = cGVOPo_gv;
3782 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3783 /* XXX could check prototype here instead of just carping */
3784 SV * const sv = sv_newmortal();
3785 gv_efullname3(sv, gv, NULL);
3786 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3787 "%" SVf "() called too early to check prototype",
3794 if (cSVOPo->op_private & OPpCONST_STRICT)
3795 no_bareword_allowed(o);
3799 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3804 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3805 case OP_METHOD_NAMED:
3806 case OP_METHOD_SUPER:
3807 case OP_METHOD_REDIR:
3808 case OP_METHOD_REDIR_SUPER:
3809 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3818 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3821 rop = (UNOP*)((BINOP*)o)->op_first;
3826 S_scalar_slice_warning(aTHX_ o);
3830 kid = OpSIBLING(cLISTOPo->op_first);
3831 if (/* I bet there's always a pushmark... */
3832 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3833 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3838 key_op = (SVOP*)(kid->op_type == OP_CONST
3840 : OpSIBLING(kLISTOP->op_first));
3842 rop = (UNOP*)((LISTOP*)o)->op_last;
3845 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3847 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3851 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3855 S_scalar_slice_warning(aTHX_ o);
3859 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3860 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3868 if (o->op_flags & OPf_KIDS) {
3871 /* check that op_last points to the last sibling, and that
3872 * the last op_sibling/op_sibparent field points back to the
3873 * parent, and that the only ops with KIDS are those which are
3874 * entitled to them */
3875 U32 type = o->op_type;
3879 if (type == OP_NULL) {
3881 /* ck_glob creates a null UNOP with ex-type GLOB
3882 * (which is a list op. So pretend it wasn't a listop */
3883 if (type == OP_GLOB)
3886 family = PL_opargs[type] & OA_CLASS_MASK;
3888 has_last = ( family == OA_BINOP
3889 || family == OA_LISTOP
3890 || family == OA_PMOP
3891 || family == OA_LOOP
3893 assert( has_last /* has op_first and op_last, or ...
3894 ... has (or may have) op_first: */
3895 || family == OA_UNOP
3896 || family == OA_UNOP_AUX
3897 || family == OA_LOGOP
3898 || family == OA_BASEOP_OR_UNOP
3899 || family == OA_FILESTATOP
3900 || family == OA_LOOPEXOP
3901 || family == OA_METHOP
3902 || type == OP_CUSTOM
3903 || type == OP_NULL /* new_logop does this */
3906 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3907 if (!OpHAS_SIBLING(kid)) {
3909 assert(kid == cLISTOPo->op_last);
3910 assert(kid->op_sibparent == o);
3915 } while (( o = traverse_op_tree(top, o)) != NULL);
3919 =for apidoc op_lvalue
3921 Propagate lvalue ("modifiable") context to an op and its children.
3922 C<type> represents the context type, roughly based on the type of op that
3923 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3924 because it has no op type of its own (it is signalled by a flag on
3927 This function detects things that can't be modified, such as C<$x+1>, and
3928 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3929 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3931 It also flags things that need to behave specially in an lvalue context,
3932 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3938 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3941 PadnameLVALUE_on(pn);
3942 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3944 /* RT #127786: cv can be NULL due to an eval within the DB package
3945 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3946 * unless they contain an eval, but calling eval within DB
3947 * pretends the eval was done in the caller's scope.
3951 assert(CvPADLIST(cv));
3953 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3954 assert(PadnameLEN(pn));
3955 PadnameLVALUE_on(pn);
3960 S_vivifies(const OPCODE type)
3963 case OP_RV2AV: case OP_ASLICE:
3964 case OP_RV2HV: case OP_KVASLICE:
3965 case OP_RV2SV: case OP_HSLICE:
3966 case OP_AELEMFAST: case OP_KVHSLICE:
3975 S_lvref(pTHX_ OP *o, I32 type)
3979 switch (o->op_type) {
3981 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3982 kid = OpSIBLING(kid))
3983 S_lvref(aTHX_ kid, type);
3988 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3989 o->op_flags |= OPf_STACKED;
3990 if (o->op_flags & OPf_PARENS) {
3991 if (o->op_private & OPpLVAL_INTRO) {
3992 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3993 "localized parenthesized array in list assignment"));
3997 OpTYPE_set(o, OP_LVAVREF);
3998 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3999 o->op_flags |= OPf_MOD|OPf_REF;
4002 o->op_private |= OPpLVREF_AV;
4005 kid = cUNOPo->op_first;
4006 if (kid->op_type == OP_NULL)
4007 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4009 o->op_private = OPpLVREF_CV;
4010 if (kid->op_type == OP_GV)
4011 o->op_flags |= OPf_STACKED;
4012 else if (kid->op_type == OP_PADCV) {
4013 o->op_targ = kid->op_targ;
4015 op_free(cUNOPo->op_first);
4016 cUNOPo->op_first = NULL;
4017 o->op_flags &=~ OPf_KIDS;
4022 if (o->op_flags & OPf_PARENS) {
4024 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4025 "parenthesized hash in list assignment"));
4028 o->op_private |= OPpLVREF_HV;
4032 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4033 o->op_flags |= OPf_STACKED;
4036 if (o->op_flags & OPf_PARENS) goto parenhash;
4037 o->op_private |= OPpLVREF_HV;
4040 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4043 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4044 if (o->op_flags & OPf_PARENS) goto slurpy;
4045 o->op_private |= OPpLVREF_AV;
4049 o->op_private |= OPpLVREF_ELEM;
4050 o->op_flags |= OPf_STACKED;
4054 OpTYPE_set(o, OP_LVREFSLICE);
4055 o->op_private &= OPpLVAL_INTRO;
4058 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4060 else if (!(o->op_flags & OPf_KIDS))
4062 if (o->op_targ != OP_LIST) {
4063 S_lvref(aTHX_ cBINOPo->op_first, type);
4068 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
4069 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
4070 S_lvref(aTHX_ kid, type);
4074 if (o->op_flags & OPf_PARENS)
4079 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4080 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4081 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4087 OpTYPE_set(o, OP_LVREF);
4089 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4090 if (type == OP_ENTERLOOP)
4091 o->op_private |= OPpLVREF_ITER;
4094 PERL_STATIC_INLINE bool
4095 S_potential_mod_type(I32 type)
4097 /* Types that only potentially result in modification. */
4098 return type == OP_GREPSTART || type == OP_ENTERSUB
4099 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4103 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4107 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4110 if (!o || (PL_parser && PL_parser->error_count))
4113 if ((o->op_private & OPpTARGET_MY)
4114 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4119 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4121 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4123 switch (o->op_type) {
4128 if ((o->op_flags & OPf_PARENS))
4132 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4133 !(o->op_flags & OPf_STACKED)) {
4134 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4135 assert(cUNOPo->op_first->op_type == OP_NULL);
4136 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4139 else { /* lvalue subroutine call */
4140 o->op_private |= OPpLVAL_INTRO;
4141 PL_modcount = RETURN_UNLIMITED_NUMBER;
4142 if (S_potential_mod_type(type)) {
4143 o->op_private |= OPpENTERSUB_INARGS;
4146 else { /* Compile-time error message: */
4147 OP *kid = cUNOPo->op_first;
4152 if (kid->op_type != OP_PUSHMARK) {
4153 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4155 "panic: unexpected lvalue entersub "
4156 "args: type/targ %ld:%" UVuf,
4157 (long)kid->op_type, (UV)kid->op_targ);
4158 kid = kLISTOP->op_first;
4160 while (OpHAS_SIBLING(kid))
4161 kid = OpSIBLING(kid);
4162 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4163 break; /* Postpone until runtime */
4166 kid = kUNOP->op_first;
4167 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4168 kid = kUNOP->op_first;
4169 if (kid->op_type == OP_NULL)
4171 "Unexpected constant lvalue entersub "
4172 "entry via type/targ %ld:%" UVuf,
4173 (long)kid->op_type, (UV)kid->op_targ);
4174 if (kid->op_type != OP_GV) {
4181 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4182 ? MUTABLE_CV(SvRV(gv))
4188 if (flags & OP_LVALUE_NO_CROAK)
4191 namesv = cv_name(cv, NULL, 0);
4192 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4193 "subroutine call of &%" SVf " in %s",
4194 SVfARG(namesv), PL_op_desc[type]),
4202 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4203 /* grep, foreach, subcalls, refgen */
4204 if (S_potential_mod_type(type))
4206 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4207 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4210 type ? PL_op_desc[type] : "local"));
4223 case OP_RIGHT_SHIFT:
4232 if (!(o->op_flags & OPf_STACKED))
4238 if (o->op_flags & OPf_STACKED) {
4242 if (!(o->op_private & OPpREPEAT_DOLIST))
4245 const I32 mods = PL_modcount;
4246 modkids(cBINOPo->op_first, type);
4247 if (type != OP_AASSIGN)
4249 kid = cBINOPo->op_last;
4250 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4251 const IV iv = SvIV(kSVOP_sv);
4252 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4254 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4257 PL_modcount = RETURN_UNLIMITED_NUMBER;
4263 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4264 op_lvalue(kid, type);
4269 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4270 PL_modcount = RETURN_UNLIMITED_NUMBER;
4271 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4272 fiable since some contexts need to know. */
4273 o->op_flags |= OPf_MOD;
4278 if (scalar_mod_type(o, type))
4280 ref(cUNOPo->op_first, o->op_type);
4287 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4288 if (type == OP_LEAVESUBLV && (
4289 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4290 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4292 o->op_private |= OPpMAYBE_LVSUB;
4296 PL_modcount = RETURN_UNLIMITED_NUMBER;
4301 if (type == OP_LEAVESUBLV)
4302 o->op_private |= OPpMAYBE_LVSUB;
4305 if (type == OP_LEAVESUBLV
4306 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4307 o->op_private |= OPpMAYBE_LVSUB;
4310 PL_hints |= HINT_BLOCK_SCOPE;
4311 if (type == OP_LEAVESUBLV)
4312 o->op_private |= OPpMAYBE_LVSUB;
4316 ref(cUNOPo->op_first, o->op_type);
4320 PL_hints |= HINT_BLOCK_SCOPE;
4330 case OP_AELEMFAST_LEX:
4337 PL_modcount = RETURN_UNLIMITED_NUMBER;
4338 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4340 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4341 fiable since some contexts need to know. */
4342 o->op_flags |= OPf_MOD;
4345 if (scalar_mod_type(o, type))
4347 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4348 && type == OP_LEAVESUBLV)
4349 o->op_private |= OPpMAYBE_LVSUB;
4353 if (!type) /* local() */
4354 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4355 PNfARG(PAD_COMPNAME(o->op_targ)));
4356 if (!(o->op_private & OPpLVAL_INTRO)
4357 || ( type != OP_SASSIGN && type != OP_AASSIGN
4358 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4359 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4367 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4371 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4377 if (type == OP_LEAVESUBLV)
4378 o->op_private |= OPpMAYBE_LVSUB;
4379 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4380 /* substr and vec */
4381 /* If this op is in merely potential (non-fatal) modifiable
4382 context, then apply OP_ENTERSUB context to
4383 the kid op (to avoid croaking). Other-
4384 wise pass this op’s own type so the correct op is mentioned
4385 in error messages. */
4386 op_lvalue(OpSIBLING(cBINOPo->op_first),
4387 S_potential_mod_type(type)
4395 ref(cBINOPo->op_first, o->op_type);
4396 if (type == OP_ENTERSUB &&
4397 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4398 o->op_private |= OPpLVAL_DEFER;
4399 if (type == OP_LEAVESUBLV)
4400 o->op_private |= OPpMAYBE_LVSUB;
4407 o->op_private |= OPpLVALUE;
4413 if (o->op_flags & OPf_KIDS)
4414 op_lvalue(cLISTOPo->op_last, type);
4419 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4421 else if (!(o->op_flags & OPf_KIDS))
4424 if (o->op_targ != OP_LIST) {
4425 OP *sib = OpSIBLING(cLISTOPo->op_first);
4426 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4433 * compared with things like OP_MATCH which have the argument
4439 * so handle specially to correctly get "Can't modify" croaks etc
4442 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4444 /* this should trigger a "Can't modify transliteration" err */
4445 op_lvalue(sib, type);
4447 op_lvalue(cBINOPo->op_first, type);
4453 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4454 /* elements might be in void context because the list is
4455 in scalar context or because they are attribute sub calls */
4456 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4457 op_lvalue(kid, type);
4465 if (type == OP_LEAVESUBLV
4466 || !S_vivifies(cLOGOPo->op_first->op_type))
4467 op_lvalue(cLOGOPo->op_first, type);
4468 if (type == OP_LEAVESUBLV
4469 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4470 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4474 if (type == OP_NULL) { /* local */
4476 if (!FEATURE_MYREF_IS_ENABLED)
4477 Perl_croak(aTHX_ "The experimental declared_refs "
4478 "feature is not enabled");
4479 Perl_ck_warner_d(aTHX_
4480 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4481 "Declaring references is experimental");
4482 op_lvalue(cUNOPo->op_first, OP_NULL);
4485 if (type != OP_AASSIGN && type != OP_SASSIGN
4486 && type != OP_ENTERLOOP)
4488 /* Don’t bother applying lvalue context to the ex-list. */
4489 kid = cUNOPx(cUNOPo->op_first)->op_first;
4490 assert (!OpHAS_SIBLING(kid));
4493 if (type == OP_NULL) /* local */
4495 if (type != OP_AASSIGN) goto nomod;
4496 kid = cUNOPo->op_first;
4499 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4500 S_lvref(aTHX_ kid, type);
4501 if (!PL_parser || PL_parser->error_count == ec) {
4502 if (!FEATURE_REFALIASING_IS_ENABLED)
4504 "Experimental aliasing via reference not enabled");
4505 Perl_ck_warner_d(aTHX_
4506 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4507 "Aliasing via reference is experimental");
4510 if (o->op_type == OP_REFGEN)
4511 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4516 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4517 /* This is actually @array = split. */
4518 PL_modcount = RETURN_UNLIMITED_NUMBER;
4524 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4528 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4529 their argument is a filehandle; thus \stat(".") should not set
4531 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4534 if (type != OP_LEAVESUBLV)
4535 o->op_flags |= OPf_MOD;
4537 if (type == OP_AASSIGN || type == OP_SASSIGN)
4538 o->op_flags |= OPf_SPECIAL
4539 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4540 else if (!type) { /* local() */
4543 o->op_private |= OPpLVAL_INTRO;
4544 o->op_flags &= ~OPf_SPECIAL;
4545 PL_hints |= HINT_BLOCK_SCOPE;
4550 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4551 "Useless localization of %s", OP_DESC(o));
4554 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4555 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4556 o->op_flags |= OPf_REF;
4561 S_scalar_mod_type(const OP *o, I32 type)
4566 if (o && o->op_type == OP_RV2GV)
4590 case OP_RIGHT_SHIFT:
4619 S_is_handle_constructor(const OP *o, I32 numargs)
4621 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4623 switch (o->op_type) {
4631 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4644 S_refkids(pTHX_ OP *o, I32 type)
4646 if (o && o->op_flags & OPf_KIDS) {
4648 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4655 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4660 PERL_ARGS_ASSERT_DOREF;
4662 if (PL_parser && PL_parser->error_count)
4665 switch (o->op_type) {
4667 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4668 !(o->op_flags & OPf_STACKED)) {
4669 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4670 assert(cUNOPo->op_first->op_type == OP_NULL);
4671 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4672 o->op_flags |= OPf_SPECIAL;
4674 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4675 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4676 : type == OP_RV2HV ? OPpDEREF_HV
4678 o->op_flags |= OPf_MOD;
4684 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4685 doref(kid, type, set_op_ref);
4688 if (type == OP_DEFINED)
4689 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4690 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4693 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4694 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4695 : type == OP_RV2HV ? OPpDEREF_HV
4697 o->op_flags |= OPf_MOD;