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