This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_op_linklist(): use OPf_KIDS flags
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC
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
79072805
LW
6 *
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.
9 *
a0d0e21e
LW
10 */
11
12/*
4ac71550
TC
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
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW
20 */
21
166f8a29
DM
22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
9b7bf845
DM
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
27 *
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.
166f8a29
DM
38 *
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):
43 *
44 * newBINOP(OP_ADD, flags,
45 * newSVREF($a),
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47 * )
48 *
9b7bf845
DM
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
53 * parse tree left.
54 *
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:
58 *
59 * [+]
60 * |
61 * [*]------[/]
62 * | |
63 * A---B C---D
64 *
65 * with the intended execution order being:
66 *
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
68 *
69 * At this point all the nodes' op_next pointers will have been set,
70 * except that:
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
83 * initially have had:
84 * [*] => A; A => B; B => [*]
85 * and
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.
90 *
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.
96 *
97 * In summary: given a subtree, its top-level node's op_next will either
98 * be:
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
166f8a29 102 */
ccfc67b7 103
61b743bb 104/*
9b7bf845
DM
105
106Here's an older description from Larry.
107
61b743bb
DM
108Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110 A bottom-up pass
111 A top-down pass
112 An execution-order pass
113
114The bottom-up pass is represented by all the "newOP" routines and
115the ck_ routines. The bottom-upness is actually driven by yacc.
116So at the point that a ck_ routine fires, we have no idea what the
117context is, either upward in the syntax tree, or either forward or
118backward in the execution order. (The bottom-up parser builds that
119part of the execution order it knows about, but if you follow the "next"
120links around, you'll find it's actually a closed loop through the
ef9da979 121top level node.)
61b743bb
DM
122
123Whenever the bottom-up parser gets to a node that supplies context to
124its components, it invokes that portion of the top-down pass that applies
125to that part of the subtree (and marks the top node as processed, so
126if a node further up supplies context, it doesn't have to take the
127plunge again). As a particular subcase of this, as the new node is
128built, it takes all the closed execution loops of its subcomponents
129and links them into a new closed loop for the higher level node. But
130it's still not the real execution order.
131
132The actual execution order is not known till we get a grammar reduction
133to 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
135into peep() to do that code's portion of the 3rd pass. It has to be
136recursive, but it's recursive on basic blocks, not on tree nodes.
137*/
138
06e0342d 139/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC
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
06e0342d 147 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC
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.
151
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.
c28fe1ec 155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC
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.
b3ca2e83
NC
159*/
160
79072805 161#include "EXTERN.h"
864dbfa3 162#define PERL_IN_OP_C
79072805 163#include "perl.h"
77ca0c92 164#include "keywords.h"
2846acbf 165#include "feature.h"
74529a43 166#include "regcomp.h"
79072805 167
16c91539 168#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 169#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 170#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 171
5068f264 172static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
637494ac 173
72621f84
DM
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.
177 */
178
179STATIC void
dc3bf405 180S_prune_chain_head(OP** op_p)
72621f84
DM
181{
182 while (*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)
187 )
188 *op_p = (*op_p)->op_next;
189}
190
191
8be227ab
FC
192/* See the explanatory comments above struct opslab in op.h. */
193
7aef8e5b 194#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
195# define PERL_SLAB_SIZE 128
196# define PERL_MAX_SLAB_SIZE 4096
197# include <sys/mman.h>
7aef8e5b 198#endif
3107b51f 199
7aef8e5b 200#ifndef PERL_SLAB_SIZE
8be227ab 201# define PERL_SLAB_SIZE 64
7aef8e5b
FC
202#endif
203#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 204# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 205#endif
8be227ab
FC
206
207/* rounds up to nearest pointer */
7aef8e5b
FC
208#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
209#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab 210
49c01b24
DM
211/* malloc a new op slab (suitable for attaching to PL_compcv) */
212
8be227ab
FC
213static OPSLAB *
214S_new_slab(pTHX_ size_t sz)
215{
7aef8e5b 216#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
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");
224 abort();
225 }
226 slab->opslab_size = (U16)sz;
7aef8e5b 227#else
8be227ab 228 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 229#endif
dc3bf405
BF
230#ifndef WIN32
231 /* The context is unused in non-Windows */
232 PERL_UNUSED_CONTEXT;
233#endif
8be227ab
FC
234 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
235 return slab;
236}
237
e7372881
FC
238/* requires double parens and aTHX_ */
239#define DEBUG_S_warn(args) \
240 DEBUG_S( \
241 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
242 )
243
49c01b24
DM
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.
248 */
249
8be227ab
FC
250void *
251Perl_Slab_Alloc(pTHX_ size_t sz)
252{
8be227ab
FC
253 OPSLAB *slab;
254 OPSLAB *slab2;
255 OPSLOT *slot;
256 OP *o;
5cb52f30 257 size_t opsz, space;
8be227ab 258
2073970f
NC
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. */
8be227ab
FC
265 if (!PL_compcv || CvROOT(PL_compcv)
266 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
29e61fd9
DM
267 {
268 o = (OP*)PerlMemShared_calloc(1, sz);
269 goto gotit;
270 }
8be227ab 271
2073970f
NC
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
277 details. */
278 if (!CvSTART(PL_compcv)) {
8be227ab
FC
279 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 */
283 }
284 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
285
5cb52f30
FC
286 opsz = SIZE_TO_PSIZE(sz);
287 sz = opsz + OPSLOT_HEADER_P;
8be227ab 288
2073970f
NC
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. */
8be227ab
FC
292 if (slab->opslab_freed) {
293 OP **too = &slab->opslab_freed;
294 o = *too;
eb212a1c 295 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
8be227ab 296 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 297 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 298 o = *(too = &o->op_next);
eb212a1c 299 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
8be227ab
FC
300 }
301 if (o) {
302 *too = o->op_next;
5cb52f30 303 Zero(o, opsz, I32 *);
8be227ab 304 o->op_slabbed = 1;
29e61fd9 305 goto gotit;
8be227ab
FC
306 }
307 }
308
7aef8e5b 309#define INIT_OPSLOT \
8be227ab
FC
310 slot->opslot_slab = slab; \
311 slot->opslot_next = slab2->opslab_first; \
312 slab2->opslab_first = slot; \
313 o = &slot->opslot_op; \
314 o->op_slabbed = 1
315
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. */
320
8be227ab
FC
321 /* If we can fit a BASEOP, add it to the free chain, so as not
322 to waste it. */
323 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
324 slot = &slab2->opslab_slots;
325 INIT_OPSLOT;
326 o->op_type = OP_FREED;
327 o->op_next = slab->opslab_freed;
328 slab->opslab_freed = o;
329 }
330
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;
af7751f6
FC
334 slab2 = S_new_slab(aTHX_
335 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 336 ? PERL_MAX_SLAB_SIZE
af7751f6 337 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC
338 slab2->opslab_next = slab->opslab_next;
339 slab->opslab_next = slab2;
8be227ab
FC
340 }
341 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
342
343 /* Create a new op slot */
344 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
345 assert(slot >= &slab2->opslab_slots);
51c777ca
FC
346 if (DIFF(&slab2->opslab_slots, slot)
347 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
348 slot = &slab2->opslab_slots;
8be227ab 349 INIT_OPSLOT;
eb212a1c 350 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
29e61fd9
DM
351
352 gotit:
87b5a8b9
DM
353 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
354 assert(!o->op_moresib);
86cd3a13 355 assert(!o->op_sibparent);
29e61fd9 356
8be227ab
FC
357 return (void *)o;
358}
359
7aef8e5b 360#undef INIT_OPSLOT
8be227ab 361
7aef8e5b 362#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
363void
364Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
365{
366 PERL_ARGS_ASSERT_SLAB_TO_RO;
367
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);
376 }
377}
378
7bbbc3c0
NC
379void
380Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 381{
3107b51f
FC
382 OPSLAB *slab2;
383
384 PERL_ARGS_ASSERT_SLAB_TO_RW;
385
3107b51f
FC
386 if (!slab->opslab_readonly) return;
387 slab2 = slab;
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);
395 }
396 }
397 slab->opslab_readonly = 0;
398}
399
400#else
9e4d7a13 401# define Slab_to_rw(op) NOOP
3107b51f
FC
402#endif
403
8be227ab
FC
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
406 commit 083fcd5. */
7aef8e5b 407#ifdef NETWARE
8be227ab 408# define PerlMemShared PerlMem
7aef8e5b 409#endif
8be227ab 410
c5cd8dab
DM
411/* make freed ops die if they're inadvertently executed */
412#ifdef DEBUGGING
413static OP *
414S_pp_freed(pTHX)
415{
416 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
417}
418#endif
419
49c01b24
DM
420
421/* Return the block of memory used by an op to the free list of
422 * the OP slab associated with that op.
423 */
424
8be227ab
FC
425void
426Perl_Slab_Free(pTHX_ void *op)
427{
428 OP * const o = (OP *)op;
429 OPSLAB *slab;
430
431 PERL_ARGS_ASSERT_SLAB_FREE;
432
c5cd8dab
DM
433#ifdef DEBUGGING
434 o->op_ppaddr = S_pp_freed;
435#endif
436
8be227ab 437 if (!o->op_slabbed) {
90840c5d
RU
438 if (!o->op_static)
439 PerlMemShared_free(op);
8be227ab
FC
440 return;
441 }
442
443 slab = OpSLAB(o);
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;
eb212a1c 449 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
8be227ab
FC
450 OpslabREFCNT_dec_padok(slab);
451}
452
453void
454Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
455{
8be227ab
FC
456 const bool havepad = !!PL_comppad;
457 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
458 if (havepad) {
459 ENTER;
460 PAD_SAVE_SETNULLPAD();
461 }
462 opslab_free(slab);
463 if (havepad) LEAVE;
464}
465
49c01b24
DM
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).
472 *
473 *
474 */
475
8be227ab
FC
476void
477Perl_opslab_free(pTHX_ OPSLAB *slab)
478{
479 OPSLAB *slab2;
480 PERL_ARGS_ASSERT_OPSLAB_FREE;
81611534 481 PERL_UNUSED_CONTEXT;
eb212a1c 482 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
8be227ab 483 assert(slab->opslab_refcnt == 1);
3dc78631 484 do {
8be227ab 485 slab2 = slab->opslab_next;
7aef8e5b 486#ifdef DEBUGGING
8be227ab 487 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC
488#endif
489#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 490 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
eb212a1c 491 (void*)slab));
3107b51f
FC
492 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
493 perror("munmap failed");
494 abort();
495 }
7aef8e5b 496#else
8be227ab 497 PerlMemShared_free(slab);
7aef8e5b 498#endif
3dc78631
DM
499 slab = slab2;
500 } while (slab);
8be227ab
FC
501}
502
49c01b24
DM
503/* like opslab_free(), but first calls op_free() on any ops in the slab
504 * not marked as OP_FREED
505 */
506
8be227ab
FC
507void
508Perl_opslab_force_free(pTHX_ OPSLAB *slab)
509{
510 OPSLAB *slab2;
7aef8e5b 511#ifdef DEBUGGING
8be227ab 512 size_t savestack_count = 0;
7aef8e5b 513#endif
8be227ab
FC
514 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
515 slab2 = slab;
516 do {
19742f39 517 OPSLOT *slot;
8be227ab
FC
518 for (slot = slab2->opslab_first;
519 slot->opslot_next;
520 slot = slot->opslot_next) {
521 if (slot->opslot_op.op_type != OP_FREED
522 && !(slot->opslot_op.op_savefree
7aef8e5b 523#ifdef DEBUGGING
8be227ab 524 && ++savestack_count
7aef8e5b 525#endif
8be227ab
FC
526 )
527 ) {
528 assert(slot->opslot_op.op_slabbed);
8be227ab 529 op_free(&slot->opslot_op);
3bf28c7e 530 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC
531 }
532 }
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 */
7aef8e5b 536#ifdef DEBUGGING
8be227ab 537 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 538#endif
ee5ee853
FC
539 /* Remove the CV’s reference count. */
540 slab->opslab_refcnt--;
8be227ab
FC
541 return;
542 }
543 free:
544 opslab_free(slab);
545}
546
3107b51f
FC
547#ifdef PERL_DEBUG_READONLY_OPS
548OP *
549Perl_op_refcnt_inc(pTHX_ OP *o)
550{
551 if(o) {
372eab01
NC
552 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
553 if (slab && slab->opslab_readonly) {
83519873 554 Slab_to_rw(slab);
372eab01
NC
555 ++o->op_targ;
556 Slab_to_ro(slab);
557 } else {
558 ++o->op_targ;
559 }
3107b51f
FC
560 }
561 return o;
562
563}
564
565PADOFFSET
566Perl_op_refcnt_dec(pTHX_ OP *o)
567{
372eab01
NC
568 PADOFFSET result;
569 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
570
3107b51f 571 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC
572
573 if (slab && slab->opslab_readonly) {
83519873 574 Slab_to_rw(slab);
372eab01
NC
575 result = --o->op_targ;
576 Slab_to_ro(slab);
577 } else {
578 result = --o->op_targ;
579 }
580 return result;
3107b51f
FC
581}
582#endif
e50aee73 583/*
ce6f1cbc 584 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 585 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 586 */
11343788 587#define CHECKOP(type,o) \
ce6f1cbc 588 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 589 ? ( op_free((OP*)o), \
cb77fdf0 590 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 591 (OP*)0 ) \
16c91539 592 : PL_check[type](aTHX_ (OP*)o))
e50aee73 593
e6438c1a 594#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 595
b9a07097 596#define OpTYPE_set(o,type) \
cba5a3b0
DG
597 STMT_START { \
598 o->op_type = (OPCODE)type; \
599 o->op_ppaddr = PL_ppaddr[type]; \
600 } STMT_END
601
76e3520e 602STATIC OP *
cea2e8a9 603S_no_fh_allowed(pTHX_ OP *o)
79072805 604{
7918f24d
NC
605 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
606
cea2e8a9 607 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 608 OP_DESC(o)));
11343788 609 return o;
79072805
LW
610}
611
76e3520e 612STATIC OP *
ce16c625
BF
613S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
614{
615 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
616 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
617 return o;
618}
619
620STATIC OP *
621S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
622{
623 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 624
ce16c625 625 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 626 return o;
79072805
LW
627}
628
76e3520e 629STATIC void
ed9feedd 630S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
8990e307 631{
ce16c625
BF
632 PERL_ARGS_ASSERT_BAD_TYPE_PV;
633
634 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
ed9feedd 635 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
ce16c625 636}
7918f24d 637
ed9feedd
DD
638/* remove flags var, its unused in all callers, move to to right end since gv
639 and kid are always the same */
ce16c625 640STATIC void
ed9feedd 641S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
ce16c625 642{
ecf05a58 643 SV * const namesv = cv_name((CV *)gv, NULL, 0);
7b3b0904 644 PERL_ARGS_ASSERT_BAD_TYPE_GV;
ce16c625 645
147e3846 646 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
ed9feedd 647 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
8990e307
LW
648}
649
7a52d87a 650STATIC void
eb796c7f 651S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 652{
7918f24d
NC
653 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
654
5a844595 655 qerror(Perl_mess(aTHX_
147e3846 656 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
be2597df 657 SVfARG(cSVOPo_sv)));
eb796c7f 658 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS
659}
660
79072805
LW
661/* "register" allocation */
662
663PADOFFSET
d6447115 664Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 665{
a0d0e21e 666 PADOFFSET off;
12bd6ede 667 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 668
7918f24d
NC
669 PERL_ARGS_ASSERT_ALLOCMY;
670
48d0d1be 671 if (flags & ~SVf_UTF8)
d6447115
NC
672 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
673 (UV)flags);
674
59f00321 675 /* complain about "my $<special_var>" etc etc */
7a207065
KW
676 if ( len
677 && !( is_our
678 || isALPHA(name[1])
679 || ( (flags & SVf_UTF8)
680 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
681 || (name[1] == '_' && len > 2)))
834a4ddd 682 {
b14845b4 683 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
f6a1dc93 684 && isASCII(name[1])
b14845b4 685 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
8d9d0498 686 /* diag_listed_as: Can't use global %s in "%s" */
d6447115
NC
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,
aab6a793 689 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 690 } else {
ce16c625
BF
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);
46fc3d4c 693 }
a0d0e21e 694 }
748a9306 695
dd2155a4 696 /* allocate a spare slot and store the name in that slot */
93a17b20 697
cc76b5cc 698 off = pad_add_name_pvn(name, len,
48d0d1be 699 (is_our ? padadd_OUR :
2502ffdf 700 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
12bd6ede 701 PL_parser->in_my_stash,
3edf23ff 702 (is_our
133706a6 703 /* $_ is always in main::, even with our */
ef00320b
FC
704 ? (PL_curstash && !memEQs(name,len,"$_")
705 ? PL_curstash
706 : PL_defstash)
5c284bb0 707 : NULL
cca43f78 708 )
dd2155a4 709 );
a74073ad
DM
710 /* anon sub prototypes contains state vars should always be cloned,
711 * otherwise the state var would be shared between anon subs */
712
713 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
714 CvCLONE_on(PL_compcv);
715
dd2155a4 716 return off;
79072805
LW
717}
718
c0b8aebd 719/*
dcccc8ff
KW
720=head1 Optree Manipulation Functions
721
c0b8aebd
FC
722=for apidoc alloccopstash
723
724Available only under threaded builds, this function allocates an entry in
725C<PL_stashpad> for the stash passed to it.
726
727=cut
728*/
729
d4d03940
FC
730#ifdef USE_ITHREADS
731PADOFFSET
1dc74fdb 732Perl_alloccopstash(pTHX_ HV *hv)
d4d03940
FC
733{
734 PADOFFSET off = 0, o = 1;
735 bool found_slot = FALSE;
736
1dc74fdb
FC
737 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
738
739 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
d4d03940 740
1dc74fdb
FC
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)
d4d03940
FC
744 found_slot = TRUE, off = o;
745 }
746 if (!found_slot) {
1dc74fdb
FC
747 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
748 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
749 off = PL_stashpadmax;
750 PL_stashpadmax += 10;
d4d03940
FC
751 }
752
1dc74fdb 753 PL_stashpad[PL_stashpadix = off] = hv;
d4d03940
FC
754 return off;
755}
756#endif
757
d2c837a0
DM
758/* free the body of an op without examining its contents.
759 * Always use this rather than FreeOp directly */
760
4136a0f7 761static void
d2c837a0
DM
762S_op_destroy(pTHX_ OP *o)
763{
d2c837a0
DM
764 FreeOp(o);
765}
766
79072805
LW
767/* Destructor */
768
6e53b6ca 769/*
44170c9a 770=for apidoc op_free
6e53b6ca 771
73cdf3a8
DM
772Free an op and its children. Only use this when an op is no longer linked
773to from any optree.
6e53b6ca
DD
774
775=cut
776*/
777
79072805 778void
864dbfa3 779Perl_op_free(pTHX_ OP *o)
79072805 780{
27da23d5 781 dVAR;
acb36ea4 782 OPCODE type;
73cdf3a8
DM
783 OP *top_op = o;
784 OP *next_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 */
788
789 if (!o || o->op_type == OP_FREED)
790 return;
791
792 if (o->op_private & OPpREFCOUNTED) {
793 /* if base of tree is refcounted, just decrement */
794 switch (o->op_type) {
795 case OP_LEAVESUB:
796 case OP_LEAVESUBLV:
797 case OP_LEAVEEVAL:
798 case OP_LEAVE:
799 case OP_SCOPE:
800 case OP_LEAVEWRITE:
801 {
802 PADOFFSET refcnt;
803 OP_REFCNT_LOCK;
804 refcnt = OpREFCNT_dec(o);
805 OP_REFCNT_UNLOCK;
806 if (refcnt) {
807 /* Need to find and remove any pattern match ops from
808 * the list we maintain for reset(). */
809 find_and_forget_pmops(o);
810 return;
811 }
812 }
813 break;
814 default:
815 break;
816 }
817 }
79072805 818
73cdf3a8
DM
819 while (next_op) {
820 o = next_op;
821
822 /* free child ops before ourself, (then free ourself "on the
823 * way back up") */
824
825 if (!went_up && o->op_flags & OPf_KIDS) {
826 next_op = cUNOPo->op_first;
827 continue;
828 }
829
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
832 * freed) */
833
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 */
839
840 /* Now process the current node */
79072805 841
0997db6f
TC
842 /* Though ops may be freed twice, freeing the op after its slab is a
843 big no-no. */
73cdf3a8 844 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
0997db6f
TC
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)
848 continue;
d0c8136d 849
0997db6f 850 type = o->op_type;
d0c8136d 851
0997db6f 852 /* an op should only ever acquire op_private flags that we know about.
09681a13
DM
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
ad53d4d4 860 * we can't spot faults in the main code, only
09681a13
DM
861 * evaled/required code */
862#ifdef DEBUGGING
73cdf3a8 863 if ( o->op_ppaddr == PL_ppaddr[type]
09681a13
DM
864 && PL_parser
865 && !PL_parser->error_count)
866 {
0997db6f
TC
867 assert(!(o->op_private & ~PL_op_private_valid[type]));
868 }
09681a13 869#endif
7934575e 870
f37b8c3f 871
0997db6f
TC
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
874 * are freed. */
875 CALL_OPFREEHOOK(o);
876
0997db6f
TC
877 if (type == OP_NULL)
878 type = (OPCODE)o->op_targ;
acb36ea4 879
0997db6f
TC
880 if (o->op_slabbed)
881 Slab_to_rw(OpSLAB(o));
fc97af9c 882
0997db6f
TC
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) {
886 cop_free((COP*)o);
887 }
acb36ea4 888
0997db6f
TC
889 op_clear(o);
890 FreeOp(o);
0997db6f
TC
891 if (PL_op == o)
892 PL_op = NULL;
73cdf3a8 893 }
acb36ea4 894}
79072805 895
73cdf3a8 896
ab576797
DM
897/* S_op_clear_gv(): free a GV attached to an OP */
898
f9db5646 899STATIC
ab576797
DM
900#ifdef USE_ITHREADS
901void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
902#else
903void S_op_clear_gv(pTHX_ OP *o, SV**svp)
904#endif
905{
906
fedf30e1
DM
907 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
908 || o->op_type == OP_MULTIDEREF)
ab576797
DM
909#ifdef USE_ITHREADS
910 && PL_curpad
911 ? ((GV*)PAD_SVl(*ixp)) : NULL;
912#else
913 ? (GV*)(*svp) : NULL;
914#endif
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);
930
931 if (still_valid)
932 SvREFCNT_inc_simple_void(gv);
933#ifdef USE_ITHREADS
934 if (*ixp > 0) {
935 pad_swipe(*ixp, TRUE);
936 *ixp = 0;
937 }
938#else
939 SvREFCNT_dec(*svp);
940 *svp = NULL;
941#endif
942 if (still_valid) {
943 int try_downgrade = SvREFCNT(gv) == 2;
944 SvREFCNT_dec_NN(gv);
945 if (try_downgrade)
946 gv_try_downgrade(gv);
947 }
948}
949
950
93c66552
DM
951void
952Perl_op_clear(pTHX_ OP *o)
acb36ea4 953{
13137afc 954
27da23d5 955 dVAR;
7918f24d
NC
956
957 PERL_ARGS_ASSERT_OP_CLEAR;
958
11343788 959 switch (o->op_type) {
acb36ea4 960 case OP_NULL: /* Was holding old type, if any. */
c67159e1 961 /* FALLTHROUGH */
4d193d44 962 case OP_ENTERTRY:
acb36ea4 963 case OP_ENTEREVAL: /* Was holding hints. */
4fa06845 964 case OP_ARGDEFELEM: /* Was holding signature index. */
acb36ea4 965 o->op_targ = 0;
a0d0e21e 966 break;
a6006777 967 default:
1d31efef 968 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
a6006777 969 break;
924ba076 970 /* FALLTHROUGH */
463ee0b2 971 case OP_GVSV:
79072805 972 case OP_GV:
a6006777 973 case OP_AELEMFAST:
f7461760 974#ifdef USE_ITHREADS
ab576797 975 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
350de78d 976#else
ab576797 977 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
350de78d 978#endif
79072805 979 break;
810bd8b7 980 case OP_METHOD_REDIR:
981 case OP_METHOD_REDIR_SUPER:
982#ifdef USE_ITHREADS
983 if (cMETHOPx(o)->op_rclass_targ) {
984 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
985 cMETHOPx(o)->op_rclass_targ = 0;
986 }
987#else
988 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
989 cMETHOPx(o)->op_rclass_sv = NULL;
990#endif
2165bd23 991 /* FALLTHROUGH */
a1ae71d2 992 case OP_METHOD_NAMED:
7d6c333c 993 case OP_METHOD_SUPER:
b46e009d 994 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
995 cMETHOPx(o)->op_u.op_meth_sv = NULL;
996#ifdef USE_ITHREADS
997 if (o->op_targ) {
998 pad_swipe(o->op_targ, 1);
999 o->op_targ = 0;
1000 }
1001#endif
1002 break;
79072805 1003 case OP_CONST:
996c9baa 1004 case OP_HINTSEVAL:
11343788 1005 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 1006 cSVOPo->op_sv = NULL;
3b1c21fa
AB
1007#ifdef USE_ITHREADS
1008 /** Bug #15654
1009 Even if op_clear does a pad_free for the target of the op,
6a077020 1010 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
1011 instead it lives on. This results in that it could be reused as
1012 a target later on when the pad was reallocated.
1013 **/
1014 if(o->op_targ) {
1015 pad_swipe(o->op_targ,1);
1016 o->op_targ = 0;
1017 }
1018#endif
79072805 1019 break;
c9df4fda 1020 case OP_DUMP:
748a9306
LW
1021 case OP_GOTO:
1022 case OP_NEXT:
1023 case OP_LAST:
1024 case OP_REDO:
11343788 1025 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306 1026 break;
924ba076 1027 /* FALLTHROUGH */
a0d0e21e 1028 case OP_TRANS:
bb16bae8 1029 case OP_TRANSR:
abd07ec0
DM
1030 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1031 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1032 {
043e41b8
DM
1033#ifdef USE_ITHREADS
1034 if (cPADOPo->op_padix > 0) {
1035 pad_swipe(cPADOPo->op_padix, TRUE);
1036 cPADOPo->op_padix = 0;
1037 }
1038#else
a0ed51b3 1039 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 1040 cSVOPo->op_sv = NULL;
043e41b8 1041#endif
acb36ea4
GS
1042 }
1043 else {
ea71c68d 1044 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 1045 cPVOPo->op_pv = NULL;
acb36ea4 1046 }
a0d0e21e
LW
1047 break;
1048 case OP_SUBST:
20e98b0f 1049 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 1050 goto clear_pmop;
5012eebe
DM
1051
1052 case OP_SPLIT:
692044df
DM
1053 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1054 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
5012eebe
DM
1055 {
1056 if (o->op_private & OPpSPLIT_LEX)
1057 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1058 else
971a9dd3 1059#ifdef USE_ITHREADS
5012eebe 1060 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3 1061#else
5012eebe 1062 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3 1063#endif
5012eebe 1064 }
924ba076 1065 /* FALLTHROUGH */
a0d0e21e 1066 case OP_MATCH:
8782bef2 1067 case OP_QR:
7b52d656 1068 clear_pmop:
867940b8
DM
1069 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1070 op_free(cPMOPo->op_code_list);
68e2671b 1071 cPMOPo->op_code_list = NULL;
23083432 1072 forget_pmop(cPMOPo);
20e98b0f 1073 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC
1074 /* we use the same protection as the "SAFE" version of the PM_ macros
1075 * here since sv_clean_all might release some PMOPs
5f8cb046
DM
1076 * after PL_regex_padav has been cleared
1077 * and the clearing of PL_regex_padav needs to
1078 * happen before sv_clean_all
1079 */
13137afc
AB
1080#ifdef USE_ITHREADS
1081 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 1082 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 1083 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC
1084 PL_regex_pad[offset] = &PL_sv_undef;
1085 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1086 sizeof(offset));
13137afc 1087 }
9cddf794
NC
1088#else
1089 ReREFCNT_dec(PM_GETRE(cPMOPo));
1090 PM_SETRE(cPMOPo, NULL);
1eb1540c 1091#endif
13137afc 1092
a0d0e21e 1093 break;
fedf30e1 1094
4fa06845
DM
1095 case OP_ARGCHECK:
1096 PerlMemShared_free(cUNOP_AUXo->op_aux);
1097 break;
1098
e839e6ed
DM
1099 case OP_MULTICONCAT:
1100 {
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;
1107 if (p1)
1108 PerlMemShared_free(p1);
1109 if (p2 && p1 != p2)
1110 PerlMemShared_free(p2);
1111 PerlMemShared_free(aux);
1112 }
1113 break;
1114
fedf30e1
DM
1115 case OP_MULTIDEREF:
1116 {
1117 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118 UV actions = items->uv;
1119 bool last = 0;
1120 bool is_hash = FALSE;
1121
1122 while (!last) {
1123 switch (actions & MDEREF_ACTION_MASK) {
1124
1125 case MDEREF_reload:
1126 actions = (++items)->uv;
1127 continue;
1128
1129 case MDEREF_HV_padhv_helem:
1130 is_hash = TRUE;
2165bd23 1131 /* FALLTHROUGH */
fedf30e1
DM
1132 case MDEREF_AV_padav_aelem:
1133 pad_free((++items)->pad_offset);
1134 goto do_elem;
1135
1136 case MDEREF_HV_gvhv_helem:
1137 is_hash = TRUE;
2165bd23 1138 /* FALLTHROUGH */
fedf30e1
DM
1139 case MDEREF_AV_gvav_aelem:
1140#ifdef USE_ITHREADS
1141 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142#else
1143 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1144#endif
1145 goto do_elem;
1146
1147 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1148 is_hash = TRUE;
2165bd23 1149 /* FALLTHROUGH */
fedf30e1
DM
1150 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1151#ifdef USE_ITHREADS
1152 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1153#else
1154 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1155#endif
1156 goto do_vivify_rv2xv_elem;
1157
1158 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1159 is_hash = TRUE;
2165bd23 1160 /* FALLTHROUGH */
fedf30e1
DM
1161 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1162 pad_free((++items)->pad_offset);
1163 goto do_vivify_rv2xv_elem;
1164
1165 case MDEREF_HV_pop_rv2hv_helem:
1166 case MDEREF_HV_vivify_rv2hv_helem:
1167 is_hash = TRUE;
2165bd23 1168 /* FALLTHROUGH */
fedf30e1
DM
1169 do_vivify_rv2xv_elem:
1170 case MDEREF_AV_pop_rv2av_aelem:
1171 case MDEREF_AV_vivify_rv2av_aelem:
1172 do_elem:
1173 switch (actions & MDEREF_INDEX_MASK) {
1174 case MDEREF_INDEX_none:
1175 last = 1;
1176 break;
1177 case MDEREF_INDEX_const:
1178 if (is_hash) {
1179#ifdef USE_ITHREADS
1180 /* see RT #15654 */
1181 pad_swipe((++items)->pad_offset, 1);
1182#else
1183 SvREFCNT_dec((++items)->sv);
1184#endif
1185 }
1186 else
1187 items++;
1188 break;
1189 case MDEREF_INDEX_padsv:
1190 pad_free((++items)->pad_offset);
1191 break;
1192 case MDEREF_INDEX_gvsv:
1193#ifdef USE_ITHREADS
1194 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1195#else
1196 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1197#endif
1198 break;
1199 }
1200
1201 if (actions & MDEREF_FLAG_last)
1202 last = 1;
1203 is_hash = FALSE;
1204
1205 break;
1206
1207 default:
1208 assert(0);
1209 last = 1;
1210 break;
1211
1212 } /* switch */
1213
1214 actions >>= MDEREF_SHIFT;
1215 } /* while */
1216
1217 /* start of malloc is at op_aux[-1], where the length is
1218 * stored */
1219 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1220 }
1221 break;
79072805
LW
1222 }
1223
743e66e6 1224 if (o->op_targ > 0) {
11343788 1225 pad_free(o->op_targ);
743e66e6
GS
1226 o->op_targ = 0;
1227 }
79072805
LW
1228}
1229
76e3520e 1230STATIC void
3eb57f73
HS
1231S_cop_free(pTHX_ COP* cop)
1232{
7918f24d
NC
1233 PERL_ARGS_ASSERT_COP_FREE;
1234
05ec9bb3 1235 CopFILE_free(cop);
0453d815 1236 if (! specialWARN(cop->cop_warnings))
72dc9ed5 1237 PerlMemShared_free(cop->cop_warnings);
20439bc7 1238 cophh_free(CopHINTHASH_get(cop));
515abc43
FC
1239 if (PL_curcop == cop)
1240 PL_curcop = NULL;
3eb57f73
HS
1241}
1242
c2b1997a 1243STATIC void
ddda3df5 1244S_forget_pmop(pTHX_ PMOP *const o)
c2b1997a
NC
1245{
1246 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
1247
1248 PERL_ARGS_ASSERT_FORGET_PMOP;
1249
e39a6381 1250 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 1251 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
1252 if (mg) {
1253 PMOP **const array = (PMOP**) mg->mg_ptr;
1254 U32 count = mg->mg_len / sizeof(PMOP**);
1255 U32 i = count;
1256
1257 while (i--) {
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
1264 last. */
1265 if(!count) {
1266 Safefree(mg->mg_ptr);
1267 mg->mg_ptr = NULL;
1268 }
1269 break;
1270 }
1271 }
1272 }
1273 }
1cdf7faf
NC
1274 if (PL_curpm == o)
1275 PL_curpm = NULL;
c2b1997a
NC
1276}
1277
bfd0ff22
NC
1278STATIC void
1279S_find_and_forget_pmops(pTHX_ OP *o)
1280{
7918f24d
NC
1281 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1282
bfd0ff22
NC
1283 if (o->op_flags & OPf_KIDS) {
1284 OP *kid = cUNOPo->op_first;
1285 while (kid) {
1286 switch (kid->op_type) {
1287 case OP_SUBST:
5012eebe 1288 case OP_SPLIT:
bfd0ff22
NC
1289 case OP_MATCH:
1290 case OP_QR:
23083432 1291 forget_pmop((PMOP*)kid);
bfd0ff22
NC
1292 }
1293 find_and_forget_pmops(kid);
e6dae479 1294 kid = OpSIBLING(kid);
bfd0ff22
NC
1295 }
1296 }
1297}
1298
6e53b6ca 1299/*
44170c9a 1300=for apidoc op_null
6e53b6ca
DD
1301
1302Neutralizes an op when it is no longer needed, but is still linked to from
1303other ops.
1304
1305=cut
1306*/
1307
93c66552
DM
1308void
1309Perl_op_null(pTHX_ OP *o)
8990e307 1310{
27da23d5 1311 dVAR;
7918f24d
NC
1312
1313 PERL_ARGS_ASSERT_OP_NULL;
1314
acb36ea4
GS
1315 if (o->op_type == OP_NULL)
1316 return;
b5bbe64a 1317 op_clear(o);
11343788 1318 o->op_targ = o->op_type;
b9a07097 1319 OpTYPE_set(o, OP_NULL);
8990e307
LW
1320}
1321
4026c95a
SH
1322void
1323Perl_op_refcnt_lock(pTHX)
e1fc825d 1324 PERL_TSA_ACQUIRE(PL_op_mutex)
4026c95a 1325{
20b7effb 1326#ifdef USE_ITHREADS
27da23d5 1327 dVAR;
20b7effb 1328#endif
96a5add6 1329 PERL_UNUSED_CONTEXT;
4026c95a
SH
1330 OP_REFCNT_LOCK;
1331}
1332
1333void
1334Perl_op_refcnt_unlock(pTHX)
e1fc825d 1335 PERL_TSA_RELEASE(PL_op_mutex)
4026c95a 1336{
20b7effb 1337#ifdef USE_ITHREADS
27da23d5 1338 dVAR;
20b7effb 1339#endif
96a5add6 1340 PERL_UNUSED_CONTEXT;
4026c95a
SH
1341 OP_REFCNT_UNLOCK;
1342}
1343
3253bf85
DM
1344
1345/*
1346=for apidoc op_sibling_splice
1347
1348A general function for editing the structure of an existing chain of
796b6530 1349op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
3253bf85
DM
1350you to delete zero or more sequential nodes, replacing them with zero or
1351more different nodes. Performs the necessary op_first/op_last
29e61fd9 1352housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1353children. The last deleted node will be marked as as the last node by
87b5a8b9 1354updating the op_sibling/op_sibparent or op_moresib field as appropriate.
3253bf85
DM
1355
1356Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1357responsibility of the caller. It also won't create a new list op for an
8ae26bff 1358empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85 1359
796b6530 1360C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
3269ea41 1361the splicing doesn't affect the first or last op in the chain.
3253bf85 1362
796b6530 1363C<start> is the node preceding the first node to be spliced. Node(s)
7e234f81 1364following it will be deleted, and ops will be inserted after it. If it is
796b6530 1365C<NULL>, the first node onwards is deleted, and nodes are inserted at the
3253bf85
DM
1366beginning.
1367
796b6530 1368C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1369If -1 or greater than or equal to the number of remaining kids, all
1370remaining kids are deleted.
1371
796b6530
KW
1372C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1373If C<NULL>, no nodes are inserted.
3253bf85 1374
796b6530 1375The head of the chain of deleted ops is returned, or C<NULL> if no ops were
3253bf85
DM
1376deleted.
1377
1378For example:
1379
1380 action before after returns
1381 ------ ----- ----- -------
1382
1383 P P
8ae26bff
DM
1384 splice(P, A, 2, X-Y-Z) | | B-C
1385 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1386
1387 P P
1388 splice(P, NULL, 1, X-Y) | | A
1389 A-B-C-D X-Y-B-C-D
1390
1391 P P
8ae26bff
DM
1392 splice(P, NULL, 3, NULL) | | A-B-C
1393 A-B-C-D D
3253bf85
DM
1394
1395 P P
1396 splice(P, B, 0, X-Y) | | NULL
1397 A-B-C-D A-B-X-Y-C-D
1398
5e24af7d
DM
1399
1400For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
fbe13c60 1401see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
5e24af7d 1402
3253bf85
DM
1403=cut
1404*/
1405
1406OP *
8ae26bff 1407Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1408{
3269ea41 1409 OP *first;
3253bf85
DM
1410 OP *rest;
1411 OP *last_del = NULL;
1412 OP *last_ins = NULL;
1413
3269ea41
DM
1414 if (start)
1415 first = OpSIBLING(start);
1416 else if (!parent)
1417 goto no_parent;
1418 else
1419 first = cLISTOPx(parent)->op_first;
3253bf85
DM
1420
1421 assert(del_count >= -1);
1422
1423 if (del_count && first) {
1424 last_del = first;
e6dae479
FC
1425 while (--del_count && OpHAS_SIBLING(last_del))
1426 last_del = OpSIBLING(last_del);
1427 rest = OpSIBLING(last_del);
5e24af7d 1428 OpLASTSIB_set(last_del, NULL);
3253bf85
DM
1429 }
1430 else
1431 rest = first;
1432
1433 if (insert) {
1434 last_ins = insert;
e6dae479
FC
1435 while (OpHAS_SIBLING(last_ins))
1436 last_ins = OpSIBLING(last_ins);
5e24af7d 1437 OpMAYBESIB_set(last_ins, rest, NULL);
3253bf85
DM
1438 }
1439 else
1440 insert = rest;
1441
29e61fd9 1442 if (start) {
5e24af7d 1443 OpMAYBESIB_set(start, insert, NULL);
29e61fd9 1444 }
b3e29a8d 1445 else {
678ae292 1446 assert(parent);
3253bf85 1447 cLISTOPx(parent)->op_first = insert;
b3e29a8d
DM
1448 if (insert)
1449 parent->op_flags |= OPf_KIDS;
1450 else
1451 parent->op_flags &= ~OPf_KIDS;
1452 }
3253bf85
DM
1453
1454 if (!rest) {
29e61fd9 1455 /* update op_last etc */
3269ea41 1456 U32 type;
29e61fd9 1457 OP *lastop;
3253bf85 1458
3269ea41
DM
1459 if (!parent)
1460 goto no_parent;
1461
05039abd
DM
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
1464 * either */
3269ea41 1465 type = parent->op_type;
05039abd
DM
1466 if (type == OP_CUSTOM) {
1467 dTHX;
1468 type = XopENTRYCUSTOM(parent, xop_class);
1469 }
1470 else {
1471 if (type == OP_NULL)
1472 type = parent->op_targ;
1473 type = PL_opargs[type] & OA_CLASS_MASK;
1474 }
3253bf85 1475
29e61fd9 1476 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1477 if ( type == OA_BINOP
1478 || type == OA_LISTOP
1479 || type == OA_PMOP
1480 || type == OA_LOOP
1481 )
29e61fd9
DM
1482 cLISTOPx(parent)->op_last = lastop;
1483
5e24af7d
DM
1484 if (lastop)
1485 OpLASTSIB_set(lastop, parent);
3253bf85
DM
1486 }
1487 return last_del ? first : NULL;
3269ea41
DM
1488
1489 no_parent:
1490 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
3253bf85
DM
1491}
1492
29e61fd9
DM
1493/*
1494=for apidoc op_parent
1495
796b6530 1496Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
29e61fd9
DM
1497
1498=cut
1499*/
1500
1501OP *
8ae26bff 1502Perl_op_parent(OP *o)
29e61fd9
DM
1503{
1504 PERL_ARGS_ASSERT_OP_PARENT;
e6dae479
FC
1505 while (OpHAS_SIBLING(o))
1506 o = OpSIBLING(o);
86cd3a13 1507 return o->op_sibparent;
29e61fd9
DM
1508}
1509
3253bf85
DM
1510/* replace the sibling following start with a new UNOP, which becomes
1511 * the parent of the original sibling; e.g.
1512 *
1513 * op_sibling_newUNOP(P, A, unop-args...)
1514 *
1515 * P P
1516 * | becomes |
1517 * A-B-C A-U-C
1518 * |
1519 * B
1520 *
1521 * where U is the new UNOP.
1522 *
1523 * parent and start args are the same as for op_sibling_splice();
1524 * type and flags args are as newUNOP().
1525 *
1526 * Returns the new UNOP.
1527 */
1528
f9db5646 1529STATIC OP *
3253bf85
DM
1530S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1531{
1532 OP *kid, *newop;
1533
1534 kid = op_sibling_splice(parent, start, 1, NULL);
1535 newop = newUNOP(type, flags, kid);
1536 op_sibling_splice(parent, start, 0, newop);
1537 return newop;
1538}
1539
1540
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.
1545 */
1546
6cb4123e
DM
1547LOGOP *
1548Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
3253bf85 1549{
1e8db68a 1550 dVAR;
3253bf85 1551 LOGOP *logop;
29e61fd9 1552 OP *kid = first;
3253bf85 1553 NewOp(1101, logop, 1, LOGOP);
b9a07097 1554 OpTYPE_set(logop, type);
3253bf85
DM
1555 logop->op_first = first;
1556 logop->op_other = other;
d2d35729
FC
1557 if (first)
1558 logop->op_flags = OPf_KIDS;
e6dae479
FC
1559 while (kid && OpHAS_SIBLING(kid))
1560 kid = OpSIBLING(kid);
5e24af7d
DM
1561 if (kid)
1562 OpLASTSIB_set(kid, (OP*)logop);
3253bf85
DM
1563 return logop;
1564}
1565
1566
79072805
LW
1567/* Contextualizers */
1568
d9088386 1569/*
44170c9a 1570=for apidoc op_contextualize
d9088386
Z
1571
1572Applies a syntactic context to an op tree representing an expression.
2d7f6611 1573C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
d9088386
Z
1574or C<G_VOID> to specify the context to apply. The modified op tree
1575is returned.
1576
1577=cut
1578*/
1579
1580OP *
1581Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582{
1583 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584 switch (context) {
1585 case G_SCALAR: return scalar(o);
1586 case G_ARRAY: return list(o);
1587 case G_VOID: return scalarvoid(o);
1588 default:
5637ef5b
NC
1589 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1590 (long) context);
d9088386
Z
1591 }
1592}
1593
5983a79d 1594/*
79072805 1595
44170c9a 1596=for apidoc op_linklist
72d33970 1597This function is the implementation of the L</LINKLIST> macro. It should
5983a79d
BM
1598not be called directly.
1599
1600=cut
1601*/
1602
1603OP *
1604Perl_op_linklist(pTHX_ OP *o)
79072805 1605{
5983a79d 1606 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1607
11343788
MB
1608 if (o->op_next)
1609 return o->op_next;
79072805
LW
1610
1611 /* establish postfix order */
5e21b4fc 1612 if (o->op_flags & OPf_KIDS) {
eb578fdb 1613 OP *kid;
5e21b4fc 1614 OP *first = cUNOPo->op_first;
3edf23ff
AL
1615 o->op_next = LINKLIST(first);
1616 kid = first;
1617 for (;;) {
e6dae479 1618 OP *sibl = OpSIBLING(kid);
29e61fd9
DM
1619 if (sibl) {
1620 kid->op_next = LINKLIST(sibl);
1621 kid = sibl;
3edf23ff 1622 } else {
11343788 1623 kid->op_next = o;
3edf23ff
AL
1624 break;
1625 }
79072805
LW
1626 }
1627 }
1628 else
11343788 1629 o->op_next = o;
79072805 1630
11343788 1631 return o->op_next;
79072805
LW
1632}
1633
1f676739 1634static OP *
2dd5337b 1635S_scalarkids(pTHX_ OP *o)
79072805 1636{
11343788 1637 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1638 OP *kid;
e6dae479 1639 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
1640 scalar(kid);
1641 }
11343788 1642 return o;
79072805
LW
1643}
1644
76e3520e 1645STATIC OP *
cea2e8a9 1646S_scalarboolean(pTHX_ OP *o)
8990e307 1647{
7918f24d
NC
1648 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1649
0a44e30b
DC
1650 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1651 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1652 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1653 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1654 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
d008e5eb 1655 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1656 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1657
2b7cddde
NC
1658 if (PL_parser && PL_parser->copline != NOLINE) {
1659 /* This ensures that warnings are reported at the first line
1660 of the conditional, not the last. */
53a7735b 1661 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1662 }
9014280d 1663 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1664 CopLINE_set(PL_curcop, oldline);
d008e5eb 1665 }
a0d0e21e 1666 }
11343788 1667 return scalar(o);
8990e307
LW
1668}
1669
0920b7fa 1670static SV *
637494ac 1671S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
0920b7fa
FC
1672{
1673 assert(o);
1674 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1675 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1676 {
1677 const char funny = o->op_type == OP_PADAV
1678 || o->op_type == OP_RV2AV ? '@' : '%';
1679 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1680 GV *gv;
1681 if (cUNOPo->op_first->op_type != OP_GV
1682 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1683 return NULL;
637494ac 1684 return varname(gv, funny, 0, NULL, 0, subscript_type);
0920b7fa
FC
1685 }
1686 return
637494ac 1687 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
0920b7fa
FC
1688 }
1689}
1690
637494ac
TC
1691static SV *
1692S_op_varname(pTHX_ const OP *o)
1693{
1694 return S_op_varname_subscript(aTHX_ o, 1);
1695}
1696
429a2555 1697static void
2186f873
FC
1698S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1699{ /* or not so pretty :-) */
2186f873
FC
1700 if (o->op_type == OP_CONST) {
1701 *retsv = cSVOPo_sv;
1702 if (SvPOK(*retsv)) {
1703 SV *sv = *retsv;
1704 *retsv = sv_newmortal();
1705 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1706 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1707 }
1708 else if (!SvOK(*retsv))
1709 *retpv = "undef";
1710 }
1711 else *retpv = "...";
1712}
1713
1714static void
429a2555
FC
1715S_scalar_slice_warning(pTHX_ const OP *o)
1716{
1717 OP *kid;
fe7df09e
FC
1718 const bool h = o->op_type == OP_HSLICE
1719 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
429a2555 1720 const char lbrack =
fe7df09e 1721 h ? '{' : '[';
429a2555 1722 const char rbrack =
fe7df09e 1723 h ? '}' : ']';
429a2555 1724 SV *name;
32e9ec8f 1725 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC
1726 const char *key = NULL;
1727
1728 if (!(o->op_private & OPpSLICEWARNING))
1729 return;
1730 if (PL_parser && PL_parser->error_count)
1731 /* This warning can be nonsensical when there is a syntax error. */
1732 return;
1733
1734 kid = cLISTOPo->op_first;
e6dae479 1735 kid = OpSIBLING(kid); /* get past pushmark */
429a2555
FC
1736 /* weed out false positives: any ops that can return lists */
1737 switch (kid->op_type) {
1738 case OP_BACKTICK:
1739 case OP_GLOB:
1740 case OP_READLINE:
1741 case OP_MATCH:
1742 case OP_RV2AV:
1743 case OP_EACH:
1744 case OP_VALUES:
1745 case OP_KEYS:
1746 case OP_SPLIT:
1747 case OP_LIST:
1748 case OP_SORT:
1749 case OP_REVERSE:
1750 case OP_ENTERSUB:
1751 case OP_CALLER:
1752 case OP_LSTAT:
1753 case OP_STAT:
1754 case OP_READDIR:
1755 case OP_SYSTEM:
1756 case OP_TMS:
1757 case OP_LOCALTIME:
1758 case OP_GMTIME:
1759 case OP_ENTEREVAL:
429a2555
FC
1760 return;
1761 }
7d3c8a68
SM
1762
1763 /* Don't warn if we have a nulled list either. */
1764 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1765 return;
1766
e6dae479
FC
1767 assert(OpSIBLING(kid));
1768 name = S_op_varname(aTHX_ OpSIBLING(kid));
429a2555
FC
1769 if (!name) /* XS module fiddling with the op tree */
1770 return;
2186f873 1771 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC
1772 assert(SvPOK(name));
1773 sv_chop(name,SvPVX(name)+1);
1774 if (key)
2186f873 1775 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1776 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846 1777 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
429a2555 1778 "%c%s%c",
2186f873 1779 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC
1780 lbrack, key, rbrack);
1781 else
2186f873 1782 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1783 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846
KW
1784 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1785 SVf "%c%" SVf "%c",
c1f6cd39
BF
1786 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1787 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
429a2555
FC
1788}
1789
8623f87f
DM
1790
1791
1792/* apply scalar context to the o subtree */
1793
8990e307 1794OP *
864dbfa3 1795Perl_scalar(pTHX_ OP *o)
79072805 1796{
86e988be
DM
1797 OP * top_op = o;
1798
1799 while (1) {
78ae974a
DM
1800 OP *next_kid = NULL; /* what op (if any) to process next */
1801 OP *kid;
8623f87f 1802
78ae974a
DM
1803 /* assumes no premature commitment */
1804 if (!o || (PL_parser && PL_parser->error_count)
1805 || (o->op_flags & OPf_WANT)
1806 || o->op_type == OP_RETURN)
1807 {
1808 goto do_next;
1809 }
8623f87f 1810
78ae974a 1811 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
8623f87f 1812
78ae974a
DM
1813 switch (o->op_type) {
1814 case OP_REPEAT:
1815 scalar(cBINOPo->op_first);
1816 /* convert what initially looked like a list repeat into a
1817 * scalar repeat, e.g. $s = (1) x $n
1818 */
1819 if (o->op_private & OPpREPEAT_DOLIST) {
1820 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1821 assert(kid->op_type == OP_PUSHMARK);
1822 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1823 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1824 o->op_private &=~ OPpREPEAT_DOLIST;
1825 }
1826 }
1827 break;
8623f87f 1828
78ae974a
DM
1829 case OP_OR:
1830 case OP_AND:
1831 case OP_COND_EXPR:
1832 /* impose scalar context on everything except the condition */
1833 next_kid = OpSIBLING(cUNOPo->op_first);
1834 break;
8623f87f 1835
78ae974a
DM
1836 default:
1837 if (o->op_flags & OPf_KIDS)
1838 next_kid = cUNOPo->op_first; /* do all kids */
1839 break;
2186f873 1840
78ae974a
DM
1841 /* the children of these ops are usually a list of statements,
1842 * except the leaves, whose first child is a corresponding enter
1843 */
1844 case OP_SCOPE:
1845 case OP_LINESEQ:
1846 case OP_LIST:
1847 kid = cLISTOPo->op_first;
1848 goto do_kids;
1849 case OP_LEAVE:
1850 case OP_LEAVETRY:
1851 kid = cLISTOPo->op_first;
1852 scalar(kid);
1853 kid = OpSIBLING(kid);
1854 do_kids:
1855 while (kid) {
1856 OP *sib = OpSIBLING(kid);
adb47cec
DM
1857 /* Apply void context to all kids except the last, which
1858 * is scalar (ignoring a trailing ex-nextstate in determining
1859 * if it's the last kid). E.g.
1860 * $scalar = do { void; void; scalar }
1861 * Except that 'when's are always scalar, e.g.
1862 * $scalar = do { given(..) {
1863 * when (..) { scalar }
1864 * when (..) { scalar }
1865 * ...
1866 * }}
1867 */
1868 if (!sib
1869 || ( !OpHAS_SIBLING(sib)
1870 && sib->op_type == OP_NULL
1871 && ( sib->op_targ == OP_NEXTSTATE
1872 || sib->op_targ == OP_DBSTATE )
1873 )
1874 )
db18005b
DM
1875 {
1876 /* tail call optimise calling scalar() on the last kid */
1877 next_kid = kid;
1878 goto do_next;
1879 }
adb47cec 1880 else if (kid->op_type == OP_LEAVEWHEN)
78ae974a 1881 scalar(kid);
adb47cec
DM
1882 else
1883 scalarvoid(kid);
78ae974a
DM
1884 kid = sib;
1885 }
db18005b 1886 NOT_REACHED; /* NOTREACHED */
78ae974a 1887 break;
2186f873 1888
78ae974a
DM
1889 case OP_SORT:
1890 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1891 break;
2186f873 1892
78ae974a
DM
1893 case OP_KVHSLICE:
1894 case OP_KVASLICE:
1895 {
1896 /* Warn about scalar context */
1897 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1898 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1899 SV *name;
1900 SV *keysv;
1901 const char *key = NULL;
1902
1903 /* This warning can be nonsensical when there is a syntax error. */
1904 if (PL_parser && PL_parser->error_count)
1905 break;
1906
1907 if (!ckWARN(WARN_SYNTAX)) break;
1908
1909 kid = cLISTOPo->op_first;
1910 kid = OpSIBLING(kid); /* get past pushmark */
1911 assert(OpSIBLING(kid));
1912 name = S_op_varname(aTHX_ OpSIBLING(kid));
1913 if (!name) /* XS module fiddling with the op tree */
1914 break;
1915 S_op_pretty(aTHX_ kid, &keysv, &key);
1916 assert(SvPOK(name));
1917 sv_chop(name,SvPVX(name)+1);
1918 if (key)
1919 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1920 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1921 "%%%" SVf "%c%s%c in scalar context better written "
1922 "as $%" SVf "%c%s%c",
1923 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1924 lbrack, key, rbrack);
1925 else
1926 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1928 "%%%" SVf "%c%" SVf "%c in scalar context better "
1929 "written as $%" SVf "%c%" SVf "%c",
1930 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1931 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1932 }
1933 } /* switch */
1934
1935 /* If next_kid is set, someone in the code above wanted us to process
1936 * that kid and all its remaining siblings. Otherwise, work our way
1937 * back up the tree */
1938 do_next:
1939 while (!next_kid) {
1940 if (o == top_op)
1941 return top_op; /* at top; no parents/siblings to try */
1942 if (OpHAS_SIBLING(o))
1943 next_kid = o->op_sibparent;
db18005b 1944 else {
78ae974a 1945 o = o->op_sibparent; /*try parent's next sibling */
db18005b
DM
1946 switch (o->op_type) {
1947 case OP_SCOPE:
1948 case OP_LINESEQ:
1949 case OP_LIST:
1950 case OP_LEAVE:
1951 case OP_LEAVETRY:
1952 /* should really restore PL_curcop to its old value, but
1953 * setting it to PL_compiling is better than do nothing */
1954 PL_curcop = &PL_compiling;
1955 }
1956 }
78ae974a
DM
1957 }
1958 o = next_kid;
86e988be 1959 } /* while */
79072805
LW
1960}
1961
8623f87f 1962
67ba1548
DM
1963/* apply void context to the optree arg */
1964
79072805 1965OP *
aa9d1253 1966Perl_scalarvoid(pTHX_ OP *arg)
79072805 1967{
27da23d5 1968 dVAR;
79072805 1969 OP *kid;
8990e307 1970 SV* sv;
aa9d1253 1971 OP *o = arg;
2ebea0a1 1972
7918f24d
NC
1973 PERL_ARGS_ASSERT_SCALARVOID;
1974
2a56a87f 1975 while (1) {
19742f39 1976 U8 want;
aa9d1253
TC
1977 SV *useless_sv = NULL;
1978 const char* useless = NULL;
2a56a87f 1979 OP * next_kid = NULL;
aa9d1253 1980
26f0e7d5
TC
1981 if (o->op_type == OP_NEXTSTATE
1982 || o->op_type == OP_DBSTATE
1983 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1984 || o->op_targ == OP_DBSTATE)))
1985 PL_curcop = (COP*)o; /* for warning below */
1986
1987 /* assumes no premature commitment */
1988 want = o->op_flags & OPf_WANT;
1989 if ((want && want != OPf_WANT_SCALAR)
1990 || (PL_parser && PL_parser->error_count)
7896dde7 1991 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
26f0e7d5 1992 {
2a56a87f 1993 goto get_next_op;
26f0e7d5 1994 }
1c846c1f 1995
26f0e7d5
TC
1996 if ((o->op_private & OPpTARGET_MY)
1997 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1998 {
0d18dd72
FC
1999 /* newASSIGNOP has already applied scalar context, which we
2000 leave, as if this op is inside SASSIGN. */
2a56a87f 2001 goto get_next_op;
26f0e7d5 2002 }
79072805 2003
26f0e7d5 2004 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
75068674 2005
26f0e7d5
TC
2006 switch (o->op_type) {
2007 default:
2008 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2009 break;
2010 /* FALLTHROUGH */
2011 case OP_REPEAT:
2012 if (o->op_flags & OPf_STACKED)
2013 break;
1e2dd519
FC
2014 if (o->op_type == OP_REPEAT)
2015 scalar(cBINOPo->op_first);
26f0e7d5 2016 goto func_ops;
3d033384
Z
2017 case OP_CONCAT:
2018 if ((o->op_flags & OPf_STACKED) &&
2019 !(o->op_private & OPpCONCAT_NESTED))
2020 break;
2021 goto func_ops;
26f0e7d5
TC
2022 case OP_SUBSTR:
2023 if (o->op_private == 4)
2024 break;
2025 /* FALLTHROUGH */
26f0e7d5
TC
2026 case OP_WANTARRAY:
2027 case OP_GV:
2028 case OP_SMARTMATCH:
26f0e7d5
TC
2029 case OP_AV2ARYLEN:
2030 case OP_REF:
2031 case OP_REFGEN:
2032 case OP_SREFGEN:
2033 case OP_DEFINED:
2034 case OP_HEX:
2035 case OP_OCT:
2036 case OP_LENGTH:
2037 case OP_VEC:
2038 case OP_INDEX:
2039 case OP_RINDEX:
2040 case OP_SPRINTF:
26f0e7d5 2041 case OP_KVASLICE:
26f0e7d5
TC
2042 case OP_KVHSLICE:
2043 case OP_UNPACK:
2044 case OP_PACK:
2045 case OP_JOIN:
2046 case OP_LSLICE:
2047 case OP_ANONLIST:
2048 case OP_ANONHASH:
2049 case OP_SORT:
2050 case OP_REVERSE:
2051 case OP_RANGE:
2052 case OP_FLIP:
2053 case OP_FLOP:
2054 case OP_CALLER:
2055 case OP_FILENO:
2056 case OP_EOF:
2057 case OP_TELL:
2058 case OP_GETSOCKNAME:
2059 case OP_GETPEERNAME:
2060 case OP_READLINK:
2061 case OP_TELLDIR:
2062 case OP_GETPPID:
2063 case OP_GETPGRP:
2064 case OP_GETPRIORITY:
2065 case OP_TIME:
2066 case OP_TMS:
2067 case OP_LOCALTIME:
2068 case OP_GMTIME:
2069 case OP_GHBYNAME:
2070 case OP_GHBYADDR:
2071 case OP_GHOSTENT:
2072 case OP_GNBYNAME:
2073 case OP_GNBYADDR:
2074 case OP_GNETENT:
2075 case OP_GPBYNAME:
2076 case OP_GPBYNUMBER:
2077 case OP_GPROTOENT:
2078 case OP_GSBYNAME:
2079 case OP_GSBYPORT:
2080 case OP_GSERVENT:
2081 case OP_GPWNAM:
2082 case OP_GPWUID:
2083 case OP_GGRNAM:
2084 case OP_GGRGID:
2085 case OP_GETLOGIN:
2086 case OP_PROTOTYPE:
2087 case OP_RUNCV:
2088 func_ops:
9e209402
FC
2089 useless = OP_DESC(o);
2090 break;
2091
2092 case OP_GVSV:
2093 case OP_PADSV:
2094 case OP_PADAV:
2095 case OP_PADHV:
2096 case OP_PADANY:
2097 case OP_AELEM:
2098 case OP_AELEMFAST:
2099 case OP_AELEMFAST_LEX:
2100 case OP_ASLICE:
2101 case OP_HELEM:
2102 case OP_HSLICE:
26f0e7d5 2103 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
ea5519d6 2104 /* Otherwise it's "Useless use of grep iterator" */
3c3f8cd6 2105 useless = OP_DESC(o);
ea5519d6 2106 break;
26f0e7d5
TC
2107
2108 case OP_SPLIT:
5012eebe 2109 if (!(o->op_private & OPpSPLIT_ASSIGN))
26f0e7d5
TC
2110 useless = OP_DESC(o);
2111 break;
2112
2113 case OP_NOT:
2114 kid = cUNOPo->op_first;
2115 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2116 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2117 goto func_ops;
2118 }
2119 useless = "negative pattern binding (!~)";
2120 break;
2121
2122 case OP_SUBST:
2123 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2124 useless = "non-destructive substitution (s///r)";
2125 break;
2126
2127 case OP_TRANSR:
2128 useless = "non-destructive transliteration (tr///r)";
2129 break;
2130
2131 case OP_RV2GV:
2132 case OP_RV2SV:
2133 case OP_RV2AV:
2134 case OP_RV2HV:
2135 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
e6dae479 2136 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
26f0e7d5
TC
2137 useless = "a variable";
2138 break;
2139
2140 case OP_CONST:
2141 sv = cSVOPo_sv;
2142 if (cSVOPo->op_private & OPpCONST_STRICT)
2143 no_bareword_allowed(o);
2144 else {
2145 if (ckWARN(WARN_VOID)) {
2146 NV nv;
2147 /* don't warn on optimised away booleans, eg
2148 * use constant Foo, 5; Foo || print; */
2149 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2150 useless = NULL;
2151 /* the constants 0 and 1 are permitted as they are
2152 conventionally used as dummies in constructs like
2153 1 while some_condition_with_side_effects; */
2154 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2155 useless = NULL;
2156 else if (SvPOK(sv)) {
2157 SV * const dsv = newSVpvs("");
2158 useless_sv
2159 = Perl_newSVpvf(aTHX_
2160 "a constant (%s)",
2161 pv_pretty(dsv, SvPVX_const(sv),
2162 SvCUR(sv), 32, NULL, NULL,
2163 PERL_PV_PRETTY_DUMP
2164 | PERL_PV_ESCAPE_NOCLEAR
2165 | PERL_PV_ESCAPE_UNI_DETECT));
2166 SvREFCNT_dec_NN(dsv);
2167 }
2168 else if (SvOK(sv)) {
147e3846 2169 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
26f0e7d5
TC
2170 }
2171 else
2172 useless = "a constant (undef)";
2173 }
2174 }
2175 op_null(o); /* don't execute or even remember it */
2176 break;
79072805 2177
26f0e7d5 2178 case OP_POSTINC:
b9a07097 2179 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
26f0e7d5 2180 break;
79072805 2181
26f0e7d5 2182 case OP_POSTDEC:
b9a07097 2183 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
26f0e7d5 2184 break;
79072805 2185
26f0e7d5 2186 case OP_I_POSTINC:
b9a07097 2187 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
26f0e7d5 2188 break;
79072805 2189
26f0e7d5 2190 case OP_I_POSTDEC:
b9a07097 2191 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
26f0e7d5 2192 break;
679d6c4e 2193
26f0e7d5
TC
2194 case OP_SASSIGN: {
2195 OP *rv2gv;
2196 UNOP *refgen, *rv2cv;
2197 LISTOP *exlist;
679d6c4e 2198
26f0e7d5
TC
2199 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2200 break;
f2f8fd84 2201
26f0e7d5
TC
2202 rv2gv = ((BINOP *)o)->op_last;
2203 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2204 break;
f2f8fd84 2205
26f0e7d5 2206 refgen = (UNOP *)((BINOP *)o)->op_first;
f2f8fd84 2207
26f0e7d5
TC
2208 if (!refgen || (refgen->op_type != OP_REFGEN
2209 && refgen->op_type != OP_SREFGEN))
2210 break;
f2f8fd84 2211
26f0e7d5
TC
2212 exlist = (LISTOP *)refgen->op_first;
2213 if (!exlist || exlist->op_type != OP_NULL
2214 || exlist->op_targ != OP_LIST)
2215 break;
f2f8fd84 2216
26f0e7d5
TC
2217 if (exlist->op_first->op_type != OP_PUSHMARK
2218 && exlist->op_first != exlist->op_last)
2219 break;
f2f8fd84 2220
26f0e7d5 2221 rv2cv = (UNOP*)exlist->op_last;
f2f8fd84 2222
26f0e7d5
TC
2223 if (rv2cv->op_type != OP_RV2CV)
2224 break;
f2f8fd84 2225
26f0e7d5
TC
2226 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2227 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2228 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
f2f8fd84 2229
26f0e7d5
TC
2230 o->op_private |= OPpASSIGN_CV_TO_GV;
2231 rv2gv->op_private |= OPpDONT_INIT_GV;
2232 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
f2f8fd84 2233
26f0e7d5
TC
2234 break;
2235 }
540dd770 2236
26f0e7d5
TC
2237 case OP_AASSIGN: {
2238 inplace_aassign(o);
2239 break;
2240 }
edbe35ea 2241
26f0e7d5
TC
2242 case OP_OR:
2243 case OP_AND:
2244 kid = cLOGOPo->op_first;
2245 if (kid->op_type == OP_NOT
2246 && (kid->op_flags & OPf_KIDS)) {
2247 if (o->op_type == OP_AND) {
b9a07097 2248 OpTYPE_set(o, OP_OR);
26f0e7d5 2249 } else {
b9a07097 2250 OpTYPE_set(o, OP_AND);
26f0e7d5
TC
2251 }
2252 op_null(kid);
2253 }
2254 /* FALLTHROUGH */
5aabfad6 2255
26f0e7d5
TC
2256 case OP_DOR:
2257 case OP_COND_EXPR:
2258 case OP_ENTERGIVEN:
7896dde7 2259 case OP_ENTERWHEN:
2a56a87f 2260 next_kid = OpSIBLING(cUNOPo->op_first);
aa9d1253 2261 break;
095b19d1 2262
26f0e7d5
TC
2263 case OP_NULL:
2264 if (o->op_flags & OPf_STACKED)
2265 break;
2266 /* FALLTHROUGH */
2267 case OP_NEXTSTATE:
2268 case OP_DBSTATE:
2269 case OP_ENTERTRY:
2270 case OP_ENTER:
2271 if (!(o->op_flags & OPf_KIDS))
2272 break;
2273 /* FALLTHROUGH */
2274 case OP_SCOPE:
2275 case OP_LEAVE:
2276 case OP_LEAVETRY:
2277 case OP_LEAVELOOP:
2278 case OP_LINESEQ:
7896dde7
Z
2279 case OP_LEAVEGIVEN:
2280 case OP_LEAVEWHEN:
26f0e7d5 2281 kids:
2a56a87f 2282 next_kid = cLISTOPo->op_first;
26f0e7d5
TC
2283 break;
2284 case OP_LIST:
2285 /* If the first kid after pushmark is something that the padrange
2286 optimisation would reject, then null the list and the pushmark.
2287 */
2288 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
e6dae479 2289 && ( !(kid = OpSIBLING(kid))
26f0e7d5
TC
2290 || ( kid->op_type != OP_PADSV
2291 && kid->op_type != OP_PADAV
2292 && kid->op_type != OP_PADHV)
2293 || kid->op_private & ~OPpLVAL_INTRO
e6dae479 2294 || !(kid = OpSIBLING(kid))
26f0e7d5
TC
2295 || ( kid->op_type != OP_PADSV
2296 && kid->op_type != OP_PADAV
2297 && kid->op_type != OP_PADHV)
2298 || kid->op_private & ~OPpLVAL_INTRO)
2299 ) {
2300 op_null(cUNOPo->op_first); /* NULL the pushmark */
2301 op_null(o); /* NULL the list */
2302 }
2303 goto kids;
2304 case OP_ENTEREVAL:
2305 scalarkids(o);
2306 break;
2307 case OP_SCALAR:
2308 scalar(o);
2309 break;
2310 }
2311
2312 if (useless_sv) {
2313 /* mortalise it, in case warnings are fatal. */
2314 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
147e3846 2315 "Useless use of %" SVf " in void context",
26f0e7d5
TC
2316 SVfARG(sv_2mortal(useless_sv)));
2317 }
2318 else if (useless) {
3c3f8cd6
AB
2319 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2320 "Useless use of %s in void context",
2321 useless);
26f0e7d5 2322 }
aa9d1253 2323
2a56a87f
DM
2324 get_next_op:
2325 /* if a kid hasn't been nominated to process, continue with the
2326 * next sibling, or if no siblings left, go back to the parent's
2327 * siblings and so on
2328 */
2329 while (!next_kid) {
2330 if (o == arg)
2331 return arg; /* at top; no parents/siblings to try */
2332 if (OpHAS_SIBLING(o))
2333 next_kid = o->op_sibparent;
2334 else
2335 o = o->op_sibparent; /*try parent's next sibling */
2336 }
2337 o = next_kid;
2338 }
aa9d1253
TC
2339
2340 return arg;
79072805
LW
2341}
2342
2a56a87f 2343
1f676739 2344static OP *
412da003 2345S_listkids(pTHX_ OP *o)
79072805 2346{
11343788 2347 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2348 OP *kid;
e6dae479 2349 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
2350 list(kid);
2351 }
11343788 2352 return o;
79072805
LW
2353}
2354
7cd35865
DM
2355
2356/* apply list context to the o subtree */
2357
79072805 2358OP *
864dbfa3 2359Perl_list(pTHX_ OP *o)
79072805 2360{
8ef9070b
DM
2361 OP * top_op = o;
2362
2363 while (1) {
a58b51cf 2364 OP *next_kid = NULL; /* what op (if any) to process next */
8ef9070b 2365
a58b51cf 2366 OP *kid;
79072805 2367
a58b51cf
DM
2368 /* assumes no premature commitment */
2369 if (!o || (o->op_flags & OPf_WANT)
2370 || (PL_parser && PL_parser->error_count)
2371 || o->op_type == OP_RETURN)
2372 {
2373 goto do_next;
2374 }
1c846c1f 2375
a58b51cf
DM
2376 if ((o->op_private & OPpTARGET_MY)
2377 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2378 {
2379 goto do_next; /* As if inside SASSIGN */
2380 }
79072805 2381
a58b51cf 2382 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
054d8a90 2383
a58b51cf
DM
2384 switch (o->op_type) {
2385 case OP_REPEAT:
2386 if (o->op_private & OPpREPEAT_DOLIST
2387 && !(o->op_flags & OPf_STACKED))
2388 {
2389 list(cBINOPo->op_first);
2390 kid = cBINOPo->op_last;
2391 /* optimise away (.....) x 1 */
2392 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2393 && SvIVX(kSVOP_sv) == 1)
2394 {
2395 op_null(o); /* repeat */
2396 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2397 /* const (rhs): */
2398 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2399 }
2400 }
2401 break;
2a45276d 2402
a58b51cf
DM
2403 case OP_OR:
2404 case OP_AND:
2405 case OP_COND_EXPR:
2406 /* impose list context on everything except the condition */
2407 next_kid = OpSIBLING(cUNOPo->op_first);
2408 break;
054d8a90 2409
a58b51cf
DM
2410 default:
2411 if (!(o->op_flags & OPf_KIDS))
2412 break;
2413 /* possibly flatten 1..10 into a constant array */
2414 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2415 list(cBINOPo->op_first);
2416 gen_constant_list(o);
2417 goto do_next;
2418 }
8ef9070b 2419 next_kid = cUNOPo->op_first; /* do all kids */
a58b51cf 2420 break;
054d8a90 2421
a58b51cf
DM
2422 case OP_LIST:
2423 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2424 op_null(cUNOPo->op_first); /* NULL the pushmark */
2425 op_null(o); /* NULL the list */
2426 }
2427 if (o->op_flags & OPf_KIDS)
2428 next_kid = cUNOPo->op_first; /* do all kids */
2429 break;
054d8a90 2430
a58b51cf 2431 /* the children of these ops are usually a list of statements,
06c2b1fc 2432 * except the leaves, whose first child is a corresponding enter
a58b51cf
DM
2433 */
2434 case OP_SCOPE:
2435 case OP_LINESEQ:
2436 kid = cLISTOPo->op_first;
2437 goto do_kids;
2438 case OP_LEAVE:
2439 case OP_LEAVETRY:
2440 kid = cLISTOPo->op_first;
2441 list(kid);
2442 kid = OpSIBLING(kid);
2443 do_kids:
2444 while (kid) {
2445 OP *sib = OpSIBLING(kid);
9d15d64e
DM
2446 /* Apply void context to all kids except the last, which
2447 * is list. E.g.
2448 * @a = do { void; void; list }
2449 * Except that 'when's are always list context, e.g.
2450 * @a = do { given(..) {
2451 * when (..) { list }
2452 * when (..) { list }
2453 * ...
2454 * }}
2455 */
f23e1643
DM
2456 if (!sib) {
2457 /* tail call optimise calling list() on the last kid */
2458 next_kid = kid;
2459 goto do_next;
2460 }
9d15d64e 2461 else if (kid->op_type == OP_LEAVEWHEN)
a58b51cf 2462 list(kid);
9d15d64e
DM
2463 else
2464 scalarvoid(kid);
a58b51cf
DM
2465 kid = sib;
2466 }
f23e1643 2467 NOT_REACHED; /* NOTREACHED */
a58b51cf 2468 break;
054d8a90 2469
a58b51cf 2470 }
8ef9070b 2471
a58b51cf
DM
2472 /* If next_kid is set, someone in the code above wanted us to process
2473 * that kid and all its remaining siblings. Otherwise, work our way
2474 * back up the tree */
2475 do_next:
2476 while (!next_kid) {
2477 if (o == top_op)
2478 return top_op; /* at top; no parents/siblings to try */
2479 if (OpHAS_SIBLING(o))
2480 next_kid = o->op_sibparent;
f23e1643 2481 else {
a58b51cf 2482 o = o->op_sibparent; /*try parent's next sibling */
f23e1643
DM
2483 switch (o->op_type) {
2484 case OP_SCOPE:
2485 case OP_LINESEQ:
2486 case OP_LIST:
2487 case OP_LEAVE:
2488 case OP_LEAVETRY:
2489 /* should really restore PL_curcop to its old value, but
2490 * setting it to PL_compiling is better than do nothing */
2491 PL_curcop = &PL_compiling;
2492 }
2493 }
2494
a58b51cf
DM
2495
2496 }
2497 o = next_kid;
8ef9070b 2498 } /* while */
79072805
LW
2499}
2500
7cd35865 2501
1f676739 2502static OP *
2dd5337b 2503S_scalarseq(pTHX_ OP *o)
79072805 2504{
11343788 2505 if (o) {
1496a290
AL
2506 const OPCODE type = o->op_type;
2507
2508 if (type == OP_LINESEQ || type == OP_SCOPE ||
2509 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2510 {
b7bea5da
FC
2511 OP *kid, *sib;
2512 for (kid = cLISTOPo->op_first; kid; kid = sib) {
e6dae479
FC
2513 if ((sib = OpSIBLING(kid))
2514 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
b7bea5da
FC
2515 || ( sib->op_targ != OP_NEXTSTATE
2516 && sib->op_targ != OP_DBSTATE )))
2517 {
463ee0b2 2518 scalarvoid(kid);
ed6116ce 2519 }
463ee0b2 2520 }
3280af22 2521 PL_curcop = &PL_compiling;
79072805 2522 }
11343788 2523 o->op_flags &= ~OPf_PARENS;
3280af22 2524 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2525 o->op_flags |= OPf_PARENS;
79072805 2526 }
8990e307 2527 else
11343788
MB
2528 o = newOP(OP_STUB, 0);
2529 return o;
79072805
LW
2530}
2531
76e3520e 2532STATIC OP *
cea2e8a9 2533S_modkids(pTHX_ OP *o, I32 type)
79072805 2534{
11343788 2535 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2536 OP *kid;
e6dae479 2537 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3ad73efd 2538 op_lvalue(kid, type);
79072805 2539 }
11343788 2540 return o;
79072805
LW
2541}
2542
12ee5d32
DM
2543
2544/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2545 * const fields. Also, convert CONST keys to HEK-in-SVs.
02a9632a 2546 * rop is the op that retrieves the hash;
12ee5d32 2547 * key_op is the first key
02a9632a 2548 * real if false, only check (and possibly croak); don't update op
12ee5d32
DM
2549 */
2550
f9db5646 2551STATIC void
02a9632a 2552S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
12ee5d32
DM
2553{
2554 PADNAME *lexname;
2555 GV **fields;
2556 bool check_fields;
2557
2558 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2559 if (rop) {
2560 if (rop->op_first->op_type == OP_PADSV)
2561 /* @$hash{qw(keys here)} */
2562 rop = (UNOP*)rop->op_first;
2563 else {
2564 /* @{$hash}{qw(keys here)} */
2565 if (rop->op_first->op_type == OP_SCOPE
2566 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2567 {
2568 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2569 }
2570 else
2571 rop = NULL;
2572 }
2573 }
2574
2575 lexname = NULL; /* just to silence compiler warnings */
2576 fields = NULL; /* just to silence compiler warnings */
2577
2578 check_fields =
2579 rop
2580 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2581 SvPAD_TYPED(lexname))
2582 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2583 && isGV(*fields) && GvHV(*fields);
2584
e6dae479 2585 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
12ee5d32
DM
2586 SV **svp, *sv;
2587 if (key_op->op_type != OP_CONST)
2588 continue;
2589 svp = cSVOPx_svp(key_op);
2590
e1ccd220
DIM
2591 /* make sure it's not a bareword under strict subs */
2592 if (key_op->op_private & OPpCONST_BARE &&
2593 key_op->op_private & OPpCONST_STRICT)
2594 {
2595 no_bareword_allowed((OP*)key_op);
2596 }
2597
12ee5d32
DM
2598 /* Make the CONST have a shared SV */
2599 if ( !SvIsCOW_shared_hash(sv = *svp)
2600 && SvTYPE(sv) < SVt_PVMG
2601 && SvOK(sv)
02a9632a
DM
2602 && !SvROK(sv)
2603 && real)
12ee5d32
DM
2604 {
2605 SSize_t keylen;
2606 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2607 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2608 SvREFCNT_dec_NN(sv);
2609 *svp = nsv;
2610 }
2611
2612 if ( check_fields
2613 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2614 {
147e3846
KW
2615 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2616 "in variable %" PNf " of type %" HEKf,
12ee5d32
DM
2617 SVfARG(*svp), PNfARG(lexname),
2618 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2619 }
2620 }
2621}
2622
e839e6ed
DM
2623/* info returned by S_sprintf_is_multiconcatable() */
2624
2625struct sprintf_ismc_info {
ca84e88e 2626 SSize_t nargs; /* num of args to sprintf (not including the format) */
e839e6ed
DM
2627 char *start; /* start of raw format string */
2628 char *end; /* bytes after end of raw format string */
2629 STRLEN total_len; /* total length (in bytes) of format string, not
2630 including '%s' and half of '%%' */
2631 STRLEN variant; /* number of bytes by which total_len_p would grow
2632 if upgraded to utf8 */
2633 bool utf8; /* whether the format is utf8 */
2634};
2635
2636
2637/* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2638 * i.e. its format argument is a const string with only '%s' and '%%'
2639 * formats, and the number of args is known, e.g.
2640 * sprintf "a=%s f=%s", $a[0], scalar(f());
2641 * but not
2642 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2643 *
2644 * If successful, the sprintf_ismc_info struct pointed to by info will be
2645 * populated.
2646 */
2647
2648STATIC bool
2649S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2650{
2651 OP *pm, *constop, *kid;
2652 SV *sv;
2653 char *s, *e, *p;
ca84e88e 2654 SSize_t nargs, nformats;
e839e6ed
DM
2655 STRLEN cur, total_len, variant;
2656 bool utf8;
2657
2658 /* if sprintf's behaviour changes, die here so that someone
2659 * can decide whether to enhance this function or skip optimising
2660 * under those new circumstances */
2661 assert(!(o->op_flags & OPf_STACKED));
2662 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2663 assert(!(o->op_private & ~OPpARG4_MASK));
2664
2665 pm = cUNOPo->op_first;
2666 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2667 return FALSE;
2668 constop = OpSIBLING(pm);
2669 if (!constop || constop->op_type != OP_CONST)
2670 return FALSE;
2671 sv = cSVOPx_sv(constop);
2672 if (SvMAGICAL(sv) || !SvPOK(sv))
2673 return FALSE;
2674
2675 s = SvPV(sv, cur);
2676 e = s + cur;
2677
2678 /* Scan format for %% and %s and work out how many %s there are.
2679 * Abandon if other format types are found.
2680 */
2681
2682 nformats = 0;
2683 total_len = 0;
2684 variant = 0;
2685
2686 for (p = s; p < e; p++) {
2687 if (*p != '%') {
2688 total_len++;
b3baa1fe 2689 if (!UTF8_IS_INVARIANT(*p))
e839e6ed
DM
2690 variant++;
2691 continue;
2692 }
2693 p++;
2694 if (p >= e)
2695 return FALSE; /* lone % at end gives "Invalid conversion" */
2696 if (*p == '%')
2697 total_len++;
2698 else if (*p == 's')
2699 nformats++;
2700 else
2701 return FALSE;
2702 }
2703
2704 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2705 return FALSE;
2706
2707 utf8 = cBOOL(SvUTF8(sv));
2708 if (utf8)
2709 variant = 0;
2710
2711 /* scan args; they must all be in scalar cxt */
2712
2713 nargs = 0;
2714 kid = OpSIBLING(constop);
2715
2716 while (kid) {
2717 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2718 return FALSE;
2719 nargs++;
2720 kid = OpSIBLING(kid);
2721 }
2722
2723 if (nargs != nformats)
2724 return FALSE; /* e.g. sprintf("%s%s", $a); */
2725
2726
2727 info->nargs = nargs;
2728 info->start = s;
2729 info->end = e;
2730 info->total_len = total_len;
2731 info->variant = variant;
2732 info->utf8 = utf8;
2733
2734 return TRUE;
2735}
2736
2737
2738
2739/* S_maybe_multiconcat():
2740 *
2741 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2742 * convert it (and its children) into an OP_MULTICONCAT. See the code
2743 * comments just before pp_multiconcat() for the full details of what
2744 * OP_MULTICONCAT supports.
2745 *
2746 * Basically we're looking for an optree with a chain of OP_CONCATS down
2747 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2748 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2749 *
2750 * $x = "$a$b-$c"
2751 *
2752 * looks like
2753 *
2754 * SASSIGN
2755 * |
2756 * STRINGIFY -- PADSV[$x]
2757 * |
2758 * |
2759 * ex-PUSHMARK -- CONCAT/S
2760 * |
2761 * CONCAT/S -- PADSV[$d]
2762 * |
2763 * CONCAT -- CONST["-"]
2764 * |
2765 * PADSV[$a] -- PADSV[$b]
2766 *
2767 * Note that at this stage the OP_SASSIGN may have already been optimised
2768 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2769 */
2770
2771STATIC void
2772S_maybe_multiconcat(pTHX_ OP *o)
2773{
1565c085 2774 dVAR;
e839e6ed
DM
2775 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2776 OP *topop; /* the top-most op in the concat tree (often equals o,
2777 unless there are assign/stringify ops above it */
2778 OP *parentop; /* the parent op of topop (or itself if no parent) */
2779 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2780 OP *targetop; /* the op corresponding to target=... or target.=... */
2781 OP *stringop; /* the OP_STRINGIFY op, if any */
2782 OP *nextop; /* used for recreating the op_next chain without consts */
2783 OP *kid; /* general-purpose op pointer */
2784 UNOP_AUX_item *aux;
2785 UNOP_AUX_item *lenp;
2786 char *const_str, *p;
2787 struct sprintf_ismc_info sprintf_info;
2788
2789 /* store info about each arg in args[];
2790 * toparg is the highest used slot; argp is a general
2791 * pointer to args[] slots */
2792 struct {
2793 void *p; /* initially points to const sv (or null for op);
2794 later, set to SvPV(constsv), with ... */
2795 STRLEN len; /* ... len set to SvPV(..., len) */
2796 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2797
ca84e88e
DM
2798 SSize_t nargs = 0;
2799 SSize_t nconst = 0;
f08f2d03 2800 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
e839e6ed
DM
2801 STRLEN variant;
2802 bool utf8 = FALSE;
2803 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2804 the last-processed arg will the LHS of one,
2805 as args are processed in reverse order */
2806 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2807 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2808 U8 flags = 0; /* what will become the op_flags and ... */
2809 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2810 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2811 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
f08f2d03 2812 bool prev_was_const = FALSE; /* previous arg was a const */
e839e6ed
DM
2813
2814 /* -----------------------------------------------------------------
2815 * Phase 1:
2816 *
2817 * Examine the optree non-destructively to determine whether it's
2818 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2819 * information about the optree in args[].
2820 */
2821
2822 argp = args;
2823 targmyop = NULL;
2824 targetop = NULL;
2825 stringop = NULL;
2826 topop = o;
2827 parentop = o;
2828
2829 assert( o->op_type == OP_SASSIGN
2830 || o->op_type == OP_CONCAT
2831 || o->op_type == OP_SPRINTF
2832 || o->op_type == OP_STRINGIFY);
2833
da431b10
JH
2834 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2835
e839e6ed
DM
2836 /* first see if, at the top of the tree, there is an assign,
2837 * append and/or stringify */
2838
2839 if (topop->op_type == OP_SASSIGN) {
2840 /* expr = ..... */
2841 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2842 return;
2843 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2844 return;
2845 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2846
2847 parentop = topop;
2848 topop = cBINOPo->op_first;
2849 targetop = OpSIBLING(topop);
2850 if (!targetop) /* probably some sort of syntax error */
2851 return;
2852 }
2853 else if ( topop->op_type == OP_CONCAT
2854 && (topop->op_flags & OPf_STACKED)
62c1220c
DM
2855 && (!(topop->op_private & OPpCONCAT_NESTED))
2856 )
e839e6ed
DM
2857 {
2858 /* expr .= ..... */
2859
2860 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2861 * decide what to do about it */
2862 assert(!(o->op_private & OPpTARGET_MY));
2863
2864 /* barf on unknown flags */
2865 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2866 private_flags |= OPpMULTICONCAT_APPEND;
2867 targetop = cBINOPo->op_first;
2868 parentop = topop;
2869 topop = OpSIBLING(targetop);
2870
2871 /* $x .= <FOO> gets optimised to rcatline instead */
2872 if (topop->op_type == OP_READLINE)
2873 return;
2874 }
2875
2876 if (targetop) {
2877 /* Can targetop (the LHS) if it's a padsv, be be optimised
2878 * away and use OPpTARGET_MY instead?
2879 */
2880 if ( (targetop->op_type == OP_PADSV)
2881 && !(targetop->op_private & OPpDEREF)
2882 && !(targetop->op_private & OPpPAD_STATE)
2883 /* we don't support 'my $x .= ...' */
2884 && ( o->op_type == OP_SASSIGN
2885 || !(targetop->op_private & OPpLVAL_INTRO))
2886 )
2887 is_targable = TRUE;
2888 }
2889
2890 if (topop->op_type == OP_STRINGIFY) {
2891 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2892 return;
2893 stringop = topop;
2894
2895 /* barf on unknown flags */
2896 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2897
2898 if ((topop->op_private & OPpTARGET_MY)) {
2899 if (o->op_type == OP_SASSIGN)
2900 return; /* can't have two assigns */
2901 targmyop = topop;
2902 }
2903
2904 private_flags |= OPpMULTICONCAT_STRINGIFY;
2905 parentop = topop;
2906 topop = cBINOPx(topop)->op_first;
2907 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2908 topop = OpSIBLING(topop);
2909 }
2910
2911 if (topop->op_type == OP_SPRINTF) {
2912 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2913 return;
2914 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2915 nargs = sprintf_info.nargs;
2916 total_len = sprintf_info.total_len;
2917 variant = sprintf_info.variant;
2918 utf8 = sprintf_info.utf8;
2919 is_sprintf = TRUE;
2920 private_flags |= OPpMULTICONCAT_FAKE;
2921 toparg = argp;
2922 /* we have an sprintf op rather than a concat optree.
2923 * Skip most of the code below which is associated with
2924 * processing that optree. We also skip phase 2, determining
2925 * whether its cost effective to optimise, since for sprintf,
2926 * multiconcat is *always* faster */
2927 goto create_aux;
2928 }
2929 /* note that even if the sprintf itself isn't multiconcatable,
2930 * the expression as a whole may be, e.g. in
2931 * $x .= sprintf("%d",...)
2932 * the sprintf op will be left as-is, but the concat/S op may
2933 * be upgraded to multiconcat
2934 */
2935 }
2936 else if (topop->op_type == OP_CONCAT) {
2937 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2938 return;
2939
2940 if ((topop->op_private & OPpTARGET_MY)) {
2941 if (o->op_type == OP_SASSIGN || targmyop)
2942 return; /* can't have two assigns */
2943 targmyop = topop;
2944 }
2945 }
2946
2947 /* Is it safe to convert a sassign/stringify/concat op into
2948 * a multiconcat? */
2949 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2950 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2951 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2952 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2953 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2954 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2955 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2956 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2957
2958 /* Now scan the down the tree looking for a series of
2959 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2960 * stacked). For example this tree:
2961 *
2962 * |
2963 * CONCAT/STACKED
2964 * |
2965 * CONCAT/STACKED -- EXPR5
2966 * |
2967 * CONCAT/STACKED -- EXPR4
2968 * |
2969 * CONCAT -- EXPR3
2970 * |
2971 * EXPR1 -- EXPR2
2972 *
2973 * corresponds to an expression like
2974 *
2975 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2976 *
2977 * Record info about each EXPR in args[]: in particular, whether it is
2978 * a stringifiable OP_CONST and if so what the const sv is.
2979 *
2980 * The reason why the last concat can't be STACKED is the difference
2981 * between
2982 *
2983 * ((($a .= $a) .= $a) .= $a) .= $a
2984 *
2985 * and
2986 * $a . $a . $a . $a . $a
2987 *
2988 * The main difference between the optrees for those two constructs
2989 * is the presence of the last STACKED. As well as modifying $a,
2990 * the former sees the changed $a between each concat, so if $s is
2991 * initially 'a', the first returns 'a' x 16, while the latter returns
2992 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2993 */
2994
2995 kid = topop;
2996
2997 for (;;) {
2998 OP *argop;
2999 SV *sv;
3000 bool last = FALSE;
3001
3002 if ( kid->op_type == OP_CONCAT
3003 && !kid_is_last
3004 ) {
3005 OP *k1, *k2;
3006 k1 = cUNOPx(kid)->op_first;
3007 k2 = OpSIBLING(k1);
3008 /* shouldn't happen except maybe after compile err? */
3009 if (!k2)
3010 return;
3011
3012 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3013 if (kid->op_private & OPpTARGET_MY)
3014 kid_is_last = TRUE;
3015
3016 stacked_last = (kid->op_flags & OPf_STACKED);
3017 if (!stacked_last)
3018 kid_is_last = TRUE;
3019
3020 kid = k1;
3021 argop = k2;
3022 }
3023 else {
3024 argop = kid;
3025 last = TRUE;
3026 }
3027
f08f2d03 3028 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
e839e6ed
DM
3029 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3030 {
3031 /* At least two spare slots are needed to decompose both
3032 * concat args. If there are no slots left, continue to
3033 * examine the rest of the optree, but don't push new values
3034 * on args[]. If the optree as a whole is legal for conversion
3035 * (in particular that the last concat isn't STACKED), then
3036 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3037 * can be converted into an OP_MULTICONCAT now, with the first
3038 * child of that op being the remainder of the optree -
3039 * which may itself later be converted to a multiconcat op
3040 * too.
3041 */
3042 if (last) {
3043 /* the last arg is the rest of the optree */
3044 argp++->p = NULL;
3045 nargs++;
3046 }
3047 }
3048 else if ( argop->op_type == OP_CONST
3049 && ((sv = cSVOPx_sv(argop)))
3050 /* defer stringification until runtime of 'constant'
3051 * things that might stringify variantly, e.g. the radix
3052 * point of NVs, or overloaded RVs */
3053 && (SvPOK(sv) || SvIOK(sv))
3054 && (!SvGMAGICAL(sv))
3055 ) {
3056 argp++->p = sv;
3057 utf8 |= cBOOL(SvUTF8(sv));
3058 nconst++;
f08f2d03
DM
3059 if (prev_was_const)
3060 /* this const may be demoted back to a plain arg later;
3061 * make sure we have enough arg slots left */
3062 nadjconst++;
3063 prev_was_const = !prev_was_const;
e839e6ed
DM
3064 }
3065 else {
3066 argp++->p = NULL;
3067 nargs++;
f08f2d03 3068 prev_was_const = FALSE;
e839e6ed
DM
3069 }
3070
3071 if (last)
3072 break;
3073 }
3074
3075 toparg = argp - 1;
3076
3077 if (stacked_last)
3078 return; /* we don't support ((A.=B).=C)...) */
3079
bcc30fd0
DM
3080 /* look for two adjacent consts and don't fold them together:
3081 * $o . "a" . "b"
3082 * should do
3083 * $o->concat("a")->concat("b")
3084 * rather than
3085 * $o->concat("ab")
3086 * (but $o .= "a" . "b" should still fold)
3087 */
3088 {
3089 bool seen_nonconst = FALSE;
3090 for (argp = toparg; argp >= args; argp--) {
3091 if (argp->p == NULL) {
3092 seen_nonconst = TRUE;
3093 continue;
3094 }
3095 if (!seen_nonconst)
3096 continue;
3097 if (argp[1].p) {
3098 /* both previous and current arg were constants;
3099 * leave the current OP_CONST as-is */
3100 argp->p = NULL;
3101 nconst--;
3102 nargs++;
3103 }
3104 }
3105 }
3106
e839e6ed
DM
3107 /* -----------------------------------------------------------------
3108 * Phase 2:
3109 *
3110 * At this point we have determined that the optree *can* be converted
3111 * into a multiconcat. Having gathered all the evidence, we now decide
3112 * whether it *should*.
3113 */
3114
3115
3116 /* we need at least one concat action, e.g.:
3117 *
3118 * Y . Z
3119 * X = Y . Z
3120 * X .= Y
3121 *
3122 * otherwise we could be doing something like $x = "foo", which
3123 * if treated as as a concat, would fail to COW.
3124 */
3125 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3126 return;
3127
3128 /* Benchmarking seems to indicate that we gain if:
3129 * * we optimise at least two actions into a single multiconcat
3130 * (e.g concat+concat, sassign+concat);
3131 * * or if we can eliminate at least 1 OP_CONST;
3132 * * or if we can eliminate a padsv via OPpTARGET_MY
3133 */
3134
3135 if (
3136 /* eliminated at least one OP_CONST */
3137 nconst >= 1
3138 /* eliminated an OP_SASSIGN */
3139 || o->op_type == OP_SASSIGN
3140 /* eliminated an OP_PADSV */
3141 || (!targmyop && is_targable)
3142 )
3143 /* definitely a net gain to optimise */
3144 goto optimise;
3145
3146 /* ... if not, what else? */
3147
3148 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3149 * multiconcat is faster (due to not creating a temporary copy of
3150 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3151 * faster.
3152 */
3153 if ( nconst == 0
3154 && nargs == 2
3155 && targmyop
3156 && topop->op_type == OP_CONCAT
3157 ) {
3158 PADOFFSET t = targmyop->op_targ;
3159 OP *k1 = cBINOPx(topop)->op_first;
3160 OP *k2 = cBINOPx(topop)->op_last;
3161 if ( k2->op_type == OP_PADSV
3162 && k2->op_targ == t
3163 && ( k1->op_type != OP_PADSV
3164 || k1->op_targ != t)
3165 )
3166 goto optimise;
3167 }
3168
3169 /* need at least two concats */
3170 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3171 return;
3172
3173
3174
3175 /* -----------------------------------------------------------------
3176 * Phase 3:
3177 *
3178 * At this point the optree has been verified as ok to be optimised
3179 * into an OP_MULTICONCAT. Now start changing things.
3180 */
3181
3182 optimise:
3183
3184 /* stringify all const args and determine utf8ness */
3185
3186 variant = 0;
3187 for (argp = args; argp <= toparg; argp++) {
3188 SV *sv = (SV*)argp->p;
3189 if (!sv)
3190 continue; /* not a const op */
3191 if (utf8 && !SvUTF8(sv))
3192 sv_utf8_upgrade_nomg(sv);
3193 argp->p = SvPV_nomg(sv, argp->len);
3194 total_len += argp->len;
3195
3196 /* see if any strings would grow if converted to utf8 */
3197 if (!utf8) {
c1a88fe2
KW
3198 variant += variant_under_utf8_count((U8 *) argp->p,
3199 (U8 *) argp->p + argp->len);
e839e6ed
DM
3200 }
3201 }
3202
3203 /* create and populate aux struct */
3204
3205 create_aux:
3206
3207 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3208 sizeof(UNOP_AUX_item)
3209 * (
3210 PERL_MULTICONCAT_HEADER_SIZE
3211 + ((nargs + 1) * (variant ? 2 : 1))
3212 )
3213 );
6623aa6a 3214 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
e839e6ed
DM
3215
3216 /* Extract all the non-const expressions from the concat tree then
3217 * dispose of the old tree, e.g. convert the tree from this:
3218 *
3219 * o => SASSIGN
3220 * |
3221 * STRINGIFY -- TARGET
3222 * |
3223 * ex-PUSHMARK -- CONCAT
3224 * |
3225 * CONCAT -- EXPR5
3226 * |
3227 * CONCAT -- EXPR4
3228 * |
3229 * CONCAT -- EXPR3
3230 * |
3231 * EXPR1 -- EXPR2
3232 *
3233 *
3234 * to:
3235 *
3236 * o => MULTICONCAT
3237 * |
3238 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3239 *
3240 * except that if EXPRi is an OP_CONST, it's discarded.
3241 *
3242 * During the conversion process, EXPR ops are stripped from the tree
3243 * and unshifted onto o. Finally, any of o's remaining original
3244 * childen are discarded and o is converted into an OP_MULTICONCAT.
3245 *
3246 * In this middle of this, o may contain both: unshifted args on the
3247 * left, and some remaining original args on the right. lastkidop
3248 * is set to point to the right-most unshifted arg to delineate
3249 * between the two sets.
3250 */
3251
3252
3253 if (is_sprintf) {
3254 /* create a copy of the format with the %'s removed, and record
3255 * the sizes of the const string segments in the aux struct */
3256 char *q, *oldq;
3257 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3258
3259 p = sprintf_info.start;
3260 q = const_str;
3261 oldq = q;
3262 for (; p < sprintf_info.end; p++) {
3263 if (*p == '%') {
3264 p++;
3265 if (*p != '%') {
b5bf9f73 3266 (lenp++)->ssize = q - oldq;
e839e6ed
DM
3267 oldq = q;
3268 continue;
3269 }
3270 }
3271 *q++ = *p;
3272 }
b5bf9f73 3273 lenp->ssize = q - oldq;
e839e6ed
DM
3274 assert((STRLEN)(q - const_str) == total_len);
3275
3276 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3277 * may or may not be topop) The pushmark and const ops need to be
3278 * kept in case they're an op_next entry point.
3279 */
3280 lastkidop = cLISTOPx(topop)->op_last;
3281 kid = cUNOPx(topop)->op_first; /* pushmark */
3282 op_null(kid);
3283 op_null(OpSIBLING(kid)); /* const */
3284 if (o != topop) {
3285 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3286 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3287 lastkidop->op_next = o;
3288 }
3289 }
3290 else {
3291 p = const_str;
3292 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3293
b5bf9f73 3294 lenp->ssize = -1;
e839e6ed
DM
3295
3296 /* Concatenate all const strings into const_str.
3297 * Note that args[] contains the RHS args in reverse order, so
3298 * we scan args[] from top to bottom to get constant strings
3299 * in L-R order
3300 */
3301 for (argp = toparg; argp >= args; argp--) {
3302 if (!argp->p)
3303 /* not a const op */
b5bf9f73 3304 (++lenp)->ssize = -1;
e839e6ed
DM
3305 else {
3306 STRLEN l = argp->len;
3307 Copy(argp->p, p, l, char);
3308 p += l;
b5bf9f73
DM
3309 if (lenp->ssize == -1)
3310 lenp->ssize = l;
e839e6ed 3311 else
b5bf9f73 3312 lenp->ssize += l;
e839e6ed
DM
3313 }
3314 }
3315
3316 kid = topop;
3317 nextop = o;
3318 lastkidop = NULL;
3319
3320 for (argp = args; argp <= toparg; argp++) {
3321 /* only keep non-const args, except keep the first-in-next-chain
3322 * arg no matter what it is (but nulled if OP_CONST), because it
3323 * may be the entry point to this subtree from the previous
3324 * op_next.
3325 */
3326 bool last = (argp == toparg);
3327 OP *prev;
3328
3329 /* set prev to the sibling *before* the arg to be cut out,
789a38b6 3330 * e.g. when cutting EXPR:
e839e6ed
DM
3331 *
3332 * |
789a38b6 3333 * kid= CONCAT
e839e6ed 3334 * |
789a38b6 3335 * prev= CONCAT -- EXPR
e839e6ed
DM
3336 * |
3337 */
3338 if (argp == args && kid->op_type != OP_CONCAT) {
789a38b6 3339 /* in e.g. '$x .= f(1)' there's no RHS concat tree
e839e6ed
DM
3340 * so the expression to be cut isn't kid->op_last but
3341 * kid itself */
3342 OP *o1, *o2;
3343 /* find the op before kid */
3344 o1 = NULL;
3345 o2 = cUNOPx(parentop)->op_first;
3346 while (o2 && o2 != kid) {
3347 o1 = o2;
3348 o2 = OpSIBLING(o2);
3349 }
3350 assert(o2 == kid);
3351 prev = o1;
3352 kid = parentop;
3353 }
3354 else if (kid == o && lastkidop)
3355 prev = last ? lastkidop : OpSIBLING(lastkidop);
3356 else
3357 prev = last ? NULL : cUNOPx(kid)->op_first;
3358
3359 if (!argp->p || last) {
3360 /* cut RH op */
3361 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3362 /* and unshift to front of o */
3363 op_sibling_splice(o, NULL, 0, aop);
3364 /* record the right-most op added to o: later we will
3365 * free anything to the right of it */
3366 if (!lastkidop)
3367 lastkidop = aop;
3368 aop->op_next = nextop;
3369 if (last) {
3370 if (argp->p)
3371 /* null the const at start of op_next chain */
3372 op_null(aop);
3373 }
3374 else if (prev)
3375 nextop = prev->op_next;
3376 }
3377
3378 /* the last two arguments are both attached to the same concat op */
3379 if (argp < toparg - 1)
3380 kid = prev;
3381 }
3382 }
3383
3384 /* Populate the aux struct */
3385
ca84e88e 3386 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
e839e6ed 3387 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
b5bf9f73 3388 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
e839e6ed 3389 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
b5bf9f73 3390 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
e839e6ed
DM
3391
3392 /* if variant > 0, calculate a variant const string and lengths where
3393 * the utf8 version of the string will take 'variant' more bytes than
3394 * the plain one. */
3395
3396 if (variant) {
3397 char *p = const_str;
3398 STRLEN ulen = total_len + variant;
3399 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3400 UNOP_AUX_item *ulens = lens + (nargs + 1);
3401 char *up = (char*)PerlMemShared_malloc(ulen);
ca84e88e 3402 SSize_t n;
e839e6ed
DM
3403
3404 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
b5bf9f73 3405 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
e839e6ed
DM
3406
3407 for (n = 0; n < (nargs + 1); n++) {
576915da
DM
3408 SSize_t i;
3409 char * orig_up = up;
b5bf9f73 3410 for (i = (lens++)->ssize; i > 0; i--) {
e839e6ed 3411 U8 c = *p++;
576915da 3412 append_utf8_from_native_byte(c, (U8**)&up);
e839e6ed 3413 }
b5bf9f73 3414 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
e839e6ed
DM
3415 }
3416 }
3417
3418 if (stringop) {
3419 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3420 * that op's first child - an ex-PUSHMARK - because the op_next of
3421 * the previous op may point to it (i.e. it's the entry point for
3422 * the o optree)
3423 */
3424 OP *pmop =
3425 (stringop == o)
3426 ? op_sibling_splice(o, lastkidop, 1, NULL)
3427 : op_sibling_splice(stringop, NULL, 1, NULL);
3428 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3429 op_sibling_splice(o, NULL, 0, pmop);
3430 if (!lastkidop)
3431 lastkidop = pmop;
3432 }
3433
3434 /* Optimise
3435 * target = A.B.C...
3436 * target .= A.B.C...
3437 */
3438
3439 if (targetop) {
3440 assert(!targmyop);
3441
3442 if (o->op_type == OP_SASSIGN) {
3443 /* Move the target subtree from being the last of o's children
3444 * to being the last of o's preserved children.
3445 * Note the difference between 'target = ...' and 'target .= ...':
3446 * for the former, target is executed last; for the latter,
3447 * first.
3448 */
3449 kid = OpSIBLING(lastkidop);
3450 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3451 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3452 lastkidop->op_next = kid->op_next;
3453 lastkidop = targetop;
3454 }
3455 else {
3456 /* Move the target subtree from being the first of o's
3457 * original children to being the first of *all* o's children.
3458 */
3459 if (lastkidop) {
3460 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3461 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3462 }
3463 else {
3464 /* if the RHS of .= doesn't contain a concat (e.g.
3465 * $x .= "foo"), it gets missed by the "strip ops from the
3466 * tree and add to o" loop earlier */
3467 assert(topop->op_type != OP_CONCAT);
3468 if (stringop) {
3469 /* in e.g. $x .= "$y", move the $y expression
3470 * from being a child of OP_STRINGIFY to being the
3471 * second child of the OP_CONCAT
3472 */
3473 assert(cUNOPx(stringop)->op_first == topop);
3474 op_sibling_splice(stringop, NULL, 1, NULL);
3475 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3476 }
3477 assert(topop == OpSIBLING(cBINOPo->op_first));
3478 if (toparg->p)
3479 op_null(topop);
3480 lastkidop = topop;
3481 }
3482 }
3483
3484 if (is_targable) {
3485 /* optimise
3486 * my $lex = A.B.C...
3487 * $lex = A.B.C...
3488 * $lex .= A.B.C...
3489 * The original padsv op is kept but nulled in case it's the
3490 * entry point for the optree (which it will be for
3491 * '$lex .= ... '
3492 */
3493 private_flags |= OPpTARGET_MY;
3494 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3495 o->op_targ = targetop->op_targ;
3496 targetop->op_targ = 0;
3497 op_null(targetop);
3498 }
3499 else
3500 flags |= OPf_STACKED;
3501 }
3502 else if (targmyop) {
3503 private_flags |= OPpTARGET_MY;
3504 if (o != targmyop) {
3505 o->op_targ = targmyop->op_targ;
3506 targmyop->op_targ = 0;
3507 }
3508 }
3509
3510 /* detach the emaciated husk of the sprintf/concat optree and free it */
3511 for (;;) {
3512 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3513 if (!kid)
3514 break;
3515 op_free(kid);
3516 }
3517
3518 /* and convert o into a multiconcat */
3519
3520 o->op_flags = (flags|OPf_KIDS|stacked_last
3521 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3522 o->op_private = private_flags;
3523 o->op_type = OP_MULTICONCAT;
3524 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3525 cUNOP_AUXo->op_aux = aux;
3526}
3527
12ee5d32 3528
01f9673f
DM
3529/* do all the final processing on an optree (e.g. running the peephole
3530 * optimiser on it), then attach it to cv (if cv is non-null)
3531 */
3532
3533static void
3534S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3535{
3536 OP **startp;
3537
3538 /* XXX for some reason, evals, require and main optrees are
3539 * never attached to their CV; instead they just hang off
3540 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3541 * and get manually freed when appropriate */
3542 if (cv)
3543 startp = &CvSTART(cv);
3544 else
3545 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3546
3547 *startp = start;
3548 optree->op_private |= OPpREFCOUNTED;
3549 OpREFCNT_set(optree, 1);
d2905138 3550 optimize_optree(optree);
01f9673f
DM
3551 CALL_PEEP(*startp);
3552 finalize_optree(optree);
3553 S_prune_chain_head(startp);
3554
3555 if (cv) {
3556 /* now that optimizer has done its work, adjust pad values */
3557 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3558 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3559 }
3560}
3561
3562
3ad73efd 3563/*
d2905138
DM
3564=for apidoc optimize_optree
3565
3566This function applies some optimisations to the optree in top-down order.
3567It is called before the peephole optimizer, which processes ops in
3568execution order. Note that finalize_optree() also does a top-down scan,
3569but is called *after* the peephole optimizer.
3570
3571=cut
3572*/
3573
3574void
3575Perl_optimize_optree(pTHX_ OP* o)
3576{
3577 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3578
3579 ENTER;
3580 SAVEVPTR(PL_curcop);
3581
3582 optimize_op(o);
3583
3584 LEAVE;
3585}
3586
3587
6eebe43d 3588/* helper for optimize_optree() which optimises one op then recurses
d2905138
DM
3589 * to optimise any children.
3590 */
3591
3592STATIC void
3593S_optimize_op(pTHX_ OP* o)
3594{
6eebe43d 3595 OP *top_op = o;
d2905138
DM
3596
3597 PERL_ARGS_ASSERT_OPTIMIZE_OP;
6eebe43d
DM
3598
3599 while (1) {
3600 OP * next_kid = NULL;
3601
f2861c9b 3602 assert(o->op_type != OP_FREED);
d2905138 3603
f2861c9b
TC
3604 switch (o->op_type) {
3605 case OP_NEXTSTATE:
3606 case OP_DBSTATE:
3607 PL_curcop = ((COP*)o); /* for warnings */
3608 break;
d2905138
DM
3609
3610
f2861c9b
TC
3611 case OP_CONCAT:
3612 case OP_SASSIGN:
3613 case OP_STRINGIFY:
3614 case OP_SPRINTF:
3615 S_maybe_multiconcat(aTHX_ o);
3616 break;
e839e6ed 3617
f2861c9b 3618 case OP_SUBST:
6eebe43d
DM
3619 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3620 /* we can't assume that op_pmreplroot->op_sibparent == o
3621 * and that it is thus possible to walk back up the tree
3622 * past op_pmreplroot. So, although we try to avoid
3623 * recursing through op trees, do it here. After all,
3624 * there are unlikely to be many nested s///e's within
3625 * the replacement part of a s///e.
3626 */
3627 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3628 }
f2861c9b 3629 break;
d2905138 3630
f2861c9b
TC
3631 default:
3632 break;
3633 }
d2905138 3634
6eebe43d
DM
3635 if (o->op_flags & OPf_KIDS)
3636 next_kid = cUNOPo->op_first;
3637
3638 /* if a kid hasn't been nominated to process, continue with the
3639 * next sibling, or if no siblings left, go back to the parent's
3640 * siblings and so on
3641 */
3642 while (!next_kid) {
3643 if (o == top_op)
3644 return; /* at top; no parents/siblings to try */
3645 if (OpHAS_SIBLING(o))
3646 next_kid = o->op_sibparent;
3647 else
3648 o = o->op_sibparent; /*try parent's next sibling */
f2861c9b 3649 }
d2905138 3650
6eebe43d
DM
3651 /* this label not yet used. Goto here if any code above sets
3652 * next-kid
3653 get_next_op:
3654 */
3655 o = next_kid;
3656 }
d2905138
DM
3657}
3658
3659
3660/*
d164302a
GG
3661=for apidoc finalize_optree
3662
72d33970
FC
3663This function finalizes the optree. Should be called directly after
3664the complete optree is built. It does some additional
796b6530 3665checking which can't be done in the normal C<ck_>xxx functions and makes
d164302a
GG
3666the tree thread-safe.
3667
3668=cut
3669*/
3670void
3671Perl_finalize_optree(pTHX_ OP* o)
3672{
3673 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3674
3675 ENTER;
3676 SAVEVPTR(PL_curcop);
3677
3678 finalize_op(o);
3679
3680 LEAVE;
3681}
3682
b46e009d 3683#ifdef USE_ITHREADS
3684/* Relocate sv to the pad for thread safety.
3685 * Despite being a "constant", the SV is written to,
3686 * for reference counts, sv_upgrade() etc. */
3687PERL_STATIC_INLINE void
3688S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3689{
3690 PADOFFSET ix;
3691 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3692 if (!*svp) return;
3693 ix = pad_alloc(OP_CONST, SVf_READONLY);
3694 SvREFCNT_dec(PAD_SVl(ix));
3695 PAD_SETSV(ix, *svp);
3696 /* XXX I don't know how this isn't readonly already. */
3697 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3698 *svp = NULL;
3699 *targp = ix;
3700}
3701#endif
3702
7f8280cf 3703/*
44170c9a 3704=for apidoc traverse_op_tree
7f8280cf
TC
3705
3706Return the next op in a depth-first traversal of the op tree,
3707returning NULL when the traversal is complete.
3708
3709The initial call must supply the root of the tree as both top and o.
3710
3711For now it's static, but it may be exposed to the API in the future.
3712
3713=cut
3714*/
3715
3716STATIC OP*
35c1827f 3717S_traverse_op_tree(pTHX_ OP *top, OP *o) {
7f8280cf
TC
3718 OP *sib;
3719
3720 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3721
3722 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3723 return cUNOPo->op_first;
3724 }
3725 else if ((sib = OpSIBLING(o))) {
3726 return sib;
3727 }
3728 else {
3729 OP *parent = o->op_sibparent;
3730 assert(!(o->op_moresib));
3731 while (parent && parent != top) {
3732 OP *sib = OpSIBLING(parent);
3733 if (sib)
3734 return sib;
3735 parent = parent->op_sibparent;
3736 }
3737
3738 return NULL;
3739 }
3740}
b46e009d 3741
60dde6b2 3742STATIC void
d164302a
GG
3743S_finalize_op(pTHX_ OP* o)
3744{
7f8280cf 3745 OP * const top = o;
d164302a
GG
3746 PERL_ARGS_ASSERT_FINALIZE_OP;
3747
7f8280cf 3748 do {
64242fed 3749 assert(o->op_type != OP_FREED);
d164302a 3750
64242fed
TC
3751 switch (o->op_type) {
3752 case OP_NEXTSTATE:
3753 case OP_DBSTATE:
3754 PL_curcop = ((COP*)o); /* for warnings */
3755 break;
3756 case OP_EXEC:
3757 if (OpHAS_SIBLING(o)) {
3758 OP *sib = OpSIBLING(o);
3759 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3760 && ckWARN(WARN_EXEC)
3761 && OpHAS_SIBLING(sib))
3762 {
e6dae479 3763 const OPCODE type = OpSIBLING(sib)->op_type;
d164302a
GG
3764 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3765 const line_t oldline = CopLINE(PL_curcop);
1ed44841 3766 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
3767 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3768 "Statement unlikely to be reached");
3769 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3770 "\t(Maybe you meant system() when you said exec()?)\n");
3771 CopLINE_set(PL_curcop, oldline);
3772 }
64242fed
TC
3773 }
3774 }
3775 break;
d164302a 3776
64242fed
TC
3777 case OP_GV:
3778 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3779 GV * const gv = cGVOPo_gv;
3780 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3781 /* XXX could check prototype here instead of just carping */
3782 SV * const sv = sv_newmortal();
3783 gv_efullname3(sv, gv, NULL);
3784 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3785 "%" SVf "() called too early to check prototype",
3786 SVfARG(sv));
3787 }
3788 }
3789 break;
d164302a 3790
64242fed
TC
3791 case OP_CONST:
3792 if (cSVOPo->op_private & OPpCONST_STRICT)
3793 no_bareword_allowed(o);
d164302a 3794#ifdef USE_ITHREADS
64242fed
TC
3795 /* FALLTHROUGH */
3796 case OP_HINTSEVAL:
3797 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
b46e009d 3798#endif
64242fed 3799 break;
b46e009d 3800
3801#ifdef USE_ITHREADS
64242fed
TC
3802 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3803 case OP_METHOD_NAMED:
3804 case OP_METHOD_SUPER:
3805 case OP_METHOD_REDIR:
3806 case OP_METHOD_REDIR_SUPER:
3807 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3808 break;
d164302a 3809#endif
d164302a 3810
64242fed
TC
3811 case OP_HELEM: {
3812 UNOP *rop;
3813 SVOP *key_op;
3814 OP *kid;
d164302a 3815
64242fed
TC
3816 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3817 break;
d164302a 3818
64242fed 3819 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 3820
64242fed 3821 goto check_keys;
d164302a 3822
64242fed
TC
3823 case OP_HSLICE:
3824 S_scalar_slice_warning(aTHX_ o);
3825 /* FALLTHROUGH */
429a2555 3826
64242fed
TC
3827 case OP_KVHSLICE:
3828 kid = OpSIBLING(cLISTOPo->op_first);
3829 if (/* I bet there's always a pushmark... */
3830 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3831 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3832 {
3833 break;
3834 }
565e6f7e 3835
64242fed
TC
3836 key_op = (SVOP*)(kid->op_type == OP_CONST
3837 ? kid
3838 : OpSIBLING(kLISTOP->op_first));
565e6f7e 3839
64242fed 3840 rop = (UNOP*)((LISTOP*)o)->op_last;
565e6f7e 3841
64242fed
TC
3842 check_keys:
3843 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3844 rop = NULL;
02a9632a 3845 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
64242fed
TC
3846 break;
3847 }
3848 case OP_NULL:
3849 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3850 break;
3851 /* FALLTHROUGH */
3852 case OP_ASLICE:
3853 S_scalar_slice_warning(aTHX_ o);
3854 break;
a7fd8ef6 3855
64242fed
TC
3856 case OP_SUBST: {
3857 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3858 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3859 break;
3860 }
3861 default:
3862 break;
3863 }
d164302a 3864
7f8280cf 3865#ifdef DEBUGGING
64242fed
TC
3866 if (o->op_flags & OPf_KIDS) {
3867 OP *kid;
3868
3869 /* check that op_last points to the last sibling, and that
3870 * the last op_sibling/op_sibparent field points back to the
3871 * parent, and that the only ops with KIDS are those which are
3872 * entitled to them */
3873 U32 type = o->op_type;
3874 U32 family;
3875 bool has_last;
3876
3877 if (type == OP_NULL) {
3878 type = o->op_targ;
3879 /* ck_glob creates a null UNOP with ex-type GLOB
3880 * (which is a list op. So pretend it wasn't a listop */
3881 if (type == OP_GLOB)
3882 type = OP_NULL;
3883 }
3884 family = PL_opargs[type] & OA_CLASS_MASK;
3885
3886 has_last = ( family == OA_BINOP
3887 || family == OA_LISTOP
3888 || family == OA_PMOP
3889 || family == OA_LOOP
3890 );
3891 assert( has_last /* has op_first and op_last, or ...
3892 ... has (or may have) op_first: */
3893 || family == OA_UNOP
3894 || family == OA_UNOP_AUX
3895 || family == OA_LOGOP
3896 || family == OA_BASEOP_OR_UNOP
3897 || family == OA_FILESTATOP
3898 || family == OA_LOOPEXOP
3899 || family == OA_METHOP
3900 || type == OP_CUSTOM
3901 || type == OP_NULL /* new_logop does this */
3902 );
3903
3904 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3905 if (!OpHAS_SIBLING(kid)) {
3906 if (has_last)
3907 assert(kid == cLISTOPo->op_last);
3908 assert(kid->op_sibparent == o);
3909 }
20220689 3910 }
c4b20975 3911 }
7f8280cf
TC
3912#endif
3913 } while (( o = traverse_op_tree(top, o)) != NULL);
d164302a
GG
3914}
3915
3916/*
44170c9a 3917=for apidoc op_lvalue
3ad73efd
Z
3918
3919Propagate lvalue ("modifiable") context to an op and its children.
2d7f6611 3920C<type> represents the context type, roughly based on the type of op that
796b6530 3921would do the modifying, although C<local()> is represented by C<OP_NULL>,
3ad73efd 3922because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
3923the lvalue op).
3924
3925This function detects things that can't be modified, such as C<$x+1>, and
72d33970 3926generates errors for them. For example, C<$x+1 = 2> would cause it to be
796b6530 3927called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
001c3c51
FC
3928
3929It also flags things that need to behave specially in an lvalue context,
3930such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
3931
3932=cut
3933*/
ddeae0f1 3934
03414f05
FC
3935static void
3936S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3937{
3938 CV *cv = PL_compcv;
3939 PadnameLVALUE_on(pn);
3940 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3941 cv = CvOUTSIDE(cv);
aea0412a
DM
3942 /* RT #127786: cv can be NULL due to an eval within the DB package
3943 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3944 * unless they contain an eval, but calling eval within DB
3945 * pretends the eval was done in the caller's scope.
3946 */
3947 if (!cv)
3948 break;
03414f05
FC
3949 assert(CvPADLIST(cv));
3950 pn =
3951 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3952 assert(PadnameLEN(pn));
3953 PadnameLVALUE_on(pn);
3954 }
3955}
3956
375879aa
FC
3957static bool
3958S_vivifies(const OPCODE type)
3959{
3960 switch(type) {
3961 case OP_RV2AV: case OP_ASLICE:
3962 case OP_RV2HV: case OP_KVASLICE:
3963 case OP_RV2SV: case OP_HSLICE:
3964 case OP_AELEMFAST: case OP_KVHSLICE:
3965 case OP_HELEM:
3966 case OP_AELEM:
3967 return 1;
3968 }
3969 return 0;
3970}
3971
7664512e 3972static void
63702de8 3973S_lvref(pTHX_ OP *o, I32 type)
7664512e 3974{
727d2dc6 3975 dVAR;
766