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