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