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