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