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