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