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