This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_op_lvalue_flags(): skip OPf_WANT_VOID ops.
[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
f0d08550 1278
bfd0ff22
NC
1279STATIC void
1280S_find_and_forget_pmops(pTHX_ OP *o)
1281{
f0d08550
DM
1282 OP* top_op = o;
1283
7918f24d
NC
1284 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1285
f0d08550
DM
1286 while (1) {
1287 switch (o->op_type) {
1288 case OP_SUBST:
1289 case OP_SPLIT:
1290 case OP_MATCH:
1291 case OP_QR:
1292 forget_pmop((PMOP*)o);
1293 }
1294
1295 if (o->op_flags & OPf_KIDS) {
1296 o = cUNOPo->op_first;
1297 continue;
1298 }
1299
1300 while (1) {
1301 if (o == top_op)
1302 return; /* at top; no parents/siblings to try */
1303 if (OpHAS_SIBLING(o)) {
1304 o = o->op_sibparent; /* process next sibling */
1305 break;
1306 }
1307 o = o->op_sibparent; /*try parent's next sibling */
1308 }
bfd0ff22
NC
1309 }
1310}
1311
f0d08550 1312
6e53b6ca 1313/*
44170c9a 1314=for apidoc op_null
6e53b6ca
DD
1315
1316Neutralizes an op when it is no longer needed, but is still linked to from
1317other ops.
1318
1319=cut
1320*/
1321
93c66552
DM
1322void
1323Perl_op_null(pTHX_ OP *o)
8990e307 1324{
27da23d5 1325 dVAR;
7918f24d
NC
1326
1327 PERL_ARGS_ASSERT_OP_NULL;
1328
acb36ea4
GS
1329 if (o->op_type == OP_NULL)
1330 return;
b5bbe64a 1331 op_clear(o);
11343788 1332 o->op_targ = o->op_type;
b9a07097 1333 OpTYPE_set(o, OP_NULL);
8990e307
LW
1334}
1335
4026c95a
SH
1336void
1337Perl_op_refcnt_lock(pTHX)
e1fc825d 1338 PERL_TSA_ACQUIRE(PL_op_mutex)
4026c95a 1339{
20b7effb 1340#ifdef USE_ITHREADS
27da23d5 1341 dVAR;
20b7effb 1342#endif
96a5add6 1343 PERL_UNUSED_CONTEXT;
4026c95a
SH
1344 OP_REFCNT_LOCK;
1345}
1346
1347void
1348Perl_op_refcnt_unlock(pTHX)
e1fc825d 1349 PERL_TSA_RELEASE(PL_op_mutex)
4026c95a 1350{
20b7effb 1351#ifdef USE_ITHREADS
27da23d5 1352 dVAR;
20b7effb 1353#endif
96a5add6 1354 PERL_UNUSED_CONTEXT;
4026c95a
SH
1355 OP_REFCNT_UNLOCK;
1356}
1357
3253bf85
DM
1358
1359/*
1360=for apidoc op_sibling_splice
1361
1362A general function for editing the structure of an existing chain of
796b6530 1363op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
3253bf85
DM
1364you to delete zero or more sequential nodes, replacing them with zero or
1365more different nodes. Performs the necessary op_first/op_last
29e61fd9 1366housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1367children. The last deleted node will be marked as as the last node by
87b5a8b9 1368updating the op_sibling/op_sibparent or op_moresib field as appropriate.
3253bf85
DM
1369
1370Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1371responsibility of the caller. It also won't create a new list op for an
8ae26bff 1372empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85 1373
796b6530 1374C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
3269ea41 1375the splicing doesn't affect the first or last op in the chain.
3253bf85 1376
796b6530 1377C<start> is the node preceding the first node to be spliced. Node(s)
7e234f81 1378following it will be deleted, and ops will be inserted after it. If it is
796b6530 1379C<NULL>, the first node onwards is deleted, and nodes are inserted at the
3253bf85
DM
1380beginning.
1381
796b6530 1382C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1383If -1 or greater than or equal to the number of remaining kids, all
1384remaining kids are deleted.
1385
796b6530
KW
1386C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1387If C<NULL>, no nodes are inserted.
3253bf85 1388
796b6530 1389The head of the chain of deleted ops is returned, or C<NULL> if no ops were
3253bf85
DM
1390deleted.
1391
1392For example:
1393
1394 action before after returns
1395 ------ ----- ----- -------
1396
1397 P P
8ae26bff
DM
1398 splice(P, A, 2, X-Y-Z) | | B-C
1399 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1400
1401 P P
1402 splice(P, NULL, 1, X-Y) | | A
1403 A-B-C-D X-Y-B-C-D
1404
1405 P P
8ae26bff
DM
1406 splice(P, NULL, 3, NULL) | | A-B-C
1407 A-B-C-D D
3253bf85
DM
1408
1409 P P
1410 splice(P, B, 0, X-Y) | | NULL
1411 A-B-C-D A-B-X-Y-C-D
1412
5e24af7d
DM
1413
1414For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
fbe13c60 1415see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
5e24af7d 1416
3253bf85
DM
1417=cut
1418*/
1419
1420OP *
8ae26bff 1421Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1422{
3269ea41 1423 OP *first;
3253bf85
DM
1424 OP *rest;
1425 OP *last_del = NULL;
1426 OP *last_ins = NULL;
1427
3269ea41
DM
1428 if (start)
1429 first = OpSIBLING(start);
1430 else if (!parent)
1431 goto no_parent;
1432 else
1433 first = cLISTOPx(parent)->op_first;
3253bf85
DM
1434
1435 assert(del_count >= -1);
1436
1437 if (del_count && first) {
1438 last_del = first;
e6dae479
FC
1439 while (--del_count && OpHAS_SIBLING(last_del))
1440 last_del = OpSIBLING(last_del);
1441 rest = OpSIBLING(last_del);
5e24af7d 1442 OpLASTSIB_set(last_del, NULL);
3253bf85
DM
1443 }
1444 else
1445 rest = first;
1446
1447 if (insert) {
1448 last_ins = insert;
e6dae479
FC
1449 while (OpHAS_SIBLING(last_ins))
1450 last_ins = OpSIBLING(last_ins);
5e24af7d 1451 OpMAYBESIB_set(last_ins, rest, NULL);
3253bf85
DM
1452 }
1453 else
1454 insert = rest;
1455
29e61fd9 1456 if (start) {
5e24af7d 1457 OpMAYBESIB_set(start, insert, NULL);
29e61fd9 1458 }
b3e29a8d 1459 else {
678ae292 1460 assert(parent);
3253bf85 1461 cLISTOPx(parent)->op_first = insert;
b3e29a8d
DM
1462 if (insert)
1463 parent->op_flags |= OPf_KIDS;
1464 else
1465 parent->op_flags &= ~OPf_KIDS;
1466 }
3253bf85
DM
1467
1468 if (!rest) {
29e61fd9 1469 /* update op_last etc */
3269ea41 1470 U32 type;
29e61fd9 1471 OP *lastop;
3253bf85 1472
3269ea41
DM
1473 if (!parent)
1474 goto no_parent;
1475
05039abd
DM
1476 /* ought to use OP_CLASS(parent) here, but that can't handle
1477 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1478 * either */
3269ea41 1479 type = parent->op_type;
05039abd
DM
1480 if (type == OP_CUSTOM) {
1481 dTHX;
1482 type = XopENTRYCUSTOM(parent, xop_class);
1483 }
1484 else {
1485 if (type == OP_NULL)
1486 type = parent->op_targ;
1487 type = PL_opargs[type] & OA_CLASS_MASK;
1488 }
3253bf85 1489
29e61fd9 1490 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1491 if ( type == OA_BINOP
1492 || type == OA_LISTOP
1493 || type == OA_PMOP
1494 || type == OA_LOOP
1495 )
29e61fd9
DM
1496 cLISTOPx(parent)->op_last = lastop;
1497
5e24af7d
DM
1498 if (lastop)
1499 OpLASTSIB_set(lastop, parent);
3253bf85
DM
1500 }
1501 return last_del ? first : NULL;
3269ea41
DM
1502
1503 no_parent:
1504 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
3253bf85
DM
1505}
1506
29e61fd9
DM
1507/*
1508=for apidoc op_parent
1509
796b6530 1510Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
29e61fd9
DM
1511
1512=cut
1513*/
1514
1515OP *
8ae26bff 1516Perl_op_parent(OP *o)
29e61fd9
DM
1517{
1518 PERL_ARGS_ASSERT_OP_PARENT;
e6dae479
FC
1519 while (OpHAS_SIBLING(o))
1520 o = OpSIBLING(o);
86cd3a13 1521 return o->op_sibparent;
29e61fd9
DM
1522}
1523
3253bf85
DM
1524/* replace the sibling following start with a new UNOP, which becomes
1525 * the parent of the original sibling; e.g.
1526 *
1527 * op_sibling_newUNOP(P, A, unop-args...)
1528 *
1529 * P P
1530 * | becomes |
1531 * A-B-C A-U-C
1532 * |
1533 * B
1534 *
1535 * where U is the new UNOP.
1536 *
1537 * parent and start args are the same as for op_sibling_splice();
1538 * type and flags args are as newUNOP().
1539 *
1540 * Returns the new UNOP.
1541 */
1542
f9db5646 1543STATIC OP *
3253bf85
DM
1544S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1545{
1546 OP *kid, *newop;
1547
1548 kid = op_sibling_splice(parent, start, 1, NULL);
1549 newop = newUNOP(type, flags, kid);
1550 op_sibling_splice(parent, start, 0, newop);
1551 return newop;
1552}
1553
1554
1555/* lowest-level newLOGOP-style function - just allocates and populates
1556 * the struct. Higher-level stuff should be done by S_new_logop() /
1557 * newLOGOP(). This function exists mainly to avoid op_first assignment
1558 * being spread throughout this file.
1559 */
1560
6cb4123e
DM
1561LOGOP *
1562Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
3253bf85 1563{
1e8db68a 1564 dVAR;
3253bf85 1565 LOGOP *logop;
29e61fd9 1566 OP *kid = first;
3253bf85 1567 NewOp(1101, logop, 1, LOGOP);
b9a07097 1568 OpTYPE_set(logop, type);
3253bf85
DM
1569 logop->op_first = first;
1570 logop->op_other = other;
d2d35729
FC
1571 if (first)
1572 logop->op_flags = OPf_KIDS;
e6dae479
FC
1573 while (kid && OpHAS_SIBLING(kid))
1574 kid = OpSIBLING(kid);
5e24af7d
DM
1575 if (kid)
1576 OpLASTSIB_set(kid, (OP*)logop);
3253bf85
DM
1577 return logop;
1578}
1579
1580
79072805
LW
1581/* Contextualizers */
1582
d9088386 1583/*
44170c9a 1584=for apidoc op_contextualize
d9088386
Z
1585
1586Applies a syntactic context to an op tree representing an expression.
2d7f6611 1587C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
d9088386
Z
1588or C<G_VOID> to specify the context to apply. The modified op tree
1589is returned.
1590
1591=cut
1592*/
1593
1594OP *
1595Perl_op_contextualize(pTHX_ OP *o, I32 context)
1596{
1597 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1598 switch (context) {
1599 case G_SCALAR: return scalar(o);
1600 case G_ARRAY: return list(o);
1601 case G_VOID: return scalarvoid(o);
1602 default:
5637ef5b
NC
1603 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1604 (long) context);
d9088386
Z
1605 }
1606}
1607
5983a79d 1608/*
79072805 1609
44170c9a 1610=for apidoc op_linklist
72d33970 1611This function is the implementation of the L</LINKLIST> macro. It should
5983a79d
BM
1612not be called directly.
1613
1614=cut
1615*/
1616
7d3bb7a6 1617
5983a79d
BM
1618OP *
1619Perl_op_linklist(pTHX_ OP *o)
79072805 1620{
7d3bb7a6
DM
1621
1622 OP **prevp;
1623 OP *kid;
1624 OP * top_op = o;
1625
5983a79d 1626 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1627
7d3bb7a6
DM
1628 while (1) {
1629 /* Descend down the tree looking for any unprocessed subtrees to
1630 * do first */
1631 if (!o->op_next) {
1632 if (o->op_flags & OPf_KIDS) {
1633 o = cUNOPo->op_first;
1634 continue;
1635 }
1636 o->op_next = o; /* leaf node; link to self initially */
1637 }
79072805 1638
7d3bb7a6
DM
1639 /* if we're at the top level, there either weren't any children
1640 * to process, or we've worked our way back to the top. */
1641 if (o == top_op)
1642 return o->op_next;
79072805 1643
7d3bb7a6
DM
1644 /* o is now processed. Next, process any sibling subtrees */
1645
1646 if (OpHAS_SIBLING(o)) {
1647 o = OpSIBLING(o);
1648 continue;
1649 }
1650
1651 /* Done all the subtrees at this level. Go back up a level and
1652 * link the parent in with all its (processed) children.
1653 */
1654
1655 o = o->op_sibparent;
1656 assert(!o->op_next);
1657 prevp = &(o->op_next);
1658 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1659 while (kid) {
1660 *prevp = kid->op_next;
1661 prevp = &(kid->op_next);
1662 kid = OpSIBLING(kid);
1663 }
1664 *prevp = o;
1665 }
79072805
LW
1666}
1667
7d3bb7a6 1668
1f676739 1669static OP *
2dd5337b 1670S_scalarkids(pTHX_ OP *o)
79072805 1671{
11343788 1672 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1673 OP *kid;
e6dae479 1674 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
1675 scalar(kid);
1676 }
11343788 1677 return o;
79072805
LW
1678}
1679
76e3520e 1680STATIC OP *
cea2e8a9 1681S_scalarboolean(pTHX_ OP *o)
8990e307 1682{
7918f24d
NC
1683 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1684
0a44e30b
DC
1685 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1686 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1687 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1688 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1689 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
d008e5eb 1690 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1691 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1692
2b7cddde
NC
1693 if (PL_parser && PL_parser->copline != NOLINE) {
1694 /* This ensures that warnings are reported at the first line
1695 of the conditional, not the last. */
53a7735b 1696 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1697 }
9014280d 1698 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1699 CopLINE_set(PL_curcop, oldline);
d008e5eb 1700 }
a0d0e21e 1701 }
11343788 1702 return scalar(o);
8990e307
LW
1703}
1704
0920b7fa 1705static SV *
637494ac 1706S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
0920b7fa
FC
1707{
1708 assert(o);
1709 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1710 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1711 {
1712 const char funny = o->op_type == OP_PADAV
1713 || o->op_type == OP_RV2AV ? '@' : '%';
1714 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1715 GV *gv;
1716 if (cUNOPo->op_first->op_type != OP_GV
1717 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1718 return NULL;
637494ac 1719 return varname(gv, funny, 0, NULL, 0, subscript_type);
0920b7fa
FC
1720 }
1721 return
637494ac 1722 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
0920b7fa
FC
1723 }
1724}
1725
637494ac
TC
1726static SV *
1727S_op_varname(pTHX_ const OP *o)
1728{
1729 return S_op_varname_subscript(aTHX_ o, 1);
1730}
1731
429a2555 1732static void
2186f873
FC
1733S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1734{ /* or not so pretty :-) */
2186f873
FC
1735 if (o->op_type == OP_CONST) {
1736 *retsv = cSVOPo_sv;
1737 if (SvPOK(*retsv)) {
1738 SV *sv = *retsv;
1739 *retsv = sv_newmortal();
1740 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1741 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1742 }
1743 else if (!SvOK(*retsv))
1744 *retpv = "undef";
1745 }
1746 else *retpv = "...";
1747}
1748
1749static void
429a2555
FC
1750S_scalar_slice_warning(pTHX_ const OP *o)
1751{
1752 OP *kid;
fe7df09e
FC
1753 const bool h = o->op_type == OP_HSLICE
1754 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
429a2555 1755 const char lbrack =
fe7df09e 1756 h ? '{' : '[';
429a2555 1757 const char rbrack =
fe7df09e 1758 h ? '}' : ']';
429a2555 1759 SV *name;
32e9ec8f 1760 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC
1761 const char *key = NULL;
1762
1763 if (!(o->op_private & OPpSLICEWARNING))
1764 return;
1765 if (PL_parser && PL_parser->error_count)
1766 /* This warning can be nonsensical when there is a syntax error. */
1767 return;
1768
1769 kid = cLISTOPo->op_first;
e6dae479 1770 kid = OpSIBLING(kid); /* get past pushmark */
429a2555
FC
1771 /* weed out false positives: any ops that can return lists */
1772 switch (kid->op_type) {
1773 case OP_BACKTICK:
1774 case OP_GLOB:
1775 case OP_READLINE:
1776 case OP_MATCH:
1777 case OP_RV2AV:
1778 case OP_EACH:
1779 case OP_VALUES:
1780 case OP_KEYS:
1781 case OP_SPLIT:
1782 case OP_LIST:
1783 case OP_SORT:
1784 case OP_REVERSE:
1785 case OP_ENTERSUB:
1786 case OP_CALLER:
1787 case OP_LSTAT:
1788 case OP_STAT:
1789 case OP_READDIR:
1790 case OP_SYSTEM:
1791 case OP_TMS:
1792 case OP_LOCALTIME:
1793 case OP_GMTIME:
1794 case OP_ENTEREVAL:
429a2555
FC
1795 return;
1796 }
7d3c8a68
SM
1797
1798 /* Don't warn if we have a nulled list either. */
1799 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1800 return;
1801
e6dae479
FC
1802 assert(OpSIBLING(kid));
1803 name = S_op_varname(aTHX_ OpSIBLING(kid));
429a2555
FC
1804 if (!name) /* XS module fiddling with the op tree */
1805 return;
2186f873 1806 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC
1807 assert(SvPOK(name));
1808 sv_chop(name,SvPVX(name)+1);
1809 if (key)
2186f873 1810 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1811 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846 1812 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
429a2555 1813 "%c%s%c",
2186f873 1814 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC
1815 lbrack, key, rbrack);
1816 else
2186f873 1817 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1818 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846
KW
1819 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1820 SVf "%c%" SVf "%c",
c1f6cd39
BF
1821 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1822 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
429a2555
FC
1823}
1824
8623f87f
DM
1825
1826
1827/* apply scalar context to the o subtree */
1828
8990e307 1829OP *
864dbfa3 1830Perl_scalar(pTHX_ OP *o)
79072805 1831{
86e988be
DM
1832 OP * top_op = o;
1833
1834 while (1) {
78ae974a
DM
1835 OP *next_kid = NULL; /* what op (if any) to process next */
1836 OP *kid;
8623f87f 1837
78ae974a
DM
1838 /* assumes no premature commitment */
1839 if (!o || (PL_parser && PL_parser->error_count)
1840 || (o->op_flags & OPf_WANT)
1841 || o->op_type == OP_RETURN)
1842 {
1843 goto do_next;
1844 }
8623f87f 1845
78ae974a 1846 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
8623f87f 1847
78ae974a
DM
1848 switch (o->op_type) {
1849 case OP_REPEAT:
1850 scalar(cBINOPo->op_first);
1851 /* convert what initially looked like a list repeat into a
1852 * scalar repeat, e.g. $s = (1) x $n
1853 */
1854 if (o->op_private & OPpREPEAT_DOLIST) {
1855 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1856 assert(kid->op_type == OP_PUSHMARK);
1857 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1858 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1859 o->op_private &=~ OPpREPEAT_DOLIST;
1860 }
1861 }
1862 break;
8623f87f 1863
78ae974a
DM
1864 case OP_OR:
1865 case OP_AND:
1866 case OP_COND_EXPR:
1867 /* impose scalar context on everything except the condition */
1868 next_kid = OpSIBLING(cUNOPo->op_first);
1869 break;
8623f87f 1870
78ae974a
DM
1871 default:
1872 if (o->op_flags & OPf_KIDS)
1873 next_kid = cUNOPo->op_first; /* do all kids */
1874 break;
2186f873 1875
78ae974a
DM
1876 /* the children of these ops are usually a list of statements,
1877 * except the leaves, whose first child is a corresponding enter
1878 */
1879 case OP_SCOPE:
1880 case OP_LINESEQ:
1881 case OP_LIST:
1882 kid = cLISTOPo->op_first;
1883 goto do_kids;
1884 case OP_LEAVE:
1885 case OP_LEAVETRY:
1886 kid = cLISTOPo->op_first;
1887 scalar(kid);
1888 kid = OpSIBLING(kid);
1889 do_kids:
1890 while (kid) {
1891 OP *sib = OpSIBLING(kid);
adb47cec
DM
1892 /* Apply void context to all kids except the last, which
1893 * is scalar (ignoring a trailing ex-nextstate in determining
1894 * if it's the last kid). E.g.
1895 * $scalar = do { void; void; scalar }
1896 * Except that 'when's are always scalar, e.g.
1897 * $scalar = do { given(..) {
1898 * when (..) { scalar }
1899 * when (..) { scalar }
1900 * ...
1901 * }}
1902 */
1903 if (!sib
1904 || ( !OpHAS_SIBLING(sib)
1905 && sib->op_type == OP_NULL
1906 && ( sib->op_targ == OP_NEXTSTATE
1907 || sib->op_targ == OP_DBSTATE )
1908 )
1909 )
db18005b
DM
1910 {
1911 /* tail call optimise calling scalar() on the last kid */
1912 next_kid = kid;
1913 goto do_next;
1914 }
adb47cec 1915 else if (kid->op_type == OP_LEAVEWHEN)
78ae974a 1916 scalar(kid);
adb47cec
DM
1917 else
1918 scalarvoid(kid);
78ae974a
DM
1919 kid = sib;
1920 }
db18005b 1921 NOT_REACHED; /* NOTREACHED */
78ae974a 1922 break;
2186f873 1923
78ae974a
DM
1924 case OP_SORT:
1925 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1926 break;
2186f873 1927
78ae974a
DM
1928 case OP_KVHSLICE:
1929 case OP_KVASLICE:
1930 {
1931 /* Warn about scalar context */
1932 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1933 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1934 SV *name;
1935 SV *keysv;
1936 const char *key = NULL;
1937
1938 /* This warning can be nonsensical when there is a syntax error. */
1939 if (PL_parser && PL_parser->error_count)
1940 break;
1941
1942 if (!ckWARN(WARN_SYNTAX)) break;
1943
1944 kid = cLISTOPo->op_first;
1945 kid = OpSIBLING(kid); /* get past pushmark */
1946 assert(OpSIBLING(kid));
1947 name = S_op_varname(aTHX_ OpSIBLING(kid));
1948 if (!name) /* XS module fiddling with the op tree */
1949 break;
1950 S_op_pretty(aTHX_ kid, &keysv, &key);
1951 assert(SvPOK(name));
1952 sv_chop(name,SvPVX(name)+1);
1953 if (key)
1954 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1955 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1956 "%%%" SVf "%c%s%c in scalar context better written "
1957 "as $%" SVf "%c%s%c",
1958 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1959 lbrack, key, rbrack);
1960 else
1961 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1962 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1963 "%%%" SVf "%c%" SVf "%c in scalar context better "
1964 "written as $%" SVf "%c%" SVf "%c",
1965 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1966 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1967 }
1968 } /* switch */
1969
1970 /* If next_kid is set, someone in the code above wanted us to process
1971 * that kid and all its remaining siblings. Otherwise, work our way
1972 * back up the tree */
1973 do_next:
1974 while (!next_kid) {
1975 if (o == top_op)
1976 return top_op; /* at top; no parents/siblings to try */
1977 if (OpHAS_SIBLING(o))
1978 next_kid = o->op_sibparent;
db18005b 1979 else {
78ae974a 1980 o = o->op_sibparent; /*try parent's next sibling */
db18005b
DM
1981 switch (o->op_type) {
1982 case OP_SCOPE:
1983 case OP_LINESEQ:
1984 case OP_LIST:
1985 case OP_LEAVE:
1986 case OP_LEAVETRY:
1987 /* should really restore PL_curcop to its old value, but
1988 * setting it to PL_compiling is better than do nothing */
1989 PL_curcop = &PL_compiling;
1990 }
1991 }
78ae974a
DM
1992 }
1993 o = next_kid;
86e988be 1994 } /* while */
79072805
LW
1995}
1996
8623f87f 1997
67ba1548
DM
1998/* apply void context to the optree arg */
1999
79072805 2000OP *
aa9d1253 2001Perl_scalarvoid(pTHX_ OP *arg)
79072805 2002{
27da23d5 2003 dVAR;
79072805 2004 OP *kid;
8990e307 2005 SV* sv;
aa9d1253 2006 OP *o = arg;
2ebea0a1 2007
7918f24d
NC
2008 PERL_ARGS_ASSERT_SCALARVOID;
2009
2a56a87f 2010 while (1) {
19742f39 2011 U8 want;
aa9d1253
TC
2012 SV *useless_sv = NULL;
2013 const char* useless = NULL;
2a56a87f 2014 OP * next_kid = NULL;
aa9d1253 2015
26f0e7d5
TC
2016 if (o->op_type == OP_NEXTSTATE
2017 || o->op_type == OP_DBSTATE
2018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2019 || o->op_targ == OP_DBSTATE)))
2020 PL_curcop = (COP*)o; /* for warning below */
2021
2022 /* assumes no premature commitment */
2023 want = o->op_flags & OPf_WANT;
2024 if ((want && want != OPf_WANT_SCALAR)
2025 || (PL_parser && PL_parser->error_count)
7896dde7 2026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
26f0e7d5 2027 {
2a56a87f 2028 goto get_next_op;
26f0e7d5 2029 }
1c846c1f 2030
26f0e7d5
TC
2031 if ((o->op_private & OPpTARGET_MY)
2032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2033 {
0d18dd72
FC
2034 /* newASSIGNOP has already applied scalar context, which we
2035 leave, as if this op is inside SASSIGN. */
2a56a87f 2036 goto get_next_op;
26f0e7d5 2037 }
79072805 2038
26f0e7d5 2039 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
75068674 2040
26f0e7d5
TC
2041 switch (o->op_type) {
2042 default:
2043 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2044 break;
2045 /* FALLTHROUGH */
2046 case OP_REPEAT:
2047 if (o->op_flags & OPf_STACKED)
2048 break;
1e2dd519
FC
2049 if (o->op_type == OP_REPEAT)
2050 scalar(cBINOPo->op_first);
26f0e7d5 2051 goto func_ops;
3d033384
Z
2052 case OP_CONCAT:
2053 if ((o->op_flags & OPf_STACKED) &&
2054 !(o->op_private & OPpCONCAT_NESTED))
2055 break;
2056 goto func_ops;
26f0e7d5
TC
2057 case OP_SUBSTR:
2058 if (o->op_private == 4)
2059 break;
2060 /* FALLTHROUGH */
26f0e7d5
TC
2061 case OP_WANTARRAY:
2062 case OP_GV:
2063 case OP_SMARTMATCH:
26f0e7d5
TC
2064 case OP_AV2ARYLEN:
2065 case OP_REF:
2066 case OP_REFGEN:
2067 case OP_SREFGEN:
2068 case OP_DEFINED:
2069 case OP_HEX:
2070 case OP_OCT:
2071 case OP_LENGTH:
2072 case OP_VEC:
2073 case OP_INDEX:
2074 case OP_RINDEX:
2075 case OP_SPRINTF:
26f0e7d5 2076 case OP_KVASLICE:
26f0e7d5
TC
2077 case OP_KVHSLICE:
2078 case OP_UNPACK:
2079 case OP_PACK:
2080 case OP_JOIN:
2081 case OP_LSLICE:
2082 case OP_ANONLIST:
2083 case OP_ANONHASH:
2084 case OP_SORT:
2085 case OP_REVERSE:
2086 case OP_RANGE:
2087 case OP_FLIP:
2088 case OP_FLOP:
2089 case OP_CALLER:
2090 case OP_FILENO:
2091 case OP_EOF:
2092 case OP_TELL:
2093 case OP_GETSOCKNAME:
2094 case OP_GETPEERNAME:
2095 case OP_READLINK:
2096 case OP_TELLDIR:
2097 case OP_GETPPID:
2098 case OP_GETPGRP:
2099 case OP_GETPRIORITY:
2100 case OP_TIME:
2101 case OP_TMS:
2102 case OP_LOCALTIME:
2103 case OP_GMTIME:
2104 case OP_GHBYNAME:
2105 case OP_GHBYADDR:
2106 case OP_GHOSTENT:
2107 case OP_GNBYNAME:
2108 case OP_GNBYADDR:
2109 case OP_GNETENT:
2110 case OP_GPBYNAME:
2111 case OP_GPBYNUMBER:
2112 case OP_GPROTOENT:
2113 case OP_GSBYNAME:
2114 case OP_GSBYPORT:
2115 case OP_GSERVENT:
2116 case OP_GPWNAM:
2117 case OP_GPWUID:
2118 case OP_GGRNAM:
2119 case OP_GGRGID:
2120 case OP_GETLOGIN:
2121 case OP_PROTOTYPE:
2122 case OP_RUNCV:
2123 func_ops:
9e209402
FC
2124 useless = OP_DESC(o);
2125 break;
2126
2127 case OP_GVSV:
2128 case OP_PADSV:
2129 case OP_PADAV:
2130 case OP_PADHV:
2131 case OP_PADANY:
2132 case OP_AELEM:
2133 case OP_AELEMFAST:
2134 case OP_AELEMFAST_LEX:
2135 case OP_ASLICE:
2136 case OP_HELEM:
2137 case OP_HSLICE:
26f0e7d5 2138 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
ea5519d6 2139 /* Otherwise it's "Useless use of grep iterator" */
3c3f8cd6 2140 useless = OP_DESC(o);
ea5519d6 2141 break;
26f0e7d5
TC
2142
2143 case OP_SPLIT:
5012eebe 2144 if (!(o->op_private & OPpSPLIT_ASSIGN))
26f0e7d5
TC
2145 useless = OP_DESC(o);
2146 break;
2147
2148 case OP_NOT:
2149 kid = cUNOPo->op_first;
2150 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2151 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2152 goto func_ops;
2153 }
2154 useless = "negative pattern binding (!~)";
2155 break;
2156
2157 case OP_SUBST:
2158 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2159 useless = "non-destructive substitution (s///r)";
2160 break;
2161
2162 case OP_TRANSR:
2163 useless = "non-destructive transliteration (tr///r)";
2164 break;
2165
2166 case OP_RV2GV:
2167 case OP_RV2SV:
2168 case OP_RV2AV:
2169 case OP_RV2HV:
2170 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
e6dae479 2171 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
26f0e7d5
TC
2172 useless = "a variable";
2173 break;
2174
2175 case OP_CONST:
2176 sv = cSVOPo_sv;
2177 if (cSVOPo->op_private & OPpCONST_STRICT)
2178 no_bareword_allowed(o);
2179 else {
2180 if (ckWARN(WARN_VOID)) {
2181 NV nv;
2182 /* don't warn on optimised away booleans, eg
2183 * use constant Foo, 5; Foo || print; */
2184 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2185 useless = NULL;
2186 /* the constants 0 and 1 are permitted as they are
2187 conventionally used as dummies in constructs like
2188 1 while some_condition_with_side_effects; */
2189 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2190 useless = NULL;
2191 else if (SvPOK(sv)) {
2192 SV * const dsv = newSVpvs("");
2193 useless_sv
2194 = Perl_newSVpvf(aTHX_
2195 "a constant (%s)",
2196 pv_pretty(dsv, SvPVX_const(sv),
2197 SvCUR(sv), 32, NULL, NULL,
2198 PERL_PV_PRETTY_DUMP
2199 | PERL_PV_ESCAPE_NOCLEAR
2200 | PERL_PV_ESCAPE_UNI_DETECT));
2201 SvREFCNT_dec_NN(dsv);
2202 }
2203 else if (SvOK(sv)) {
147e3846 2204 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
26f0e7d5
TC
2205 }
2206 else
2207 useless = "a constant (undef)";
2208 }
2209 }
2210 op_null(o); /* don't execute or even remember it */
2211 break;
79072805 2212
26f0e7d5 2213 case OP_POSTINC:
b9a07097 2214 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
26f0e7d5 2215 break;
79072805 2216
26f0e7d5 2217 case OP_POSTDEC:
b9a07097 2218 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
26f0e7d5 2219 break;
79072805 2220
26f0e7d5 2221 case OP_I_POSTINC:
b9a07097 2222 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
26f0e7d5 2223 break;
79072805 2224
26f0e7d5 2225 case OP_I_POSTDEC:
b9a07097 2226 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
26f0e7d5 2227 break;
679d6c4e 2228
26f0e7d5
TC
2229 case OP_SASSIGN: {
2230 OP *rv2gv;
2231 UNOP *refgen, *rv2cv;
2232 LISTOP *exlist;
679d6c4e 2233
26f0e7d5
TC
2234 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2235 break;
f2f8fd84 2236
26f0e7d5
TC
2237 rv2gv = ((BINOP *)o)->op_last;
2238 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2239 break;
f2f8fd84 2240
26f0e7d5 2241 refgen = (UNOP *)((BINOP *)o)->op_first;
f2f8fd84 2242
26f0e7d5
TC
2243 if (!refgen || (refgen->op_type != OP_REFGEN
2244 && refgen->op_type != OP_SREFGEN))
2245 break;
f2f8fd84 2246
26f0e7d5
TC
2247 exlist = (LISTOP *)refgen->op_first;
2248 if (!exlist || exlist->op_type != OP_NULL
2249 || exlist->op_targ != OP_LIST)
2250 break;
f2f8fd84 2251
26f0e7d5
TC
2252 if (exlist->op_first->op_type != OP_PUSHMARK
2253 && exlist->op_first != exlist->op_last)
2254 break;
f2f8fd84 2255
26f0e7d5 2256 rv2cv = (UNOP*)exlist->op_last;
f2f8fd84 2257
26f0e7d5
TC
2258 if (rv2cv->op_type != OP_RV2CV)
2259 break;
f2f8fd84 2260
26f0e7d5
TC
2261 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2262 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2263 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
f2f8fd84 2264
26f0e7d5
TC
2265 o->op_private |= OPpASSIGN_CV_TO_GV;
2266 rv2gv->op_private |= OPpDONT_INIT_GV;
2267 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
f2f8fd84 2268
26f0e7d5
TC
2269 break;
2270 }
540dd770 2271
26f0e7d5
TC
2272 case OP_AASSIGN: {
2273 inplace_aassign(o);
2274 break;
2275 }
edbe35ea 2276
26f0e7d5
TC
2277 case OP_OR:
2278 case OP_AND:
2279 kid = cLOGOPo->op_first;
2280 if (kid->op_type == OP_NOT
2281 && (kid->op_flags & OPf_KIDS)) {
2282 if (o->op_type == OP_AND) {
b9a07097 2283 OpTYPE_set(o, OP_OR);
26f0e7d5 2284 } else {
b9a07097 2285 OpTYPE_set(o, OP_AND);
26f0e7d5
TC
2286 }
2287 op_null(kid);
2288 }
2289 /* FALLTHROUGH */
5aabfad6 2290
26f0e7d5
TC
2291 case OP_DOR:
2292 case OP_COND_EXPR:
2293 case OP_ENTERGIVEN:
7896dde7 2294 case OP_ENTERWHEN:
2a56a87f 2295 next_kid = OpSIBLING(cUNOPo->op_first);
aa9d1253 2296 break;
095b19d1 2297
26f0e7d5
TC
2298 case OP_NULL:
2299 if (o->op_flags & OPf_STACKED)
2300 break;
2301 /* FALLTHROUGH */
2302 case OP_NEXTSTATE:
2303 case OP_DBSTATE:
2304 case OP_ENTERTRY:
2305 case OP_ENTER:
2306 if (!(o->op_flags & OPf_KIDS))
2307 break;
2308 /* FALLTHROUGH */
2309 case OP_SCOPE:
2310 case OP_LEAVE:
2311 case OP_LEAVETRY:
2312 case OP_LEAVELOOP:
2313 case OP_LINESEQ:
7896dde7
Z
2314 case OP_LEAVEGIVEN:
2315 case OP_LEAVEWHEN:
26f0e7d5 2316 kids:
2a56a87f 2317 next_kid = cLISTOPo->op_first;
26f0e7d5
TC
2318 break;
2319 case OP_LIST:
2320 /* If the first kid after pushmark is something that the padrange
2321 optimisation would reject, then null the list and the pushmark.
2322 */
2323 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
e6dae479 2324 && ( !(kid = OpSIBLING(kid))
26f0e7d5
TC
2325 || ( kid->op_type != OP_PADSV
2326 && kid->op_type != OP_PADAV
2327 && kid->op_type != OP_PADHV)
2328 || kid->op_private & ~OPpLVAL_INTRO
e6dae479 2329 || !(kid = OpSIBLING(kid))
26f0e7d5
TC
2330 || ( kid->op_type != OP_PADSV
2331 && kid->op_type != OP_PADAV
2332 && kid->op_type != OP_PADHV)
2333 || kid->op_private & ~OPpLVAL_INTRO)
2334 ) {
2335 op_null(cUNOPo->op_first); /* NULL the pushmark */
2336 op_null(o); /* NULL the list */
2337 }
2338 goto kids;
2339 case OP_ENTEREVAL:
2340 scalarkids(o);
2341 break;
2342 case OP_SCALAR:
2343 scalar(o);
2344 break;
2345 }
2346
2347 if (useless_sv) {
2348 /* mortalise it, in case warnings are fatal. */
2349 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
147e3846 2350 "Useless use of %" SVf " in void context",
26f0e7d5
TC
2351 SVfARG(sv_2mortal(useless_sv)));
2352 }
2353 else if (useless) {
3c3f8cd6
AB
2354 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2355 "Useless use of %s in void context",
2356 useless);
26f0e7d5 2357 }
aa9d1253 2358
2a56a87f
DM
2359 get_next_op:
2360 /* if a kid hasn't been nominated to process, continue with the
2361 * next sibling, or if no siblings left, go back to the parent's
2362 * siblings and so on
2363 */
2364 while (!next_kid) {
2365 if (o == arg)
2366 return arg; /* at top; no parents/siblings to try */
2367 if (OpHAS_SIBLING(o))
2368 next_kid = o->op_sibparent;
2369 else
2370 o = o->op_sibparent; /*try parent's next sibling */
2371 }
2372 o = next_kid;
2373 }
aa9d1253
TC
2374
2375 return arg;
79072805
LW
2376}
2377
2a56a87f 2378
1f676739 2379static OP *
412da003 2380S_listkids(pTHX_ OP *o)
79072805 2381{
11343788 2382 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2383 OP *kid;
e6dae479 2384 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
2385 list(kid);
2386 }
11343788 2387 return o;
79072805
LW
2388}
2389
7cd35865
DM
2390
2391/* apply list context to the o subtree */
2392
79072805 2393OP *
864dbfa3 2394Perl_list(pTHX_ OP *o)
79072805 2395{
8ef9070b
DM
2396 OP * top_op = o;
2397
2398 while (1) {
a58b51cf 2399 OP *next_kid = NULL; /* what op (if any) to process next */
8ef9070b 2400
a58b51cf 2401 OP *kid;
79072805 2402
a58b51cf
DM
2403 /* assumes no premature commitment */
2404 if (!o || (o->op_flags & OPf_WANT)
2405 || (PL_parser && PL_parser->error_count)
2406 || o->op_type == OP_RETURN)
2407 {
2408 goto do_next;
2409 }
1c846c1f 2410
a58b51cf
DM
2411 if ((o->op_private & OPpTARGET_MY)
2412 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2413 {
2414 goto do_next; /* As if inside SASSIGN */
2415 }
79072805 2416
a58b51cf 2417 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
054d8a90 2418
a58b51cf
DM
2419 switch (o->op_type) {
2420 case OP_REPEAT:
2421 if (o->op_private & OPpREPEAT_DOLIST
2422 && !(o->op_flags & OPf_STACKED))
2423 {
2424 list(cBINOPo->op_first);
2425 kid = cBINOPo->op_last;
2426 /* optimise away (.....) x 1 */
2427 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2428 && SvIVX(kSVOP_sv) == 1)
2429 {
2430 op_null(o); /* repeat */
2431 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2432 /* const (rhs): */
2433 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2434 }
2435 }
2436 break;
2a45276d 2437
a58b51cf
DM
2438 case OP_OR:
2439 case OP_AND:
2440 case OP_COND_EXPR:
2441 /* impose list context on everything except the condition */
2442 next_kid = OpSIBLING(cUNOPo->op_first);
2443 break;
054d8a90 2444
a58b51cf
DM
2445 default:
2446 if (!(o->op_flags & OPf_KIDS))
2447 break;
2448 /* possibly flatten 1..10 into a constant array */
2449 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2450 list(cBINOPo->op_first);
2451 gen_constant_list(o);
2452 goto do_next;
2453 }
8ef9070b 2454 next_kid = cUNOPo->op_first; /* do all kids */
a58b51cf 2455 break;
054d8a90 2456
a58b51cf
DM
2457 case OP_LIST:
2458 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2459 op_null(cUNOPo->op_first); /* NULL the pushmark */
2460 op_null(o); /* NULL the list */
2461 }
2462 if (o->op_flags & OPf_KIDS)
2463 next_kid = cUNOPo->op_first; /* do all kids */
2464 break;
054d8a90 2465
a58b51cf 2466 /* the children of these ops are usually a list of statements,
06c2b1fc 2467 * except the leaves, whose first child is a corresponding enter
a58b51cf
DM
2468 */
2469 case OP_SCOPE:
2470 case OP_LINESEQ:
2471 kid = cLISTOPo->op_first;
2472 goto do_kids;
2473 case OP_LEAVE:
2474 case OP_LEAVETRY:
2475 kid = cLISTOPo->op_first;
2476 list(kid);
2477 kid = OpSIBLING(kid);
2478 do_kids:
2479 while (kid) {
2480 OP *sib = OpSIBLING(kid);
9d15d64e
DM
2481 /* Apply void context to all kids except the last, which
2482 * is list. E.g.
2483 * @a = do { void; void; list }
2484 * Except that 'when's are always list context, e.g.
2485 * @a = do { given(..) {
2486 * when (..) { list }
2487 * when (..) { list }
2488 * ...
2489 * }}
2490 */
f23e1643
DM
2491 if (!sib) {
2492 /* tail call optimise calling list() on the last kid */
2493 next_kid = kid;
2494 goto do_next;
2495 }
9d15d64e 2496 else if (kid->op_type == OP_LEAVEWHEN)
a58b51cf 2497 list(kid);
9d15d64e
DM
2498 else
2499 scalarvoid(kid);
a58b51cf
DM
2500 kid = sib;
2501 }
f23e1643 2502 NOT_REACHED; /* NOTREACHED */
a58b51cf 2503 break;
054d8a90 2504
a58b51cf 2505 }
8ef9070b 2506
a58b51cf
DM
2507 /* If next_kid is set, someone in the code above wanted us to process
2508 * that kid and all its remaining siblings. Otherwise, work our way
2509 * back up the tree */
2510 do_next:
2511 while (!next_kid) {
2512 if (o == top_op)
2513 return top_op; /* at top; no parents/siblings to try */
2514 if (OpHAS_SIBLING(o))
2515 next_kid = o->op_sibparent;
f23e1643 2516 else {
a58b51cf 2517 o = o->op_sibparent; /*try parent's next sibling */
f23e1643
DM
2518 switch (o->op_type) {
2519 case OP_SCOPE:
2520 case OP_LINESEQ:
2521 case OP_LIST:
2522 case OP_LEAVE:
2523 case OP_LEAVETRY:
2524 /* should really restore PL_curcop to its old value, but
2525 * setting it to PL_compiling is better than do nothing */
2526 PL_curcop = &PL_compiling;
2527 }
2528 }
2529
a58b51cf
DM
2530
2531 }
2532 o = next_kid;
8ef9070b 2533 } /* while */
79072805
LW
2534}
2535
7cd35865 2536
1f676739 2537static OP *
2dd5337b 2538S_scalarseq(pTHX_ OP *o)
79072805 2539{
11343788 2540 if (o) {
1496a290
AL
2541 const OPCODE type = o->op_type;
2542
2543 if (type == OP_LINESEQ || type == OP_SCOPE ||
2544 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2545 {
b7bea5da
FC
2546 OP *kid, *sib;
2547 for (kid = cLISTOPo->op_first; kid; kid = sib) {
e6dae479
FC
2548 if ((sib = OpSIBLING(kid))
2549 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
b7bea5da
FC
2550 || ( sib->op_targ != OP_NEXTSTATE
2551 && sib->op_targ != OP_DBSTATE )))
2552 {
463ee0b2 2553 scalarvoid(kid);
ed6116ce 2554 }
463ee0b2 2555 }
3280af22 2556 PL_curcop = &PL_compiling;
79072805 2557 }
11343788 2558 o->op_flags &= ~OPf_PARENS;
3280af22 2559 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2560 o->op_flags |= OPf_PARENS;
79072805 2561 }
8990e307 2562 else
11343788
MB
2563 o = newOP(OP_STUB, 0);
2564 return o;
79072805
LW
2565}
2566
76e3520e 2567STATIC OP *
cea2e8a9 2568S_modkids(pTHX_ OP *o, I32 type)
79072805 2569{
11343788 2570 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2571 OP *kid;
e6dae479 2572 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3ad73efd 2573 op_lvalue(kid, type);
79072805 2574 }
11343788 2575 return o;
79072805
LW
2576}
2577
12ee5d32
DM
2578
2579/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2580 * const fields. Also, convert CONST keys to HEK-in-SVs.
02a9632a 2581 * rop is the op that retrieves the hash;
12ee5d32 2582 * key_op is the first key
02a9632a 2583 * real if false, only check (and possibly croak); don't update op
12ee5d32
DM
2584 */
2585
f9db5646 2586STATIC void
02a9632a 2587S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
12ee5d32
DM
2588{
2589 PADNAME *lexname;
2590 GV **fields;
2591 bool check_fields;
2592
2593 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2594 if (rop) {
2595 if (rop->op_first->op_type == OP_PADSV)
2596 /* @$hash{qw(keys here)} */
2597 rop = (UNOP*)rop->op_first;
2598 else {
2599 /* @{$hash}{qw(keys here)} */
2600 if (rop->op_first->op_type == OP_SCOPE
2601 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2602 {
2603 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2604 }
2605 else
2606 rop = NULL;
2607 }
2608 }
2609
2610 lexname = NULL; /* just to silence compiler warnings */
2611 fields = NULL; /* just to silence compiler warnings */
2612
2613 check_fields =
2614 rop
2615 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2616 SvPAD_TYPED(lexname))
2617 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2618 && isGV(*fields) && GvHV(*fields);
2619
e6dae479 2620 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
12ee5d32
DM
2621 SV **svp, *sv;
2622 if (key_op->op_type != OP_CONST)
2623 continue;
2624 svp = cSVOPx_svp(key_op);
2625
e1ccd220
DIM
2626 /* make sure it's not a bareword under strict subs */
2627 if (key_op->op_private & OPpCONST_BARE &&
2628 key_op->op_private & OPpCONST_STRICT)
2629 {
2630 no_bareword_allowed((OP*)key_op);
2631 }
2632
12ee5d32
DM
2633 /* Make the CONST have a shared SV */
2634 if ( !SvIsCOW_shared_hash(sv = *svp)
2635 && SvTYPE(sv) < SVt_PVMG
2636 && SvOK(sv)
02a9632a
DM
2637 && !SvROK(sv)
2638 && real)
12ee5d32
DM
2639 {
2640 SSize_t keylen;
2641 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2642 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2643 SvREFCNT_dec_NN(sv);
2644 *svp = nsv;
2645 }
2646
2647 if ( check_fields
2648 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2649 {
147e3846
KW
2650 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2651 "in variable %" PNf " of type %" HEKf,
12ee5d32
DM
2652 SVfARG(*svp), PNfARG(lexname),
2653 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2654 }
2655 }
2656}
2657
e839e6ed
DM
2658/* info returned by S_sprintf_is_multiconcatable() */
2659
2660struct sprintf_ismc_info {
ca84e88e 2661 SSize_t nargs; /* num of args to sprintf (not including the format) */
e839e6ed
DM
2662 char *start; /* start of raw format string */
2663 char *end; /* bytes after end of raw format string */
2664 STRLEN total_len; /* total length (in bytes) of format string, not
2665 including '%s' and half of '%%' */
2666 STRLEN variant; /* number of bytes by which total_len_p would grow
2667 if upgraded to utf8 */
2668 bool utf8; /* whether the format is utf8 */
2669};
2670
2671
2672/* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2673 * i.e. its format argument is a const string with only '%s' and '%%'
2674 * formats, and the number of args is known, e.g.
2675 * sprintf "a=%s f=%s", $a[0], scalar(f());
2676 * but not
2677 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2678 *
2679 * If successful, the sprintf_ismc_info struct pointed to by info will be
2680 * populated.
2681 */
2682
2683STATIC bool
2684S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2685{
2686 OP *pm, *constop, *kid;
2687 SV *sv;
2688 char *s, *e, *p;
ca84e88e 2689 SSize_t nargs, nformats;
e839e6ed
DM
2690 STRLEN cur, total_len, variant;
2691 bool utf8;
2692
2693 /* if sprintf's behaviour changes, die here so that someone
2694 * can decide whether to enhance this function or skip optimising
2695 * under those new circumstances */
2696 assert(!(o->op_flags & OPf_STACKED));
2697 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2698 assert(!(o->op_private & ~OPpARG4_MASK));
2699
2700 pm = cUNOPo->op_first;
2701 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2702 return FALSE;
2703 constop = OpSIBLING(pm);
2704 if (!constop || constop->op_type != OP_CONST)
2705 return FALSE;
2706 sv = cSVOPx_sv(constop);
2707 if (SvMAGICAL(sv) || !SvPOK(sv))
2708 return FALSE;
2709
2710 s = SvPV(sv, cur);
2711 e = s + cur;
2712
2713 /* Scan format for %% and %s and work out how many %s there are.
2714 * Abandon if other format types are found.
2715 */
2716
2717 nformats = 0;
2718 total_len = 0;
2719 variant = 0;
2720
2721 for (p = s; p < e; p++) {
2722 if (*p != '%') {
2723 total_len++;
b3baa1fe 2724 if (!UTF8_IS_INVARIANT(*p))
e839e6ed
DM
2725 variant++;
2726 continue;
2727 }
2728 p++;
2729 if (p >= e)
2730 return FALSE; /* lone % at end gives "Invalid conversion" */
2731 if (*p == '%')
2732 total_len++;
2733 else if (*p == 's')
2734 nformats++;
2735 else
2736 return FALSE;
2737 }
2738
2739 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2740 return FALSE;
2741
2742 utf8 = cBOOL(SvUTF8(sv));
2743 if (utf8)
2744 variant = 0;
2745
2746 /* scan args; they must all be in scalar cxt */
2747
2748 nargs = 0;
2749 kid = OpSIBLING(constop);
2750
2751 while (kid) {
2752 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2753 return FALSE;
2754 nargs++;
2755 kid = OpSIBLING(kid);
2756 }
2757
2758 if (nargs != nformats)
2759 return FALSE; /* e.g. sprintf("%s%s", $a); */
2760
2761
2762 info->nargs = nargs;
2763 info->start = s;
2764 info->end = e;
2765 info->total_len = total_len;
2766 info->variant = variant;
2767 info->utf8 = utf8;
2768
2769 return TRUE;
2770}
2771
2772
2773
2774/* S_maybe_multiconcat():
2775 *
2776 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2777 * convert it (and its children) into an OP_MULTICONCAT. See the code
2778 * comments just before pp_multiconcat() for the full details of what
2779 * OP_MULTICONCAT supports.
2780 *
2781 * Basically we're looking for an optree with a chain of OP_CONCATS down
2782 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2783 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2784 *
2785 * $x = "$a$b-$c"
2786 *
2787 * looks like
2788 *
2789 * SASSIGN
2790 * |
2791 * STRINGIFY -- PADSV[$x]
2792 * |
2793 * |
2794 * ex-PUSHMARK -- CONCAT/S
2795 * |
2796 * CONCAT/S -- PADSV[$d]
2797 * |
2798 * CONCAT -- CONST["-"]
2799 * |
2800 * PADSV[$a] -- PADSV[$b]
2801 *
2802 * Note that at this stage the OP_SASSIGN may have already been optimised
2803 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2804 */
2805
2806STATIC void
2807S_maybe_multiconcat(pTHX_ OP *o)
2808{
1565c085 2809 dVAR;
e839e6ed
DM
2810 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2811 OP *topop; /* the top-most op in the concat tree (often equals o,
2812 unless there are assign/stringify ops above it */
2813 OP *parentop; /* the parent op of topop (or itself if no parent) */
2814 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2815 OP *targetop; /* the op corresponding to target=... or target.=... */
2816 OP *stringop; /* the OP_STRINGIFY op, if any */
2817 OP *nextop; /* used for recreating the op_next chain without consts */
2818 OP *kid; /* general-purpose op pointer */
2819 UNOP_AUX_item *aux;
2820 UNOP_AUX_item *lenp;
2821 char *const_str, *p;
2822 struct sprintf_ismc_info sprintf_info;
2823
2824 /* store info about each arg in args[];
2825 * toparg is the highest used slot; argp is a general
2826 * pointer to args[] slots */
2827 struct {
2828 void *p; /* initially points to const sv (or null for op);
2829 later, set to SvPV(constsv), with ... */
2830 STRLEN len; /* ... len set to SvPV(..., len) */
2831 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2832
ca84e88e
DM
2833 SSize_t nargs = 0;
2834 SSize_t nconst = 0;
f08f2d03 2835 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
e839e6ed
DM
2836 STRLEN variant;
2837 bool utf8 = FALSE;
2838 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2839 the last-processed arg will the LHS of one,
2840 as args are processed in reverse order */
2841 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2842 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2843 U8 flags = 0; /* what will become the op_flags and ... */
2844 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2845 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2846 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
f08f2d03 2847 bool prev_was_const = FALSE; /* previous arg was a const */
e839e6ed
DM
2848
2849 /* -----------------------------------------------------------------
2850 * Phase 1:
2851 *
2852 * Examine the optree non-destructively to determine whether it's
2853 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2854 * information about the optree in args[].
2855 */
2856
2857 argp = args;
2858 targmyop = NULL;
2859 targetop = NULL;
2860 stringop = NULL;
2861 topop = o;
2862 parentop = o;
2863
2864 assert( o->op_type == OP_SASSIGN
2865 || o->op_type == OP_CONCAT
2866 || o->op_type == OP_SPRINTF
2867 || o->op_type == OP_STRINGIFY);
2868
da431b10
JH
2869 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2870
e839e6ed
DM
2871 /* first see if, at the top of the tree, there is an assign,
2872 * append and/or stringify */
2873
2874 if (topop->op_type == OP_SASSIGN) {
2875 /* expr = ..... */
2876 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2877 return;
2878 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2879 return;
2880 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2881
2882 parentop = topop;
2883 topop = cBINOPo->op_first;
2884 targetop = OpSIBLING(topop);
2885 if (!targetop) /* probably some sort of syntax error */
2886 return;
2887 }
2888 else if ( topop->op_type == OP_CONCAT
2889 && (topop->op_flags & OPf_STACKED)
62c1220c
DM
2890 && (!(topop->op_private & OPpCONCAT_NESTED))
2891 )
e839e6ed
DM
2892 {
2893 /* expr .= ..... */
2894
2895 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2896 * decide what to do about it */
2897 assert(!(o->op_private & OPpTARGET_MY));
2898
2899 /* barf on unknown flags */
2900 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2901 private_flags |= OPpMULTICONCAT_APPEND;
2902 targetop = cBINOPo->op_first;
2903 parentop = topop;
2904 topop = OpSIBLING(targetop);
2905
2906 /* $x .= <FOO> gets optimised to rcatline instead */
2907 if (topop->op_type == OP_READLINE)
2908 return;
2909 }
2910
2911 if (targetop) {
2912 /* Can targetop (the LHS) if it's a padsv, be be optimised
2913 * away and use OPpTARGET_MY instead?
2914 */
2915 if ( (targetop->op_type == OP_PADSV)
2916 && !(targetop->op_private & OPpDEREF)
2917 && !(targetop->op_private & OPpPAD_STATE)
2918 /* we don't support 'my $x .= ...' */
2919 && ( o->op_type == OP_SASSIGN
2920 || !(targetop->op_private & OPpLVAL_INTRO))
2921 )
2922 is_targable = TRUE;
2923 }
2924
2925 if (topop->op_type == OP_STRINGIFY) {
2926 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2927 return;
2928 stringop = topop;
2929
2930 /* barf on unknown flags */
2931 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2932
2933 if ((topop->op_private & OPpTARGET_MY)) {
2934 if (o->op_type == OP_SASSIGN)
2935 return; /* can't have two assigns */
2936 targmyop = topop;
2937 }
2938
2939 private_flags |= OPpMULTICONCAT_STRINGIFY;
2940 parentop = topop;
2941 topop = cBINOPx(topop)->op_first;
2942 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2943 topop = OpSIBLING(topop);
2944 }
2945
2946 if (topop->op_type == OP_SPRINTF) {
2947 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2948 return;
2949 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2950 nargs = sprintf_info.nargs;
2951 total_len = sprintf_info.total_len;
2952 variant = sprintf_info.variant;
2953 utf8 = sprintf_info.utf8;
2954 is_sprintf = TRUE;
2955 private_flags |= OPpMULTICONCAT_FAKE;
2956 toparg = argp;
2957 /* we have an sprintf op rather than a concat optree.
2958 * Skip most of the code below which is associated with
2959 * processing that optree. We also skip phase 2, determining
2960 * whether its cost effective to optimise, since for sprintf,
2961 * multiconcat is *always* faster */
2962 goto create_aux;
2963 }
2964 /* note that even if the sprintf itself isn't multiconcatable,
2965 * the expression as a whole may be, e.g. in
2966 * $x .= sprintf("%d",...)
2967 * the sprintf op will be left as-is, but the concat/S op may
2968 * be upgraded to multiconcat
2969 */
2970 }
2971 else if (topop->op_type == OP_CONCAT) {
2972 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2973 return;
2974
2975 if ((topop->op_private & OPpTARGET_MY)) {
2976 if (o->op_type == OP_SASSIGN || targmyop)
2977 return; /* can't have two assigns */
2978 targmyop = topop;
2979 }
2980 }
2981
2982 /* Is it safe to convert a sassign/stringify/concat op into
2983 * a multiconcat? */
2984 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2985 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2986 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2987 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2988 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2989 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2990 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2991 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2992
2993 /* Now scan the down the tree looking for a series of
2994 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2995 * stacked). For example this tree:
2996 *
2997 * |
2998 * CONCAT/STACKED
2999 * |
3000 * CONCAT/STACKED -- EXPR5
3001 * |
3002 * CONCAT/STACKED -- EXPR4
3003 * |
3004 * CONCAT -- EXPR3
3005 * |
3006 * EXPR1 -- EXPR2
3007 *
3008 * corresponds to an expression like
3009 *
3010 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3011 *
3012 * Record info about each EXPR in args[]: in particular, whether it is
3013 * a stringifiable OP_CONST and if so what the const sv is.
3014 *
3015 * The reason why the last concat can't be STACKED is the difference
3016 * between
3017 *
3018 * ((($a .= $a) .= $a) .= $a) .= $a
3019 *
3020 * and
3021 * $a . $a . $a . $a . $a
3022 *
3023 * The main difference between the optrees for those two constructs
3024 * is the presence of the last STACKED. As well as modifying $a,
3025 * the former sees the changed $a between each concat, so if $s is
3026 * initially 'a', the first returns 'a' x 16, while the latter returns
3027 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3028 */
3029
3030 kid = topop;
3031
3032 for (;;) {
3033 OP *argop;
3034 SV *sv;
3035 bool last = FALSE;
3036
3037 if ( kid->op_type == OP_CONCAT
3038 && !kid_is_last
3039 ) {
3040 OP *k1, *k2;
3041 k1 = cUNOPx(kid)->op_first;
3042 k2 = OpSIBLING(k1);
3043 /* shouldn't happen except maybe after compile err? */
3044 if (!k2)
3045 return;
3046
3047 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3048 if (kid->op_private & OPpTARGET_MY)
3049 kid_is_last = TRUE;
3050
3051 stacked_last = (kid->op_flags & OPf_STACKED);
3052 if (!stacked_last)
3053 kid_is_last = TRUE;
3054
3055 kid = k1;
3056 argop = k2;
3057 }
3058 else {
3059 argop = kid;
3060 last = TRUE;
3061 }
3062
f08f2d03 3063 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
e839e6ed
DM
3064 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3065 {
3066 /* At least two spare slots are needed to decompose both
3067 * concat args. If there are no slots left, continue to
3068 * examine the rest of the optree, but don't push new values
3069 * on args[]. If the optree as a whole is legal for conversion
3070 * (in particular that the last concat isn't STACKED), then
3071 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3072 * can be converted into an OP_MULTICONCAT now, with the first
3073 * child of that op being the remainder of the optree -
3074 * which may itself later be converted to a multiconcat op
3075 * too.
3076 */
3077 if (last) {
3078 /* the last arg is the rest of the optree */
3079 argp++->p = NULL;
3080 nargs++;
3081 }
3082 }
3083 else if ( argop->op_type == OP_CONST
3084 && ((sv = cSVOPx_sv(argop)))
3085 /* defer stringification until runtime of 'constant'
3086 * things that might stringify variantly, e.g. the radix
3087 * point of NVs, or overloaded RVs */
3088 && (SvPOK(sv) || SvIOK(sv))
3089 && (!SvGMAGICAL(sv))
3090 ) {
3091 argp++->p = sv;
3092 utf8 |= cBOOL(SvUTF8(sv));
3093 nconst++;
f08f2d03
DM
3094 if (prev_was_const)
3095 /* this const may be demoted back to a plain arg later;
3096 * make sure we have enough arg slots left */
3097 nadjconst++;
3098 prev_was_const = !prev_was_const;
e839e6ed
DM
3099 }
3100 else {
3101 argp++->p = NULL;
3102 nargs++;
f08f2d03 3103 prev_was_const = FALSE;
e839e6ed
DM
3104 }
3105
3106 if (last)
3107 break;
3108 }
3109
3110 toparg = argp - 1;
3111
3112 if (stacked_last)
3113 return; /* we don't support ((A.=B).=C)...) */
3114
bcc30fd0
DM
3115 /* look for two adjacent consts and don't fold them together:
3116 * $o . "a" . "b"
3117 * should do
3118 * $o->concat("a")->concat("b")
3119 * rather than
3120 * $o->concat("ab")
3121 * (but $o .= "a" . "b" should still fold)
3122 */
3123 {
3124 bool seen_nonconst = FALSE;
3125 for (argp = toparg; argp >= args; argp--) {
3126 if (argp->p == NULL) {
3127 seen_nonconst = TRUE;
3128 continue;
3129 }
3130 if (!seen_nonconst)
3131 continue;
3132 if (argp[1].p) {
3133 /* both previous and current arg were constants;
3134 * leave the current OP_CONST as-is */
3135 argp->p = NULL;
3136 nconst--;
3137 nargs++;
3138 }
3139 }
3140 }
3141
e839e6ed
DM
3142 /* -----------------------------------------------------------------
3143 * Phase 2:
3144 *
3145 * At this point we have determined that the optree *can* be converted
3146 * into a multiconcat. Having gathered all the evidence, we now decide
3147 * whether it *should*.
3148 */
3149
3150
3151 /* we need at least one concat action, e.g.:
3152 *
3153 * Y . Z
3154 * X = Y . Z
3155 * X .= Y
3156 *
3157 * otherwise we could be doing something like $x = "foo", which
3158 * if treated as as a concat, would fail to COW.
3159 */
3160 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3161 return;
3162
3163 /* Benchmarking seems to indicate that we gain if:
3164 * * we optimise at least two actions into a single multiconcat
3165 * (e.g concat+concat, sassign+concat);
3166 * * or if we can eliminate at least 1 OP_CONST;
3167 * * or if we can eliminate a padsv via OPpTARGET_MY
3168 */
3169
3170 if (
3171 /* eliminated at least one OP_CONST */
3172 nconst >= 1
3173 /* eliminated an OP_SASSIGN */
3174 || o->op_type == OP_SASSIGN
3175 /* eliminated an OP_PADSV */
3176 || (!targmyop && is_targable)
3177 )
3178 /* definitely a net gain to optimise */
3179 goto optimise;
3180
3181 /* ... if not, what else? */
3182
3183 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3184 * multiconcat is faster (due to not creating a temporary copy of
3185 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3186 * faster.
3187 */
3188 if ( nconst == 0
3189 && nargs == 2
3190 && targmyop
3191 && topop->op_type == OP_CONCAT
3192 ) {
3193 PADOFFSET t = targmyop->op_targ;
3194 OP *k1 = cBINOPx(topop)->op_first;
3195 OP *k2 = cBINOPx(topop)->op_last;
3196 if ( k2->op_type == OP_PADSV
3197 && k2->op_targ == t
3198 && ( k1->op_type != OP_PADSV
3199 || k1->op_targ != t)
3200 )
3201 goto optimise;
3202 }
3203
3204 /* need at least two concats */
3205 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3206 return;
3207
3208
3209
3210 /* -----------------------------------------------------------------
3211 * Phase 3:
3212 *
3213 * At this point the optree has been verified as ok to be optimised
3214 * into an OP_MULTICONCAT. Now start changing things.
3215 */
3216
3217 optimise:
3218
3219 /* stringify all const args and determine utf8ness */
3220
3221 variant = 0;
3222 for (argp = args; argp <= toparg; argp++) {
3223 SV *sv = (SV*)argp->p;
3224 if (!sv)
3225 continue; /* not a const op */
3226 if (utf8 && !SvUTF8(sv))
3227 sv_utf8_upgrade_nomg(sv);
3228 argp->p = SvPV_nomg(sv, argp->len);
3229 total_len += argp->len;
3230
3231 /* see if any strings would grow if converted to utf8 */
3232 if (!utf8) {
c1a88fe2
KW
3233 variant += variant_under_utf8_count((U8 *) argp->p,
3234 (U8 *) argp->p + argp->len);
e839e6ed
DM
3235 }
3236 }
3237
3238 /* create and populate aux struct */
3239
3240 create_aux:
3241
3242 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3243 sizeof(UNOP_AUX_item)
3244 * (
3245 PERL_MULTICONCAT_HEADER_SIZE
3246 + ((nargs + 1) * (variant ? 2 : 1))
3247 )
3248 );
6623aa6a 3249 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
e839e6ed
DM
3250
3251 /* Extract all the non-const expressions from the concat tree then
3252 * dispose of the old tree, e.g. convert the tree from this:
3253 *
3254 * o => SASSIGN
3255 * |
3256 * STRINGIFY -- TARGET
3257 * |
3258 * ex-PUSHMARK -- CONCAT
3259 * |
3260 * CONCAT -- EXPR5
3261 * |
3262 * CONCAT -- EXPR4
3263 * |
3264 * CONCAT -- EXPR3
3265 * |
3266 * EXPR1 -- EXPR2
3267 *
3268 *
3269 * to:
3270 *
3271 * o => MULTICONCAT
3272 * |
3273 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3274 *
3275 * except that if EXPRi is an OP_CONST, it's discarded.
3276 *
3277 * During the conversion process, EXPR ops are stripped from the tree
3278 * and unshifted onto o. Finally, any of o's remaining original
3279 * childen are discarded and o is converted into an OP_MULTICONCAT.
3280 *
3281 * In this middle of this, o may contain both: unshifted args on the
3282 * left, and some remaining original args on the right. lastkidop
3283 * is set to point to the right-most unshifted arg to delineate
3284 * between the two sets.
3285 */
3286
3287
3288 if (is_sprintf) {
3289 /* create a copy of the format with the %'s removed, and record
3290 * the sizes of the const string segments in the aux struct */
3291 char *q, *oldq;
3292 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3293
3294 p = sprintf_info.start;
3295 q = const_str;
3296 oldq = q;
3297 for (; p < sprintf_info.end; p++) {
3298 if (*p == '%') {
3299 p++;
3300 if (*p != '%') {
b5bf9f73 3301 (lenp++)->ssize = q - oldq;
e839e6ed
DM
3302 oldq = q;
3303 continue;
3304 }
3305 }
3306 *q++ = *p;
3307 }
b5bf9f73 3308 lenp->ssize = q - oldq;
e839e6ed
DM
3309 assert((STRLEN)(q - const_str) == total_len);
3310
3311 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3312 * may or may not be topop) The pushmark and const ops need to be
3313 * kept in case they're an op_next entry point.
3314 */
3315 lastkidop = cLISTOPx(topop)->op_last;
3316 kid = cUNOPx(topop)->op_first; /* pushmark */
3317 op_null(kid);
3318 op_null(OpSIBLING(kid)); /* const */
3319 if (o != topop) {
3320 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3321 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3322 lastkidop->op_next = o;
3323 }
3324 }
3325 else {
3326 p = const_str;
3327 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3328
b5bf9f73 3329 lenp->ssize = -1;
e839e6ed
DM
3330
3331 /* Concatenate all const strings into const_str.
3332 * Note that args[] contains the RHS args in reverse order, so
3333 * we scan args[] from top to bottom to get constant strings
3334 * in L-R order
3335 */
3336 for (argp = toparg; argp >= args; argp--) {
3337 if (!argp->p)
3338 /* not a const op */
b5bf9f73 3339 (++lenp)->ssize = -1;
e839e6ed
DM
3340 else {
3341 STRLEN l = argp->len;
3342 Copy(argp->p, p, l, char);
3343 p += l;
b5bf9f73
DM
3344 if (lenp->ssize == -1)
3345 lenp->ssize = l;
e839e6ed 3346 else
b5bf9f73 3347 lenp->ssize += l;
e839e6ed
DM
3348 }
3349 }
3350
3351 kid = topop;
3352 nextop = o;
3353 lastkidop = NULL;
3354
3355 for (argp = args; argp <= toparg; argp++) {
3356 /* only keep non-const args, except keep the first-in-next-chain
3357 * arg no matter what it is (but nulled if OP_CONST), because it
3358 * may be the entry point to this subtree from the previous
3359 * op_next.
3360 */
3361 bool last = (argp == toparg);
3362 OP *prev;
3363
3364 /* set prev to the sibling *before* the arg to be cut out,
789a38b6 3365 * e.g. when cutting EXPR:
e839e6ed
DM
3366 *
3367 * |
789a38b6 3368 * kid= CONCAT
e839e6ed 3369 * |
789a38b6 3370 * prev= CONCAT -- EXPR
e839e6ed
DM
3371 * |
3372 */
3373 if (argp == args && kid->op_type != OP_CONCAT) {
789a38b6 3374 /* in e.g. '$x .= f(1)' there's no RHS concat tree
e839e6ed
DM
3375 * so the expression to be cut isn't kid->op_last but
3376 * kid itself */
3377 OP *o1, *o2;
3378 /* find the op before kid */
3379 o1 = NULL;
3380 o2 = cUNOPx(parentop)->op_first;
3381 while (o2 && o2 != kid) {
3382 o1 = o2;
3383 o2 = OpSIBLING(o2);
3384 }
3385 assert(o2 == kid);
3386 prev = o1;
3387 kid = parentop;
3388 }
3389 else if (kid == o && lastkidop)
3390 prev = last ? lastkidop : OpSIBLING(lastkidop);
3391 else
3392 prev = last ? NULL : cUNOPx(kid)->op_first;
3393
3394 if (!argp->p || last) {
3395 /* cut RH op */
3396 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3397 /* and unshift to front of o */
3398 op_sibling_splice(o, NULL, 0, aop);
3399 /* record the right-most op added to o: later we will
3400 * free anything to the right of it */
3401 if (!lastkidop)
3402 lastkidop = aop;
3403 aop->op_next = nextop;
3404 if (last) {
3405 if (argp->p)
3406 /* null the const at start of op_next chain */
3407 op_null(aop);
3408 }
3409 else if (prev)
3410 nextop = prev->op_next;
3411 }
3412
3413 /* the last two arguments are both attached to the same concat op */
3414 if (argp < toparg - 1)
3415 kid = prev;
3416 }
3417 }
3418
3419 /* Populate the aux struct */
3420
ca84e88e 3421 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
e839e6ed 3422 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
b5bf9f73 3423 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
e839e6ed 3424 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
b5bf9f73 3425 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
e839e6ed
DM
3426
3427 /* if variant > 0, calculate a variant const string and lengths where
3428 * the utf8 version of the string will take 'variant' more bytes than
3429 * the plain one. */
3430
3431 if (variant) {
3432 char *p = const_str;
3433 STRLEN ulen = total_len + variant;
3434 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3435 UNOP_AUX_item *ulens = lens + (nargs + 1);
3436 char *up = (char*)PerlMemShared_malloc(ulen);
ca84e88e 3437 SSize_t n;
e839e6ed
DM
3438
3439 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
b5bf9f73 3440 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
e839e6ed
DM
3441
3442 for (n = 0; n < (nargs + 1); n++) {
576915da
DM
3443 SSize_t i;
3444 char * orig_up = up;
b5bf9f73 3445 for (i = (lens++)->ssize; i > 0; i--) {
e839e6ed 3446 U8 c = *p++;
576915da 3447 append_utf8_from_native_byte(c, (U8**)&up);
e839e6ed 3448 }
b5bf9f73 3449 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
e839e6ed
DM
3450 }
3451 }
3452
3453 if (stringop) {
3454 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3455 * that op's first child - an ex-PUSHMARK - because the op_next of
3456 * the previous op may point to it (i.e. it's the entry point for
3457 * the o optree)
3458 */
3459 OP *pmop =
3460 (stringop == o)
3461 ? op_sibling_splice(o, lastkidop, 1, NULL)
3462 : op_sibling_splice(stringop, NULL, 1, NULL);
3463 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3464 op_sibling_splice(o, NULL, 0, pmop);
3465 if (!lastkidop)
3466 lastkidop = pmop;
3467 }
3468
3469 /* Optimise
3470 * target = A.B.C...
3471 * target .= A.B.C...
3472 */
3473
3474 if (targetop) {
3475 assert(!targmyop);
3476
3477 if (o->op_type == OP_SASSIGN) {
3478 /* Move the target subtree from being the last of o's children
3479 * to being the last of o's preserved children.
3480 * Note the difference between 'target = ...' and 'target .= ...':
3481 * for the former, target is executed last; for the latter,
3482 * first.
3483 */
3484 kid = OpSIBLING(lastkidop);
3485 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3486 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3487 lastkidop->op_next = kid->op_next;
3488 lastkidop = targetop;
3489 }
3490 else {
3491 /* Move the target subtree from being the first of o's
3492 * original children to being the first of *all* o's children.
3493 */
3494 if (lastkidop) {
3495 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3496 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3497 }
3498 else {
3499 /* if the RHS of .= doesn't contain a concat (e.g.
3500 * $x .= "foo"), it gets missed by the "strip ops from the
3501 * tree and add to o" loop earlier */
3502 assert(topop->op_type != OP_CONCAT);
3503 if (stringop) {
3504 /* in e.g. $x .= "$y", move the $y expression
3505 * from being a child of OP_STRINGIFY to being the
3506 * second child of the OP_CONCAT
3507 */
3508 assert(cUNOPx(stringop)->op_first == topop);
3509 op_sibling_splice(stringop, NULL, 1, NULL);
3510 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3511 }
3512 assert(topop == OpSIBLING(cBINOPo->op_first));
3513 if (toparg->p)
3514 op_null(topop);
3515 lastkidop = topop;
3516 }
3517 }
3518
3519 if (is_targable) {
3520 /* optimise
3521 * my $lex = A.B.C...
3522 * $lex = A.B.C...
3523 * $lex .= A.B.C...
3524 * The original padsv op is kept but nulled in case it's the
3525 * entry point for the optree (which it will be for
3526 * '$lex .= ... '
3527 */
3528 private_flags |= OPpTARGET_MY;
3529 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3530 o->op_targ = targetop->op_targ;
3531 targetop->op_targ = 0;
3532 op_null(targetop);
3533 }
3534 else
3535 flags |= OPf_STACKED;
3536 }
3537 else if (targmyop) {
3538 private_flags |= OPpTARGET_MY;
3539 if (o != targmyop) {
3540 o->op_targ = targmyop->op_targ;
3541 targmyop->op_targ = 0;
3542 }
3543 }
3544
3545 /* detach the emaciated husk of the sprintf/concat optree and free it */
3546 for (;;) {
3547 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3548 if (!kid)
3549 break;
3550 op_free(kid);
3551 }
3552
3553 /* and convert o into a multiconcat */
3554
3555 o->op_flags = (flags|OPf_KIDS|stacked_last
3556 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3557 o->op_private = private_flags;
3558 o->op_type = OP_MULTICONCAT;
3559 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3560 cUNOP_AUXo->op_aux = aux;
3561}
3562
12ee5d32 3563
01f9673f
DM
3564/* do all the final processing on an optree (e.g. running the peephole
3565 * optimiser on it), then attach it to cv (if cv is non-null)
3566 */
3567
3568static void
3569S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3570{
3571 OP **startp;
3572
3573 /* XXX for some reason, evals, require and main optrees are
3574 * never attached to their CV; instead they just hang off
3575 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3576 * and get manually freed when appropriate */
3577 if (cv)
3578 startp = &CvSTART(cv);
3579 else
3580 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3581
3582 *startp = start;
3583 optree->op_private |= OPpREFCOUNTED;
3584 OpREFCNT_set(optree, 1);
d2905138 3585 optimize_optree(optree);
01f9673f
DM
3586 CALL_PEEP(*startp);
3587 finalize_optree(optree);
3588 S_prune_chain_head(startp);
3589
3590 if (cv) {
3591 /* now that optimizer has done its work, adjust pad values */
3592 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3593 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3594 }
3595}
3596
3597
3ad73efd 3598/*
d2905138
DM
3599=for apidoc optimize_optree
3600
3601This function applies some optimisations to the optree in top-down order.
3602It is called before the peephole optimizer, which processes ops in
3603execution order. Note that finalize_optree() also does a top-down scan,
3604but is called *after* the peephole optimizer.
3605
3606=cut
3607*/
3608
3609void
3610Perl_optimize_optree(pTHX_ OP* o)
3611{
3612 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3613
3614 ENTER;
3615 SAVEVPTR(PL_curcop);
3616
3617 optimize_op(o);
3618
3619 LEAVE;
3620}
3621
3622
6eebe43d 3623/* helper for optimize_optree() which optimises one op then recurses
d2905138
DM
3624 * to optimise any children.
3625 */
3626
3627STATIC void
3628S_optimize_op(pTHX_ OP* o)
3629{
6eebe43d 3630 OP *top_op = o;
d2905138
DM
3631
3632 PERL_ARGS_ASSERT_OPTIMIZE_OP;
6eebe43d
DM
3633
3634 while (1) {
3635 OP * next_kid = NULL;
3636
f2861c9b 3637 assert(o->op_type != OP_FREED);
d2905138 3638
f2861c9b
TC
3639 switch (o->op_type) {
3640 case OP_NEXTSTATE:
3641 case OP_DBSTATE:
3642 PL_curcop = ((COP*)o); /* for warnings */
3643 break;
d2905138
DM
3644
3645
f2861c9b
TC
3646 case OP_CONCAT:
3647 case OP_SASSIGN:
3648 case OP_STRINGIFY:
3649 case OP_SPRINTF:
3650 S_maybe_multiconcat(aTHX_ o);
3651 break;
e839e6ed 3652
f2861c9b 3653 case OP_SUBST:
6eebe43d
DM
3654 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3655 /* we can't assume that op_pmreplroot->op_sibparent == o
3656 * and that it is thus possible to walk back up the tree
3657 * past op_pmreplroot. So, although we try to avoid
3658 * recursing through op trees, do it here. After all,
3659 * there are unlikely to be many nested s///e's within
3660 * the replacement part of a s///e.
3661 */
3662 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3663 }
f2861c9b 3664 break;
d2905138 3665
f2861c9b
TC
3666 default:
3667 break;
3668 }
d2905138 3669
6eebe43d
DM
3670 if (o->op_flags & OPf_KIDS)
3671 next_kid = cUNOPo->op_first;
3672
3673 /* if a kid hasn't been nominated to process, continue with the
3674 * next sibling, or if no siblings left, go back to the parent's
3675 * siblings and so on
3676 */
3677 while (!next_kid) {
3678 if (o == top_op)
3679 return; /* at top; no parents/siblings to try */
3680 if (OpHAS_SIBLING(o))
3681 next_kid = o->op_sibparent;
3682 else
3683 o = o->op_sibparent; /*try parent's next sibling */
f2861c9b 3684 }
d2905138 3685
6eebe43d
DM
3686 /* this label not yet used. Goto here if any code above sets
3687 * next-kid
3688 get_next_op:
3689 */
3690 o = next_kid;
3691 }
d2905138
DM
3692}
3693
3694
3695/*
d164302a
GG
3696=for apidoc finalize_optree
3697
72d33970
FC
3698This function finalizes the optree. Should be called directly after
3699the complete optree is built. It does some additional
796b6530 3700checking which can't be done in the normal C<ck_>xxx functions and makes
d164302a
GG
3701the tree thread-safe.
3702
3703=cut
3704*/
3705void
3706Perl_finalize_optree(pTHX_ OP* o)
3707{
3708 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3709
3710 ENTER;
3711 SAVEVPTR(PL_curcop);
3712
3713 finalize_op(o);
3714
3715 LEAVE;
3716}
3717
b46e009d 3718#ifdef USE_ITHREADS
3719/* Relocate sv to the pad for thread safety.
3720 * Despite being a "constant", the SV is written to,
3721 * for reference counts, sv_upgrade() etc. */
3722PERL_STATIC_INLINE void
3723S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3724{
3725 PADOFFSET ix;
3726 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3727 if (!*svp) return;
3728 ix = pad_alloc(OP_CONST, SVf_READONLY);
3729 SvREFCNT_dec(PAD_SVl(ix));
3730 PAD_SETSV(ix, *svp);
3731 /* XXX I don't know how this isn't readonly already. */
3732 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3733 *svp = NULL;
3734 *targp = ix;
3735}
3736#endif
3737
7f8280cf 3738/*
44170c9a 3739=for apidoc traverse_op_tree
7f8280cf
TC
3740
3741Return the next op in a depth-first traversal of the op tree,
3742returning NULL when the traversal is complete.
3743
3744The initial call must supply the root of the tree as both top and o.
3745
3746For now it's static, but it may be exposed to the API in the future.
3747
3748=cut
3749*/
3750
3751STATIC OP*
35c1827f 3752S_traverse_op_tree(pTHX_ OP *top, OP *o) {
7f8280cf
TC
3753 OP *sib;
3754
3755 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3756
3757 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3758 return cUNOPo->op_first;
3759 }
3760 else if ((sib = OpSIBLING(o))) {
3761 return sib;
3762 }
3763 else {
3764 OP *parent = o->op_sibparent;
3765 assert(!(o->op_moresib));
3766 while (parent && parent != top) {
3767 OP *sib = OpSIBLING(parent);
3768 if (sib)
3769 return sib;
3770 parent = parent->op_sibparent;
3771 }
3772
3773 return NULL;
3774 }
3775}
b46e009d 3776
60dde6b2 3777STATIC void
d164302a
GG
3778S_finalize_op(pTHX_ OP* o)
3779{
7f8280cf 3780 OP * const top = o;
d164302a
GG
3781 PERL_ARGS_ASSERT_FINALIZE_OP;
3782
7f8280cf 3783 do {
64242fed 3784 assert(o->op_type != OP_FREED);
d164302a 3785
64242fed
TC
3786 switch (o->op_type) {
3787 case OP_NEXTSTATE:
3788 case OP_DBSTATE:
3789 PL_curcop = ((COP*)o); /* for warnings */
3790 break;
3791 case OP_EXEC:
3792 if (OpHAS_SIBLING(o)) {
3793 OP *sib = OpSIBLING(o);
3794 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3795 && ckWARN(WARN_EXEC)
3796 && OpHAS_SIBLING(sib))
3797 {
e6dae479 3798 const OPCODE type = OpSIBLING(sib)->op_type;
d164302a
GG
3799 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3800 const line_t oldline = CopLINE(PL_curcop);
1ed44841 3801 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
3802 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3803 "Statement unlikely to be reached");
3804 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3805 "\t(Maybe you meant system() when you said exec()?)\n");
3806 CopLINE_set(PL_curcop, oldline);
3807 }
64242fed
TC
3808 }
3809 }
3810 break;
d164302a 3811
64242fed
TC
3812 case OP_GV:
3813 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3814 GV * const gv = cGVOPo_gv;
3815 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3816 /* XXX could check prototype here instead of just carping */
3817 SV * const sv = sv_newmortal();
3818 gv_efullname3(sv, gv, NULL);
3819 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3820 "%" SVf "() called too early to check prototype",
3821 SVfARG(sv));
3822 }
3823 }
3824 break;
d164302a 3825
64242fed
TC
3826 case OP_CONST:
3827 if (cSVOPo->op_private & OPpCONST_STRICT)
3828 no_bareword_allowed(o);
d164302a 3829#ifdef USE_ITHREADS
64242fed
TC
3830 /* FALLTHROUGH */
3831 case OP_HINTSEVAL:
3832 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
b46e009d 3833#endif
64242fed 3834 break;
b46e009d 3835
3836#ifdef USE_ITHREADS
64242fed
TC
3837 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3838 case OP_METHOD_NAMED:
3839 case OP_METHOD_SUPER:
3840 case OP_METHOD_REDIR:
3841 case OP_METHOD_REDIR_SUPER:
3842 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3843 break;
d164302a 3844#endif
d164302a 3845
64242fed
TC
3846 case OP_HELEM: {
3847 UNOP *rop;
3848 SVOP *key_op;
3849 OP *kid;
d164302a 3850
64242fed
TC
3851 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3852 break;
d164302a 3853
64242fed 3854 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 3855
64242fed 3856 goto check_keys;
d164302a 3857
64242fed
TC
3858 case OP_HSLICE:
3859 S_scalar_slice_warning(aTHX_ o);
3860 /* FALLTHROUGH */
429a2555 3861
64242fed
TC
3862 case OP_KVHSLICE:
3863 kid = OpSIBLING(cLISTOPo->op_first);
3864 if (/* I bet there's always a pushmark... */
3865 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3866 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3867 {
3868 break;
3869 }
565e6f7e 3870
64242fed
TC
3871 key_op = (SVOP*)(kid->op_type == OP_CONST
3872 ? kid
3873 : OpSIBLING(kLISTOP->op_first));
565e6f7e 3874
64242fed 3875 rop = (UNOP*)((LISTOP*)o)->op_last;
565e6f7e 3876
64242fed
TC
3877 check_keys:
3878 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3879 rop = NULL;
02a9632a 3880 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
64242fed
TC
3881 break;
3882 }
3883 case OP_NULL:
3884 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3885 break;
3886 /* FALLTHROUGH */
3887 case OP_ASLICE:
3888 S_scalar_slice_warning(aTHX_ o);
3889 break;
a7fd8ef6 3890
64242fed
TC
3891 case OP_SUBST: {
3892 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3893 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3894 break;
3895 }
3896 default:
3897 break;
3898 }
d164302a 3899
7f8280cf 3900#ifdef DEBUGGING
64242fed
TC
3901 if (o->op_flags & OPf_KIDS) {
3902 OP *kid;
3903
3904 /* check that op_last points to the last sibling, and that
3905 * the last op_sibling/op_sibparent field points back to the
3906 * parent, and that the only ops with KIDS are those which are
3907 * entitled to them */
3908 U32 type = o->op_type;
3909 U32 family;
3910 bool has_last;
3911
3912 if (type == OP_NULL) {
3913 type = o->op_targ;
3914 /* ck_glob creates a null UNOP with ex-type GLOB
3915 * (which is a list op. So pretend it wasn't a listop */
3916 if (type == OP_GLOB)
3917 type = OP_NULL;
3918 }
3919 family = PL_opargs[type] & OA_CLASS_MASK;
3920
3921 has_last = ( family == OA_BINOP
3922 || family == OA_LISTOP
3923 || family == OA_PMOP
3924 || family == OA_LOOP
3925 );
3926 assert( has_last /* has op_first and op_last, or ...
3927 ... has (or may have) op_first: */
3928 || family == OA_UNOP
3929 || family == OA_UNOP_AUX
3930 || family == OA_LOGOP
3931 || family == OA_BASEOP_OR_UNOP
3932 || family == OA_FILESTATOP
3933 || family == OA_LOOPEXOP
3934 || family == OA_METHOP
3935 || type == OP_CUSTOM
3936 || type == OP_NULL /* new_logop does this */
3937 );
3938
3939 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3940 if (!OpHAS_SIBLING(kid)) {
3941 if (has_last)
3942 assert(kid == cLISTOPo->op_last);
3943 assert(kid->op_sibparent == o);
3944 }
20220689 3945 }
c4b20975 3946 }
7f8280cf
TC
3947#endif
3948 } while (( o = traverse_op_tree(top, o)) != NULL);
d164302a
GG
3949}
3950
03414f05
FC
3951static void
3952S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3953{
3954 CV *cv = PL_compcv;
3955 PadnameLVALUE_on(pn);
3956 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3957 cv = CvOUTSIDE(cv);
aea0412a
DM
3958 /* RT #127786: cv can be NULL due to an eval within the DB package
3959 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3960 * unless they contain an eval, but calling eval within DB
3961 * pretends the eval was done in the caller's scope.
3962 */
3963 if (!cv)
3964 break;
03414f05
FC
3965 assert(CvPADLIST(cv));
3966 pn =
3967 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3968 assert(PadnameLEN(pn));
3969 PadnameLVALUE_on(pn);
3970 }
3971}
3972
375879aa
FC
3973static bool
3974S_vivifies(const OPCODE type)
3975{
3976 switch(type) {
3977 case OP_RV2AV: case OP_ASLICE:
3978 case OP_RV2HV: case OP_KVASLICE:
3979 case OP_RV2SV: case OP_HSLICE:
3980 case OP_AELEMFAST: case OP_KVHSLICE:
3981 case OP_HELEM:
3982 case OP_AELEM:
3983 return 1;
3984 }
3985 return 0;
3986}
3987
11912a83
DM
3988
3989/* apply lvalue reference (aliasing) context to the optree o.
3990 * E.g. in
3991 * \($x,$y) = (...)
3992 * o would be the list ($x,$y) and type would be OP_AASSIGN.
3993 * It may descend and apply this to children too, for example in