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