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