#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
+/* malloc a new op slab (suitable for attaching to PL_compcv) */
+
static OPSLAB *
S_new_slab(pTHX_ size_t sz)
{
PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
)
+/* Returns a sz-sized block of memory (suitable for holding an op) from
+ * a free slot in the chain of op slabs attached to PL_compcv.
+ * Allocates a new slab if necessary.
+ * if PL_compcv isn't compiling, malloc() instead.
+ */
+
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
}
#endif
+
+/* Return the block of memory used by an op to the free list of
+ * the OP slab associated with that op.
+ */
+
void
Perl_Slab_Free(pTHX_ void *op)
{
if (havepad) LEAVE;
}
+/* Free a chain of OP slabs. Should only be called after all ops contained
+ * in it have been freed. At this point, its reference count should be 1,
+ * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
+ * and just directly calls opslab_free().
+ * (Note that the reference count which PL_compcv held on the slab should
+ * have been removed once compilation of the sub was complete).
+ *
+ *
+ */
+
void
Perl_opslab_free(pTHX_ OPSLAB *slab)
{
} while (slab);
}
+/* like opslab_free(), but first calls op_free() on any ops in the slab
+ * not marked as OP_FREED
+ */
+
void
Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
if (o->op_flags & OPf_KIDS) {
OP *kid, *nextkid;
+ assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = OpSIBLING(kid); /* Get before next freeing kid */
- if (!kid || kid->op_type == OP_FREED)
+ if (kid->op_type == OP_FREED)
/* During the forced freeing of ops after
compilation failure, kidops may be freed before
their parents. */
/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
* const fields. Also, convert CONST keys to HEK-in-SVs.
- * rop is the op that retrieves the hash;
+ * rop is the op that retrieves the hash;
* key_op is the first key
+ * real if false, only check (and possibly croak); don't update op
*/
STATIC void
-S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
+S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
{
PADNAME *lexname;
GV **fields;
if ( !SvIsCOW_shared_hash(sv = *svp)
&& SvTYPE(sv) < SVt_PVMG
&& SvOK(sv)
- && !SvROK(sv))
+ && !SvROK(sv)
+ && real)
{
SSize_t keylen;
const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
/* see if any strings would grow if converted to utf8 */
if (!utf8) {
- char *p = (char*)argp->p;
- STRLEN len = argp->len;
- while (len--) {
- U8 c = *p++;
- if (!UTF8_IS_INVARIANT(c))
- variant++;
- }
+ variant += variant_under_utf8_count((U8 *) argp->p,
+ (U8 *) argp->p + argp->len);
}
}
check_keys:
if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
rop = NULL;
- S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
break;
}
case OP_NULL:
start = LINKLIST(PL_main_root);
PL_main_root->op_next = 0;
S_process_optree(aTHX_ NULL, PL_main_root, start);
- cv_forget_slab(PL_compcv);
+ if (!PL_parser->error_count)
+ /* on error, leave CV slabbed so that ops left lying around
+ * will eb cleaned up. Else unslab */
+ cv_forget_slab(PL_compcv);
PL_compcv = 0;
/* Register with debugger */
rx_flags |= RXf_SPLIT;
}
- /* Skip compiling if parser found an error for this pattern */
- if (pm->op_pmflags & PMf_HAS_ERROR) {
- return o;
- }
-
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
# endif
}
#endif
- /* But we know that one op is using this CV's slab. */
- cv_forget_slab(PL_compcv);
+ /* This LEAVE_SCOPE will restore PL_compcv to point to the
+ * outer CV (the one whose slab holds the pm op). The
+ * inner CV (which holds expr) will be freed later, once
+ * all the entries on the parse stack have been popped on
+ * return from this function. Which is why its safe to
+ * call op_free(expr) below.
+ */
LEAVE_SCOPE(floor);
pm->op_pmflags &= ~PMf_HAS_CV;
}
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
PM_SETRE(pm,
eng->op_comp
? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
}
else {
/* compile-time pattern that includes literal code blocks */
- REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+
+ REGEXP* re;
+
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
+
+ re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
rx_flags,
(pm->op_pmflags |
((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
if (block) {
+ bool free_file = CvFILE(cv) && CvDYNFILE(cv);
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
CvFLAGS(PL_compcv) |= other_flags;
- if (CvFILE(cv) && CvDYNFILE(cv)) {
+ if (free_file) {
Safefree(CvFILE(cv));
}
CvFILE_set_from_cop(cv, PL_curcop);
return cv;
}
+/* Add a stub CV to a typeglob.
+ * This is the implementation of a forward declaration, 'sub foo';'
+ */
+
CV *
Perl_newSTUB(pTHX_ GV *gv, bool fake)
{
* the extra hassle for those edge cases */
break;
- if (pass) {
+ {
UNOP *rop = NULL;
OP * helem_op = o->op_next;
ASSUME( helem_op->op_type == OP_HELEM
- || helem_op->op_type == OP_NULL);
+ || helem_op->op_type == OP_NULL
+ || pass == 0);
if (helem_op->op_type == OP_HELEM) {
rop = (UNOP*)(((BINOP*)helem_op)->op_first);
if ( helem_op->op_private & OPpLVAL_INTRO
)
rop = NULL;
}
- S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
+ /* on first pass just check; on second pass
+ * hekify */
+ S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
+ pass);
+ }
+ if (pass) {
#ifdef USE_ITHREADS
/* Relocate sv to the pad for thread safety */
op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
Size_t size;
STRLEN *new_warnings;
- PERL_ARGS_ASSERT_DUP_WARNINGS;
-
- if (specialWARN(warnings))
+ if (warnings == NULL || specialWARN(warnings))
return warnings;
size = sizeof(*warnings) + *warnings;
https://perl5.git.perl.org / perl5.git / blobdiff