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