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