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