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