/* 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
=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_op_refcnt_lock(pTHX)
PERL_TSA_ACQUIRE(PL_op_mutex)
{
-#ifdef USE_ITHREADS
- dVAR;
-#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
}
Perl_op_refcnt_unlock(pTHX)
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;
return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
+OP *
+Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
+{
+ BINOP *bop;
+ OP *op;
+
+ if (!left)
+ left = newOP(OP_NULL, 0);
+ if (!right)
+ right = newOP(OP_NULL, 0);
+ scalar(left);
+ scalar(right);
+ NewOp(0, bop, 1, BINOP);
+ op = (OP*)bop;
+ ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
+ OpTYPE_set(op, type);
+ cBINOPx(op)->op_flags = OPf_KIDS;
+ cBINOPx(op)->op_private = 2;
+ cBINOPx(op)->op_first = left;
+ cBINOPx(op)->op_last = right;
+ OpMORESIB_set(left, right);
+ OpLASTSIB_set(right, op);
+ return op;
+}
+
+OP *
+Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
+{
+ BINOP *bop;
+ OP *op;
+
+ PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
+ if (!right)
+ right = newOP(OP_NULL, 0);
+ scalar(right);
+ NewOp(0, bop, 1, BINOP);
+ op = (OP*)bop;
+ ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
+ OpTYPE_set(op, type);
+ if (ch->op_type != OP_NULL) {
+ UNOP *lch;
+ OP *nch, *cleft, *cright;
+ NewOp(0, lch, 1, UNOP);
+ nch = (OP*)lch;
+ OpTYPE_set(nch, OP_NULL);
+ nch->op_flags = OPf_KIDS;
+ cleft = cBINOPx(ch)->op_first;
+ cright = cBINOPx(ch)->op_last;
+ cBINOPx(ch)->op_first = NULL;
+ cBINOPx(ch)->op_last = NULL;
+ cBINOPx(ch)->op_private = 0;
+ cBINOPx(ch)->op_flags = 0;
+ cUNOPx(nch)->op_first = cright;
+ OpMORESIB_set(cright, ch);
+ OpMORESIB_set(ch, cleft);
+ OpLASTSIB_set(cleft, nch);
+ ch = nch;
+ }
+ OpMORESIB_set(right, op);
+ OpMORESIB_set(op, cUNOPx(ch)->op_first);
+ cUNOPx(ch)->op_first = right;
+ return ch;
+}
+
+OP *
+Perl_cmpchain_finish(pTHX_ OP *ch)
+{
+
+ PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
+ if (ch->op_type != OP_NULL) {
+ OPCODE cmpoptype = ch->op_type;
+ ch = CHECKOP(cmpoptype, ch);
+ if(!ch->op_next && ch->op_type == cmpoptype)
+ ch = fold_constants(op_integerize(op_std_init(ch)));
+ return ch;
+ } else {
+ OP *condop = NULL;
+ OP *rightarg = cUNOPx(ch)->op_first;
+ cUNOPx(ch)->op_first = OpSIBLING(rightarg);
+ OpLASTSIB_set(rightarg, NULL);
+ while (1) {
+ OP *cmpop = cUNOPx(ch)->op_first;
+ OP *leftarg = OpSIBLING(cmpop);
+ OPCODE cmpoptype = cmpop->op_type;
+ OP *nextrightarg;
+ bool is_last;
+ is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
+ OpLASTSIB_set(cmpop, NULL);
+ OpLASTSIB_set(leftarg, NULL);
+ if (is_last) {
+ ch->op_flags = 0;
+ op_free(ch);
+ nextrightarg = NULL;
+ } else {
+ nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
+ leftarg = newOP(OP_NULL, 0);
+ }
+ cBINOPx(cmpop)->op_first = leftarg;
+ cBINOPx(cmpop)->op_last = rightarg;
+ OpMORESIB_set(leftarg, rightarg);
+ OpLASTSIB_set(rightarg, cmpop);
+ cmpop->op_flags = OPf_KIDS;
+ cmpop->op_private = 2;
+ cmpop = CHECKOP(cmpoptype, cmpop);
+ if(!cmpop->op_next && cmpop->op_type == cmpoptype)
+ cmpop = op_integerize(op_std_init(cmpop));
+ condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
+ cmpop;
+ if (!nextrightarg)
+ return condop;
+ rightarg = nextrightarg;
+ }
+ }
+}
+
/*
=for apidoc op_scope
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 $scope
=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
*/
/* 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 "grow", depending on the strings being processed. Some inputs
- * won't grow, and might even shrink under /d, but some inputs could grow,
- * so we have to assume any given one might grow. On very long inputs, the
- * temporary could eat up a lot of memory, so we want to avoid it if
- * possible. For non-UTF-8 inputs, everything is single-byte, so can be
- * edited in place, unless there is something in the pattern that could
- * force it into UTF-8. The inversion map makes it feasible to determine
- * this. Previous versions of this code pretty much punted on determining
- * if UTF-8 could be edited in place. Now, this code is rigorous in making
- * that determination.
+ * 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
+ * "growing". Some inputs won't grow, and might even shrink under /d, but
+ * some inputs could grow, so we have to assume any given one might grow.
+ * On very long inputs, the temporary could eat up a lot of memory, so we
+ * want to avoid it if possible. For non-UTF-8 inputs, everything is
+ * single-byte, so can be edited in place, unless there is something in the
+ * pattern that could force it into UTF-8. The inversion map makes it
+ * feasible to determine this. Previous versions of this code pretty much
+ * punted on determining if UTF-8 could be edited in place. Now, this code
+ * is rigorous in making that determination.
*
* Another characteristic we need to know is whether the lhs and rhs are
* identical. If so, and no other flags are present, the only effect of
const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
- /* Set to true if there is some character < 256 in the lhs that maps to >
- * 255. If so, a non-UTF-8 match string can be forced into requiring to be
- * in UTF-8 by a tr/// operation. */
+ /* Set to true if there is some character < 256 in the lhs that maps to
+ * above 255. If so, a non-UTF-8 match string can be forced into being in
+ * UTF-8 by a tr/// operation. */
bool can_force_utf8 = FALSE;
/* What is the maximum expansion factor in UTF-8 transliterations. If a
* expansion factor is 1.5. This number is used at runtime to calculate
* how much space to allocate for non-inplace transliterations. Without
* this number, the worst case is 14, which is extremely unlikely to happen
- * in real life, and would require significant memory overhead. */
+ * in real life, and could require significant memory overhead. */
NV max_expansion = 1.;
UV t_range_count, r_range_count, min_range_count;
UV* t_array;
SV* t_invlist;
UV* r_map;
- UV r_cp, t_cp;
+ UV r_cp = 0, t_cp = 0;
UV t_cp_end = (UV) -1;
UV r_cp_end;
Size_t len;
* 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,
- (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))),
- (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),
- ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),
- ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),
- ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))
+ 0x80, /* Below this is 1 byte representations */
+ (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
+ (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
+ ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
+ ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
+ ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
# ifdef UV_IS_QUAD
,
- ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))
+ ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
# endif
};
-#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;
t_cp_end = MIN(IV_MAX, t_cp + span - 1);
if (r_cp == TR_SPECIAL_HANDLING) {
- r_cp_end = TR_SPECIAL_HANDLING;
+
+ /* If unmatched lhs code points map to the final map, use that
+ * value. This being set to TR_SPECIAL_HANDLING indicates that
+ * we don't have a final map: unmatched lhs code points are
+ * simply deleted */
+ r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
}
else {
r_cp_end = MIN(IV_MAX, r_cp + span - 1);
* we use the above sample data. The t_cp chunk must be any
* contiguous subset of M, N, O, P, and/or Q.
*
+ * In the first pass, calculate if there is any possible input
+ * string that has a character whose transliteration will be
+ * longer than it. If none, the transliteration may be done
+ * in-place, as it can't write over a so-far unread byte.
+ * Otherwise, a copy must first be made. This could be
+ * expensive for long inputs.
+ *
* In the first pass, the t_invlist has been partitioned so
* that all elements in any single range have the same number
* of bytes in their UTF-8 representations. And the r space is
* 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))
{
- /* Consider tr/\xCB/\X{E000}/. The maximum expansion
- * factor is 1 byte going to 3 if the lhs is not UTF-8, but
- * 2 bytes going to 3 if it is in UTF-8. We could pass two
- * different values so doop could choose based on the
- * UTF-8ness of the target. But khw thinks (perhaps
- * wrongly) that is overkill. It is used only to make sure
- * we malloc enough space. If no target string can force
- * the result to be UTF-8, then we don't have to worry
- * about this */
+ /* Here, we will need to make a copy of the input string
+ * before doing the transliteration. The worst possible
+ * case is an expansion ratio of 14:1. This is rare, and
+ * we'd rather allocate only the necessary amount of extra
+ * memory for that copy. We can calculate the worst case
+ * for this particular transliteration is by keeping track
+ * of the expansion factor for each range.
+ *
+ * Consider tr/\xCB/\X{E000}/. The maximum expansion
+ * factor is 1 byte going to 3 if the target string is not
+ * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
+ * could pass two different values so doop could choose
+ * based on the UTF-8ness of the target. But khw thinks
+ * (perhaps wrongly) that is overkill. It is used only to
+ * make sure we malloc enough space.
+ *
+ * If no target string can force the result to be UTF-8,
+ * then we don't have to worry about the case of the target
+ * 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
=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
=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,
(void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
-
- SAVEVPTR(PL_curcop);
- if (PL_curcop == &PL_compiling) {
- /* Avoid pushing the "global" &PL_compiling onto the
- * context stack. For example, a stack trace inside
- * nested use's would show all calls coming from whoever
- * most recently updated PL_compiling.cop_file and
- * cop_line. So instead, temporarily set PL_curcop to a
- * private copy of &PL_compiling. PL_curcop will soon be
- * set to point back to &PL_compiling anyway but only
- * after the temp value has been pushed onto the context
- * stack as blk_oldcop.
- * This is slightly hacky, but necessary. Note also
- * that in the brief window before PL_curcop is set back
- * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
- * will give the wrong answer.
- */
- Newx(PL_curcop, 1, COP);
- StructCopy(&PL_compiling, PL_curcop, COP);
- PL_curcop->op_slabbed = 0;
- SAVEFREEPV(PL_curcop);
- }
-
PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
+ SAVEVPTR(PL_curcop);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
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 */
case OP_AND:
case OP_OR:
case OP_DOR:
+ case OP_CMPCHAIN_AND:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
while (o->op_next && ( o->op_type == o->op_next->op_type
}
/*
-=head1 Custom Operators
+=for apidoc_section $custom
=for apidoc Perl_custom_op_xop
Return the XOP structure for a given custom op. This macro should be
else
xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
}
+
{
XOPRETANY any;
if(field == XOPe_xop_ptr) {
any.xop_peep = xop->xop_peep;
break;
default:
- NOT_REACHED; /* NOTREACHED */
+ field_panic:
+ Perl_croak(aTHX_
+ "panic: custom_op_get_field(): invalid field %d\n",
+ (int)field);
break;
}
} else {
any.xop_peep = XOPd_xop_peep;
break;
default:
- NOT_REACHED; /* NOTREACHED */
+ goto field_panic;
break;
}
}
}
- /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
- * op.c: In function 'Perl_custom_op_get_field':
- * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
- * This is because on those platforms (with -DEBUGGING) NOT_REACHED
- * expands to assert(0), which expands to ((0) ? (void)0 :
- * __assert(...)), and gcc doesn't know that __assert can never return. */
return any;
}
}
}
/*
-=head1 Hook manipulation
+=for apidoc_section $hook
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