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