/* rounds up to nearest pointer */
#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
-#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+
+#define DIFF(o,p) \
+ (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
+ ((size_t)((I32 **)(p) - (I32**)(o))))
/* requires double parens and aTHX_ */
#define DEBUG_S_warn(args) \
PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
)
+/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
+#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
+
+/* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
+#define OpSLABSizeBytes(sz) \
+ ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
/* malloc a new op slab (suitable for attaching to PL_compcv).
- * sz is in units of pointers */
+ * sz is in units of pointers from the beginning of opslab_opslots */
static OPSLAB *
S_new_slab(pTHX_ OPSLAB *head, size_t sz)
{
OPSLAB *slab;
+ size_t sz_bytes = OpSLABSizeBytes(sz);
/* opslot_offset is only U16 */
- assert(sz < U16_MAX);
+ assert(sz < U16_MAX);
+ /* room for at least one op */
+ assert(sz >= OPSLOT_SIZE_BASE);
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
+ slab = (OPSLAB *) mmap(0, sz_bytes,
PROT_READ|PROT_WRITE,
MAP_ANON|MAP_PRIVATE, -1, 0);
DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
abort();
}
#else
- slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+ slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
+ Zero(slab, sz_bytes, char);
#endif
slab->opslab_size = (U16)sz;
/* The context is unused in non-Windows */
PERL_UNUSED_CONTEXT;
#endif
- slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
+ slab->opslab_free_space = sz;
slab->opslab_head = head ? head : slab;
DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
(unsigned int)slab->opslab_size, (void*)slab,
return slab;
}
-/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
-#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
#define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
#define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
OPSLAB *slab2;
OPSLOT *slot;
OP *o;
- size_t opsz;
+ size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
/* We only allocate ops from the slab during subroutine compilation.
We find the slab via PL_compcv, hence that must be non-NULL. It could
}
else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
- opsz = SIZE_TO_PSIZE(sz);
- sz = opsz + OPSLOT_HEADER_P;
+ sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
/* The head slab for each CV maintains a free list of OPs. In particular, constant folding
will free up OPs, so it makes sense to re-use them where possible. A
freed up slot is used in preference to a new allocation. */
if (head_slab->opslab_freed &&
- OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
+ OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
U16 base_index;
/* look for a large enough size with any freed ops */
- for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
+ for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
++base_index) {
}
o = head_slab->opslab_freed[base_index];
DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
- (void*)o,
- (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
- (void*)head_slab));
+ (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
head_slab->opslab_freed[base_index] = o->op_next;
- Zero(o, opsz, I32 *);
+ Zero(o, sz, char);
o->op_slabbed = 1;
goto gotit;
}
}
#define INIT_OPSLOT(s) \
- slot->opslot_offset = DIFF(slab2, slot) ; \
+ slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \
slot->opslot_size = s; \
slab2->opslab_free_space -= s; \
o = &slot->opslot_op; \
/* The partially-filled slab is next in the chain. */
slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
- if (slab2->opslab_free_space < sz) {
+ if (slab2->opslab_free_space < sz_in_p) {
/* Remaining space is too small. */
/* If we can fit a BASEOP, add it to the free chain, so as not
to waste it. */
- if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+ if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
slot = &slab2->opslab_slots;
INIT_OPSLOT(slab2->opslab_free_space);
o->op_type = OP_FREED;
+ DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
+ (void *)o, (void *)slab2, (void *)head_slab));
link_freed_op(head_slab, o);
}
slab2->opslab_next = head_slab->opslab_next;
head_slab->opslab_next = slab2;
}
- assert(slab2->opslab_size >= sz);
+ assert(slab2->opslab_size >= sz_in_p);
/* Create a new op slot */
- slot = (OPSLOT *)
- ((I32 **)&slab2->opslab_slots
- + slab2->opslab_free_space - sz);
+ slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
assert(slot >= &slab2->opslab_slots);
- INIT_OPSLOT(sz);
+ INIT_OPSLOT(sz_in_p);
DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
(void*)o, (void*)slab2, (void*)head_slab));
slab->opslab_readonly = 1;
for (; slab; slab = slab->opslab_next) {
/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
- (unsigned long) slab->opslab_size, slab));*/
- if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
- Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
+ (unsigned long) slab->opslab_size, (void *)slab));*/
+ if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
+ Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
(unsigned long)slab->opslab_size, errno);
}
}
slab2 = slab;
for (; slab2; slab2 = slab2->opslab_next) {
/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
- (unsigned long) size, slab2));*/
- if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
+ (unsigned long) size, (void *)slab2));*/
+ if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
PROT_READ|PROT_WRITE)) {
- Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
+ Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
(unsigned long)slab2->opslab_size, errno);
}
}
o->op_type = OP_FREED;
link_freed_op(slab, o);
DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
- (void*)o,
- (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
- (void*)slab));
+ (void*)o, (void *)OpMySLAB(o), (void*)slab));
OpslabREFCNT_dec_padok(slab);
}
#ifdef PERL_DEBUG_READONLY_OPS
DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
(void*)slab));
- if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
+ if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
perror("munmap failed");
abort();
}
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
- OPSLOT *slot = (OPSLOT*)
- ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
- OPSLOT *end = (OPSLOT*)
- ((I32**)slab2 + slab2->opslab_size);
+ OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
+ OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size);
for (; slot < end;
slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
{
(int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
}
-/* remove flags var, its unused in all callers, move to to right end since gv
- and kid are always the same */
STATIC void
S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
{
}
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section Optree Manipulation Functions
=for apidoc alloccopstash
void
Perl_op_free(pTHX_ OP *o)
{
- dVAR;
OPCODE type;
OP *top_op = o;
OP *next_op = o;
Perl_op_clear(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_OP_CLEAR;
void
Perl_op_null(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_OP_NULL;
PERL_TSA_ACQUIRE(PL_op_mutex)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
PERL_TSA_RELEASE(PL_op_mutex)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_UNLOCK;
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes. Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
-children. The last deleted node will be marked as as the last node by
+children. The last deleted node will be marked as the last node by
updating the op_sibling/op_sibparent or op_moresib field as appropriate.
Note that op_next is not manipulated, and nodes are not freed; that is the
LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
- dVAR;
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
OP *
Perl_scalarvoid(pTHX_ OP *arg)
{
- dVAR;
OP *kid;
SV* sv;
OP *o = arg;
STATIC void
S_maybe_multiconcat(pTHX_ OP *o)
{
- dVAR;
OP *lastkidop; /* the right-most of any kids unshifted onto o */
OP *topop; /* the top-most op in the concat tree (often equals o,
unless there are assign/stringify ops above it */
}
if (targetop) {
- /* Can targetop (the LHS) if it's a padsv, be be optimised
+ /* Can targetop (the LHS) if it's a padsv, be optimised
* away and use OPpTARGET_MY instead?
*/
if ( (targetop->op_type == OP_PADSV)
* X .= Y
*
* otherwise we could be doing something like $x = "foo", which
- * if treated as as a concat, would fail to COW.
+ * if treated as a concat, would fail to COW.
*/
if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
return;
static void
S_lvref(pTHX_ OP *o, I32 type)
{
- dVAR;
OP *kid;
OP * top_op = o;
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
- dVAR;
OP *top_op = o;
if (!o || (PL_parser && PL_parser->error_count))
OP *
Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
- dVAR;
OP * top_op = o;
PERL_ARGS_ASSERT_DOREF;
OP *
Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
{
- dVAR;
BINOP *bop;
OP *op;
OP *
Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
{
- dVAR;
BINOP *bop;
OP *op;
OP *
Perl_cmpchain_finish(pTHX_ OP *ch)
{
- dVAR;
PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
if (ch->op_type != OP_NULL) {
OP *
Perl_op_scope(pTHX_ OP *o)
{
- dVAR;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ,
}
/*
-=head1 Compile-time scope hooks
+=for apidoc_section Compile-time scope hooks
=for apidoc blockhook_register
PERL_ARGS_ASSERT_JMAYBE;
if (o->op_type == OP_LIST) {
- OP * const o2
- = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
- o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
+ OP * const o2
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
+ o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ }
+ else {
+ /* If the user disables this, then a warning might not be enough to alert
+ them to a possible change of behaviour here, so throw an exception.
+ */
+ yyerror("Multidimensional hash lookup is disabled");
+ }
}
return o;
}
/* integerize op. */
if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
{
- dVAR;
o->op_ppaddr = PL_ppaddr[++(o->op_type)];
}
static OP *
S_fold_constants(pTHX_ OP *const o)
{
- dVAR;
OP *curop;
OP *newop;
I32 type = o->op_type;
static void
S_gen_constant_list(pTHX_ OP *o)
{
- dVAR;
OP *curop, *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
}
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section Optree Manipulation Functions
*/
/* List constructors */
OP *
Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
{
- dVAR;
if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
o = force_list(o, 0);
/*
-=head1 Optree construction
+=for apidoc_section Optree construction
=for apidoc newNULLLIST
OP *
Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
- dVAR;
LISTOP *listop;
/* Note that allocating an OP_PUSHMARK can die under Safe.pm if
* pushmark is banned. So do it now while existing ops are in a
OP *
Perl_newOP(pTHX_ I32 type, I32 flags)
{
- dVAR;
OP *o;
if (type == -OP_ENTEREVAL) {
OP *
Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
{
- dVAR;
UNOP *unop;
if (type == -OP_ENTEREVAL) {
OP *
Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
{
- dVAR;
UNOP_AUX *unop;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
static OP*
S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
- dVAR;
METHOP *methop;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
OP *
Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
- dVAR;
BINOP *binop;
ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
* One of the important characteristics to know about the input is whether
* the transliteration may be done in place, or does a temporary need to be
* allocated, then copied. If the replacement for every character in every
- * possible string takes up no more bytes than the the character it
+ * possible string takes up no more bytes than the character it
* replaces, then it can be edited in place. Otherwise the replacement
* could overwrite a byte we are about to read, depending on the strings
* being processed. The comments and variable names here refer to this as
* these up into smaller chunks, but doesn't merge any together. This
* makes it easy to find the instances it's looking for. A second pass is
* done after this has been determined which merges things together to
- * shrink the table for runtime. For ASCII platforms, the table is
- * trivial, given below, and uses the fundamental characteristics of UTF-8
- * to construct the values. For EBCDIC, it isn't so, and we rely on a
- * table constructed by the perl script that generates these kinds of
- * things */
-#ifndef EBCDIC
+ * shrink the table for runtime. The table below is used for both ASCII
+ * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
+ * increasing for code points below 256. To correct for that, the macro
+ * CP_ADJUST defined below converts those code points to ASCII in the first
+ * pass, and we use the ASCII partition values. That works because the
+ * growth factor will be unaffected, which is all that is calculated during
+ * the first pass. */
UV PL_partition_by_byte_length[] = {
0,
0x80, /* Below this is 1 byte representations */
};
-#endif
-
PERL_ARGS_ASSERT_PMTRANS;
PL_hints |= HINT_BLOCK_SCOPE;
t_array = invlist_array(t_invlist);
}
+/* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
+ * so as to get the well-behaved length 1 vs length 2 boundary. Only code
+ * points below 256 differ between the two character sets in this regard. For
+ * these, we also can't have any ranges, as they have to be individually
+ * converted. */
+#ifdef EBCDIC
+# define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
+# define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
+# define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
+#else
+# define CP_ADJUST(x) (x)
+# define FORCE_RANGE_LEN_1(x) 0
+# define CP_SKIP(x) UVCHR_SKIP(x)
+#endif
+
/* And the mapping of each of the ranges is initialized. Initially,
* everything is TR_UNLISTED. */
for (i = 0; i < len; i++) {
/* Here, not in the middle of a range, and not UTF-8. The
* next code point is the single byte where we're at */
- t_cp = *t;
+ t_cp = CP_ADJUST(*t);
t_range_count = 1;
t++;
}
* next code point is the next UTF-8 char in the input. We
* know the input is valid, because the toker constructed
* it */
- t_cp = valid_utf8_to_uvchr(t, &t_char_len);
+ t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
t += t_char_len;
/* UTF-8 strings (only) have been parsed in toke.c to have
* the first element of a range. If so, get the final
* element and calculate the range size. If not, the range
* size is 1 */
- if (t < tend && *t == RANGE_INDICATOR) {
+ if ( t < tend && *t == RANGE_INDICATOR
+ && ! FORCE_RANGE_LEN_1(t_cp))
+ {
t++;
t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
- t_cp + 1;
}
else {
if (! rstr_utf8) {
- r_cp = *r;
+ r_cp = CP_ADJUST(*r);
r_range_count = 1;
r++;
}
else {
Size_t r_char_len;
- r_cp = valid_utf8_to_uvchr(r, &r_char_len);
+ r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
r += r_char_len;
- if (r < rend && *r == RANGE_INDICATOR) {
+ if ( r < rend && *r == RANGE_INDICATOR
+ && ! FORCE_RANGE_LEN_1(r_cp))
+ {
r++;
r_range_count = valid_utf8_to_uvchr(r,
&r_char_len) - r_cp + 1;
* code point in the rhs against any code point in the lhs. */
if ( ! pass2
&& r_cp_end != TR_SPECIAL_HANDLING
- && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end))
+ && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
{
/* Here, we will need to make a copy of the input string
* before doing the transliteration. The worst possible
* string not being UTF-8 */
NV t_size = (can_force_utf8 && t_cp < 256)
? 1
- : UVCHR_SKIP(t_cp_end);
- NV ratio = UVCHR_SKIP(r_cp_end) / t_size;
+ : CP_SKIP(t_cp_end);
+ NV ratio = CP_SKIP(r_cp_end) / t_size;
o->op_private |= OPpTRANS_GROWS;
* is if it 'grows'. But in the 2nd pass, there's no
* reason to not merge */
if ( (i > 0 && ( pass2
- || UVCHR_SKIP(t_array[i-1])
- == UVCHR_SKIP(t_cp)))
+ || CP_SKIP(t_array[i-1])
+ == CP_SKIP(t_cp)))
&& ( ( r_cp == TR_SPECIAL_HANDLING
&& r_map[i-1] == TR_SPECIAL_HANDLING)
|| ( r_cp != TR_SPECIAL_HANDLING
adjacent_to_range_above = TRUE;
if (i + 1 < len)
if ( ( pass2
- || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1]))
+ || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
&& ( ( r_cp == TR_SPECIAL_HANDLING
&& r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
|| ( r_cp != TR_SPECIAL_HANDLING
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
- dVAR;
PMOP *pmop;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
} else {
SV * const repointer = &PL_sv_undef;
av_push(PL_regex_padav, repointer);
- pmop->op_pmoffset = av_tindex(PL_regex_padav);
+ pmop->op_pmoffset = av_top_index(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
OP *
Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
{
- dVAR;
SVOP *svop;
PERL_ARGS_ASSERT_NEWSVOP;
OP *
Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
{
- dVAR;
PADOP *padop;
PERL_ARGS_ASSERT_NEWPADOP;
OP *
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
- dVAR;
const bool utf8 = cBOOL(flags & SVf_UTF8);
PVOP *pvop;
}
/*
-=head1 Embedding Functions
+=for apidoc_section Embedding and Interpreter Cloning
=for apidoc load_module
=for apidoc Amnh||PERL_LOADMOD_NOIMPORT
=for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
+=for apidoc vload_module
+Like C<L</load_module>> but the arguments are an encapsulated argument list.
+
+=for apidoc load_module_nocontext
+Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut */
void
}
/*
-=head1 Optree construction
+=for apidoc_section Optree construction
=for apidoc newSLICEOP
static OP *
S_newONCEOP(pTHX_ OP *initop, OP *padop)
{
- dVAR;
const PADOFFSET target = padop->op_targ;
OP *const other = newOP(OP_PADSV,
padop->op_flags
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
- dVAR;
const U32 seq = intro_my();
const U32 utf8 = flags & SVf_UTF8;
COP *cop;
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
- dVAR;
LOGOP *logop;
OP *o;
OP *first;
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
- dVAR;
LOGOP *logop;
OP *start;
OP *o;
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
OP *expr, OP *block, OP *cont, I32 has_my)
{
- dVAR;
OP *redo;
OP *next = NULL;
OP *listop;
OP *
Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
{
- dVAR;
LOOP *loop;
OP *wop;
PADOFFSET padoff = 0;
* keep it in-place if there's space */
if (loop->op_slabbed
&& OpSLOT(loop)->opslot_size
- < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
+ < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
{
/* no space; allocate new op */
LOOP *tmp;
I32 enter_opcode, I32 leave_opcode,
PADOFFSET entertarg)
{
- dVAR;
LOGOP *enterop;
OP *o;
/*
-=head1 Optree Manipulation Functions
+=for apidoc_section Optree Manipulation Functions
=for apidoc cv_const_sv
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
- dVAR;
U32 hash;
PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
CvNAME_HEK_set(*spot, hek =
if (!CvNAME_HEK(cv)) {
if (hek) (void)share_hek_hek(hek);
else {
- dVAR;
U32 hash;
PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
hek = share_hek(PadnamePV(name)+1,
If C<o_is_gv> is false and C<o> is null, then the subroutine will
be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
-must point to a C<const> op, which will be consumed by this function,
+must point to a C<const> OP, which will be consumed by this function,
and its string value supplies a name for the subroutine. The name may
be qualified or unqualified, and if it is unqualified then a default
stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
any use of the returned pointer. It is the caller's responsibility to
ensure that it knows which of these situations applies.
+=for apidoc newATTRSUB
+Construct a Perl subroutine, also performing some surrounding jobs.
+
+This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
+FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
+the name will be derived from C<o> in the way described (as with all other
+details) in L<perlintern/C<newATTRSUB_x>>.
+
+=for apidoc newSUB
+Like C<L</newATTRSUB>>, but without attributes.
+
=cut
*/
assert(CvGV(cv) == gv);
}
else {
- dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv,
if (isGV(gv))
CvGV_set(cv, gv);
else {
- dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv, share_hek(name,
OP *
Perl_oopsAV(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_OOPSAV;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_OOPSHV;
OP *
Perl_newAVREF(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_NEWAVREF;
OP *
Perl_newHVREF(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_NEWHVREF;
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
if (o->op_type == OP_PADANY) {
- dVAR;
OpTYPE_set(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
OP *
Perl_newSVREF(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_NEWSVREF;
OP *
Perl_ck_spair(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_CK_SPAIR;
OP *
Perl_ck_eval(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_CK_EVAL;
OP *
Perl_ck_rvconst(pTHX_ OP *o)
{
- dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
PERL_ARGS_ASSERT_CK_RVCONST;
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
- dVAR;
const I32 type = o->op_type;
PERL_ARGS_ASSERT_CK_FTST;
OP *
Perl_ck_smartmatch(pTHX_ OP *o)
{
- dVAR;
PERL_ARGS_ASSERT_CK_SMARTMATCH;
if (0 == (o->op_flags & OPf_SPECIAL)) {
OP *first = cBINOPo->op_first;
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
- dVAR;
OP * const kid = cBINOPo->op_first;
PERL_ARGS_ASSERT_CK_SASSIGN;
SV * const sv = kid->op_sv;
U32 const was_readonly = SvREADONLY(sv);
if (kid->op_private & OPpCONST_BARE) {
- dVAR;
const char *end;
HEK *hek;
SvREFCNT_dec_NN(sv);
}
else {
- dVAR;
HEK *hek;
if (was_readonly) SvREADONLY_off(sv);
PERL_HASH(hash, s, len);
OP *
Perl_ck_select(pTHX_ OP *o)
{
- dVAR;
OP* kid;
PERL_ARGS_ASSERT_CK_SELECT;
OP *
Perl_ck_split(pTHX_ OP *o)
{
- dVAR;
OP *kid;
OP *sibs;
if (CvISXSUB(cv) || !CvROOT(cv))
S_entersub_alloc_targ(aTHX_ o);
if (!namegv) {
- /* The original call checker API guarantees that a GV will be
+ /* The original call checker API guarantees that a GV will
be provided with the right name. So, if the old API was
used (or the REQUIRE_GV flag was passed), we have to reify
the CV’s GV, unless this is an anonymous sub. This is not
OP *
Perl_ck_each(pTHX_ OP *o)
{
- dVAR;
OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
const unsigned orig_type = o->op_type;
goto do_next;
case OP_UNDEF:
- /* undef counts as a scalar on the RHS:
- * (undef, $x) = ...; # only 1 scalar on LHS: always safe
+ /* undef on LHS following a var is significant, e.g.
+ * my $x = 1;
+ * @a = (($x, undef) = (2 => $x));
+ * # @a shoul be (2,1) not (2,2)
+ *
+ * undef on RHS counts as a scalar:
* ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
*/
- if (rhs)
+ if ((!rhs && *scalars_p) || rhs)
(*scalars_p)++;
flags = AAS_SAFE_SCALAR;
break;
}
/* if its an unrecognised, non-dangerous op, assume that it
- * it the cause of at least one safe scalar */
+ * is the cause of at least one safe scalar */
(*scalars_p)++;
flags = AAS_SAFE_SCALAR;
break;
STATIC void
S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
{
- dVAR;
int pass;
UNOP_AUX_item *arg_buf = NULL;
bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
void
Perl_rpeep(pTHX_ OP *o)
{
- dVAR;
OP* oldop = NULL;
OP* oldoldop = NULL;
OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
}
/*
-=head1 Custom Operators
+=for apidoc_section Custom Operators
=for apidoc Perl_custom_op_xop
Return the XOP structure for a given custom op. This macro should be
}
/*
-=head1 Hook manipulation
+=for apidoc_section Hook manipulation
These functions provide convenient and thread-safe means of manipulating
hook variables.
Perl_wrap_op_checker(pTHX_ Optype opcode,
Perl_check_t new_checker, Perl_check_t *old_checker_p)
{
- dVAR;
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
https://perl5.git.perl.org / perl5.git / blobdiff