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