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