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