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