* op_type The type of the operation.
* op_opt Whether or not the op has been optimised by the
* peephole optimiser.
- *
- * See the comments in S_clear_yystack() for more
- * details on the following three flags:
- *
- * op_latefree tell op_free() to clear this op (and free any kids)
- * but not yet deallocate the struct. This means that
- * the op may be safely op_free()d multiple times
- * op_latefreed an op_latefree op has been op_free()d
- * op_attached this op (sub)tree has been attached to a CV
- *
- * op_spare three spare bits!
+ * op_slabbed allocated via opslab
+ * op_static tell op_free() to skip PerlMemShared_free(), when
+ * !op_slabbed.
+ * op_savefree on savestack via SAVEFREEOP
+ * op_folded Result/remainder of a constant fold operation.
+ * op_lastsib this op is is the last sibling
+ * op_spare One spare bit
* op_flags Flags common to all operations. See OPf_* below.
* op_private Flags peculiar to a particular operation (BUT,
* by default, set to the number of children until
#define OPCODE U16
-#ifdef PERL_MAD
-# define MADPROP_IN_BASEOP MADPROP* op_madprop;
-#else
-# define MADPROP_IN_BASEOP
-#endif
-
typedef PERL_BITFIELD16 Optype;
#ifdef BASEOP_DEFINITION
OP* op_next; \
OP* op_sibling; \
OP* (*op_ppaddr)(pTHX); \
- MADPROP_IN_BASEOP \
PADOFFSET op_targ; \
PERL_BITFIELD16 op_type:9; \
PERL_BITFIELD16 op_opt:1; \
- PERL_BITFIELD16 op_latefree:1; \
- PERL_BITFIELD16 op_latefreed:1; \
- PERL_BITFIELD16 op_attached:1; \
- PERL_BITFIELD16 op_spare:3; \
+ PERL_BITFIELD16 op_slabbed:1; \
+ PERL_BITFIELD16 op_savefree:1; \
+ PERL_BITFIELD16 op_static:1; \
+ PERL_BITFIELD16 op_folded:1; \
+ PERL_BITFIELD16 op_lastsib:1; \
+ PERL_BITFIELD16 op_spare:1; \
U8 op_flags; \
U8 op_private;
#endif
then all the other bit-fields before/after it should change their
types too to let VC pack them into the same 4 byte integer.*/
+/* for efficiency, requires OPf_WANT_VOID == G_VOID etc */
#define OP_GIMME(op,dfl) \
- (((op)->op_flags & OPf_WANT) == OPf_WANT_VOID ? G_VOID : \
- ((op)->op_flags & OPf_WANT) == OPf_WANT_SCALAR ? G_SCALAR : \
- ((op)->op_flags & OPf_WANT) == OPf_WANT_LIST ? G_ARRAY : \
- dfl)
+ (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl)
#define OP_GIMME_REVERSE(flags) ((flags) & G_WANT)
=for apidoc Amn|U32|GIMME_V
The XSUB-writer's equivalent to Perl's C<wantarray>. Returns C<G_VOID>,
C<G_SCALAR> or C<G_ARRAY> for void, scalar or list context,
-respectively. See L<perlcall> for a usage example.
+respectively.
See L<perlcall> for a usage example.
=for apidoc Amn|U32|GIMME
A backward-compatible version of C<GIMME_V> which can only return
/* On control verbs, we saw no label */
/* On flipflop, we saw ... instead of .. */
/* On UNOPs, saw bare parens, e.g. eof(). */
- /* On OP_ENTERSUB || OP_NULL, saw a "do". */
+ /* On OP_NULL, saw a "do". */
/* On OP_EXISTS, treat av as av, not avhv. */
/* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
- /* On pushre, rx is used as part of split, e.g. split " " */
+ /* On pushre, rx is used as part of split, e.g. split " " */
/* On regcomp, "use re 'eval'" was in scope */
- /* On OP_READLINE, was <$filehandle> */
/* On RV2[ACGHS]V, don't create GV--in
defined()*/
/* On OP_DBSTATE, indicates breakpoint
* (runtime property) */
/* On OP_REQUIRE, was seen as CORE::require */
- /* On OP_ENTERWHEN, there's no condition */
+ /* On OP_(ENTER|LEAVE)WHEN, there's
+ no condition */
/* On OP_SMARTMATCH, an implicit smartmatch */
/* On OP_ANONHASH and OP_ANONLIST, create a
reference to the new anon hash or array */
- Before ck_glob, called as CORE::glob
- After ck_glob, use Perl glob function
*/
+ /* On OP_PADRANGE, push @_ */
+ /* On OP_DUMP, has no label */
+ /* On OP_UNSTACK, in a foreach loop */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
: G_SCALAR) \
: dowantarray())
-/* Lower bits of op_private often carry the number of arguments, as
- * set by newBINOP, newUNOP and ck_fun */
-
-/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry lower
- * bits of PL_hints in op_private */
-
-/* Private for lvalues */
-#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
-/* Private for OPs with TARGLEX */
- /* (lower bits may carry MAXARG) */
-#define OPpTARGET_MY 16 /* Target is PADMY. */
+/* NOTE: OPp* flags are now auto-generated and defined in opcode.h,
+ * from data in regen/op_private */
-/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
-#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
-/* Private for OP_AASSIGN */
-#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
+#define OPpTRANS_ALL (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE)
-/* Private for OP_SASSIGN */
-#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
-#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */
-/* Private for OP_MATCH and OP_SUBST{,CONST} */
-#define OPpRUNTIME 64 /* Pattern coming in on the stack */
-/* Private for OP_TRANS */
-#define OPpTRANS_FROM_UTF 1
-#define OPpTRANS_TO_UTF 2
-#define OPpTRANS_IDENTICAL 4 /* right side is same as left */
-#define OPpTRANS_SQUASH 8
- /* 16 is used for OPpTARGET_MY */
-#define OPpTRANS_COMPLEMENT 32
-#define OPpTRANS_GROWS 64
-#define OPpTRANS_DELETE 128
-#define OPpTRANS_ALL (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE)
-
-/* Private for OP_REPEAT */
-#define OPpREPEAT_DOLIST 64 /* List replication. */
-
-/* Private for OP_RV2GV, OP_RV2SV, OP_AELEM, OP_HELEM, OP_PADSV */
-#define OPpDEREF (32|64) /* autovivify: Want ref to something: */
-#define OPpDEREF_AV 32 /* Want ref to AV. */
-#define OPpDEREF_HV 64 /* Want ref to HV. */
-#define OPpDEREF_SV (32|64) /* Want ref to SV. */
-
- /* OP_ENTERSUB only */
-#define OPpENTERSUB_DB 16 /* Debug subroutine. */
-#define OPpENTERSUB_HASTARG 4 /* Called from OP tree. */
-#define OPpENTERSUB_INARGS 1 /* Lval used as arg to a sub. */
-/* used by OPpDEREF (32|64) */
-/* used by HINT_STRICT_SUBS 2 */
- /* Mask for OP_ENTERSUB flags, the absence of which must be propagated
- in dynamic context */
+/* Mask for OP_ENTERSUB flags, the absence of which must be propagated
+ in dynamic context */
#define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
- /* OP_RV2CV only */
-#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
-#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */
-#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */
-
- /* OP_GV only */
-#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */
- /* OP_?ELEM only */
-#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */
- /* OP_RV2?V, OP_GVSV, OP_ENTERITER only */
-#define OPpOUR_INTRO 16 /* Variable was in an our() */
- /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN,
- OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */
-#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */
- /* OP_PADSV only */
-#define OPpPAD_STATE 16 /* is a "state" pad */
- /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
-
- /* OP_RV2GV only */
-#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */
-/* (Therefore will return whatever is currently in the symbol table, not
- guaranteed to be a PVGV) */
-
-/* Private for OP_ENTERITER and OP_ITER */
-#define OPpITER_REVERSED 4 /* for (reverse ...) */
-#define OPpITER_DEF 8 /* for $_ or for my $_ */
-
-/* Private for OP_CONST */
-#define OPpCONST_NOVER 2 /* no 6; */
-#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */
-#define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */
-#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
-#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
-#define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
-
-/* Private for OP_FLIP/FLOP */
-#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
-
-/* Private for OP_LIST */
-#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
-
-/* Private for OP_DELETE */
-#define OPpSLICE 64 /* Operating on a list of keys */
-/* Also OPpLVAL_INTRO (128) */
-
-/* Private for OP_EXISTS */
-#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */
-
-/* Private for OP_SORT */
-#define OPpSORT_NUMERIC 1 /* Optimized away { $a <=> $b } */
-#define OPpSORT_INTEGER 2 /* Ditto while under "use integer" */
-#define OPpSORT_REVERSE 4 /* Reversed sort */
-#define OPpSORT_INPLACE 8 /* sort in-place; eg @a = sort @a */
-#define OPpSORT_DESCEND 16 /* Descending sort */
-#define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */
-#define OPpSORT_STABLE 64 /* Use a stable algorithm */
-
-/* Private for OP_REVERSE */
-#define OPpREVERSE_INPLACE 8 /* reverse in-place (@a = reverse @a) */
-
-/* Private for OP_OPEN and OP_BACKTICK */
-#define OPpOPEN_IN_RAW 16 /* binmode(F,":raw") on input fh */
-#define OPpOPEN_IN_CRLF 32 /* binmode(F,":crlf") on input fh */
-#define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */
-#define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */
-
-/* Private for OP_EXIT, HUSH also for OP_DIE */
-#define OPpHUSH_VMSISH 64 /* hush DCL exit msg vmsish mode*/
-#define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/
-
-/* Private for OP_FTXXX */
-#define OPpFT_ACCESS 2 /* use filetest 'access' */
-#define OPpFT_STACKED 4 /* stacked filetest, as "-f" in "-f -x $f" */
-#define OPpFT_STACKING 8 /* stacking filetest, as "-x" in "-f -x $f" */
-
-/* Private for OP_(MAP|GREP)(WHILE|START) */
-#define OPpGREP_LEX 2 /* iterate over lexical $_ */
-
-/* Private for OP_ENTEREVAL */
-#define OPpEVAL_HAS_HH 2 /* Does it have a copy of %^H */
-#define OPpEVAL_UNICODE 4
-#define OPpEVAL_BYTES 8
-#define OPpEVAL_COPHH 16 /* Construct %^H from cop hints */
-
-/* Private for OP_CALLER, OP_WANTARRAY and OP_RUNCV */
-#define OPpOFFBYONE 128 /* Treat caller(1) as caller(2) */
-
-/* Private for OP_COREARGS */
-/* These must not conflict with OPpDONT_INIT_GV. See pp.c:S_rv2gv. */
-#define OPpCOREARGS_DEREF1 1 /* Arg 1 is a handle constructor */
-#define OPpCOREARGS_DEREF2 2 /* Arg 2 is a handle constructor */
-#define OPpCOREARGS_SCALARMOD 64 /* \$ rather than \[$@%*] */
-#define OPpCOREARGS_PUSHMARK 128 /* Call pp_pushmark */
+
struct op {
BASEOP
OP * op_last;
};
+struct methop {
+ BASEOP
+ union {
+ /* op_u.op_first *must* be aligned the same as the op_first
+ * field of the other op types, and op_u.op_meth_sv *must*
+ * be aligned with op_sv */
+ OP* op_first; /* optree for method name */
+ SV* op_meth_sv; /* static method name */
+ } op_u;
+#ifdef USE_ITHREADS
+ PADOFFSET op_class_targ; /* pad index for class name if threaded */
+#else
+ SV* op_class_sv; /* static class name */
+#endif
+};
+
struct pmop {
BASEOP
OP * op_first;
OP * op_last;
#ifdef USE_ITHREADS
- IV op_pmoffset;
+ PADOFFSET op_pmoffset;
#else
REGEXP * op_pmregexp; /* compiled expression */
#endif
union {
OP * op_pmreplstart; /* Only used in OP_SUBST */
#ifdef USE_ITHREADS
- struct {
- char * op_pmstashpv; /* Only used in OP_MATCH, with PMf_ONCE set */
- U32 op_pmstashflags; /* currently only SVf_UTF8 or 0 */
- } op_pmstashthr;
+ PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */
#else
HV * op_pmstash;
#endif
} op_pmstashstartu;
+ OP * op_code_list; /* list of (?{}) code blocks */
};
#ifdef USE_ITHREADS
#define PM_SETRE(o,r) ((o)->op_pmregexp = (r))
#endif
-/* Leave some space, so future bit allocations can go either in the shared or
- * unshared area without affecting binary compatibility */
-#define PMf_BASE_SHIFT (_RXf_PMf_SHIFT_NEXT+6)
+/* Currently these PMf flags occupy a single 32-bit word. Not all bits are
+ * currently used. The lower bits are shared with their corresponding RXf flag
+ * bits, up to but not including _RXf_PMf_SHIFT_NEXT. The unused bits
+ * immediately follow; finally the used Pmf-only (unshared) bits, so that the
+ * highest bit in the word is used. This gathers all the unused bits as a pool
+ * in the middle, like so: 11111111111111110000001111111111
+ * where the '1's represent used bits, and the '0's unused. This design allows
+ * us to allocate off one end of the pool if we need to add a shared bit, and
+ * off the other end if we need a non-shared bit, without disturbing the other
+ * bits. This maximizes the likelihood of being able to change things without
+ * breaking binary compatibility.
+ *
+ * To add shared bits, do so in op_reg_common.h. This should change
+ * _RXf_PMf_SHIFT_NEXT so that things won't compile. Then come to regexp.h and
+ * op.h and adjust the constant adders in the definitions of PMf_BASE_SHIFT and
+ * Pmf_BASE_SHIFT down by the number of shared bits you added. That's it.
+ * Things should be binary compatible. But if either of these gets to having
+ * to subtract rather than add, leave at 0 and adjust all the entries below
+ * that are in terms of this according. But if the first one of those is
+ * already PMf_BASE_SHIFT+0, there are no bits left, and a redesign is in
+ * order.
+ *
+ * To remove unshared bits, just delete its entry. If you're where breaking
+ * binary compatibility is ok to do, you might want to adjust things to move
+ * the newly opened space so that it gets absorbed into the common pool.
+ *
+ * To add unshared bits, first use up any gaps in the middle. Otherwise,
+ * allocate off the low end until you get to PMf_BASE_SHIFT+0. If that isn't
+ * enough, move PMf_BASE_SHIFT down (if possible) and add the new bit at the
+ * other end instead; this preserves binary compatibility. */
+#define PMf_BASE_SHIFT (_RXf_PMf_SHIFT_NEXT+4)
/* 'use re "taint"' in scope: taint $1 etc. if target tainted */
-#define PMf_RETAINT (1<<(PMf_BASE_SHIFT+0))
+#define PMf_RETAINT (1U<<(PMf_BASE_SHIFT+5))
/* match successfully only once per reset, with related flag RXf_USED in
* re->extflags holding state. This is used only for ?? matches, and only on
* OP_MATCH and OP_QR */
-#define PMf_ONCE (1<<(PMf_BASE_SHIFT+1))
+#define PMf_ONCE (1U<<(PMf_BASE_SHIFT+6))
-/* replacement contains variables */
-#define PMf_MAYBE_CONST (1<<(PMf_BASE_SHIFT+2))
-
-/* PMf_ONCE has matched successfully. Not used under threading. */
-#define PMf_USED (1<<(PMf_BASE_SHIFT+3))
+/* PMf_ONCE, i.e. ?pat?, has matched successfully. Not used under threading. */
+#define PMf_USED (1U<<(PMf_BASE_SHIFT+7))
/* subst replacement is constant */
-#define PMf_CONST (1<<(PMf_BASE_SHIFT+4))
+#define PMf_CONST (1U<<(PMf_BASE_SHIFT+8))
/* keep 1st runtime pattern forever */
-#define PMf_KEEP (1<<(PMf_BASE_SHIFT+5))
+#define PMf_KEEP (1U<<(PMf_BASE_SHIFT+9))
-#define PMf_GLOBAL (1<<(PMf_BASE_SHIFT+6)) /* pattern had a g modifier */
+#define PMf_GLOBAL (1U<<(PMf_BASE_SHIFT+10)) /* pattern had a g modifier */
/* don't reset pos() if //g fails */
-#define PMf_CONTINUE (1<<(PMf_BASE_SHIFT+7))
+#define PMf_CONTINUE (1U<<(PMf_BASE_SHIFT+11))
/* evaluating replacement as expr */
-#define PMf_EVAL (1<<(PMf_BASE_SHIFT+8))
+#define PMf_EVAL (1U<<(PMf_BASE_SHIFT+12))
/* Return substituted string instead of modifying it. */
-#define PMf_NONDESTRUCT (1<<(PMf_BASE_SHIFT+9))
-
-#if PMf_BASE_SHIFT+9 > 31
+#define PMf_NONDESTRUCT (1U<<(PMf_BASE_SHIFT+13))
+
+/* the pattern has a CV attached (currently only under qr/...(?{}).../) */
+#define PMf_HAS_CV (1U<<(PMf_BASE_SHIFT+14))
+
+/* op_code_list is private; don't free it etc. It may well point to
+ * code within another sub, with different pad etc */
+#define PMf_CODELIST_PRIVATE (1U<<(PMf_BASE_SHIFT+15))
+
+/* the PMOP is a QR (we should be able to detect that from the op type,
+ * but the regex compilation API passes just the pm flags, not the op
+ * itself */
+#define PMf_IS_QR (1U<<(PMf_BASE_SHIFT+16))
+#define PMf_USE_RE_EVAL (1U<<(PMf_BASE_SHIFT+17)) /* use re'eval' in scope */
+
+/* See comments at the beginning of these defines about adding bits. The
+ * highest bit position should be used, so that if PMf_BASE_SHIFT gets
+ * increased, the #error below will be triggered so that you will be reminded
+ * to adjust things at the other end to keep the bit positions unchanged */
+#if PMf_BASE_SHIFT+17 > 31
# error Too many PMf_ bits used. See above and regnodes.h for any spare in middle
#endif
#ifdef USE_ITHREADS
-# define PmopSTASHPV(o) \
- (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv : NULL)
-# if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define PmopSTASHPV_set(o,pv) ({ \
- assert((o)->op_pmflags & PMf_ONCE); \
- ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv = savesharedpv(pv)); \
- })
-# else
-# define PmopSTASHPV_set(o,pv) \
- ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv = savesharedpv(pv))
-# endif
-# define PmopSTASH_flags(o) ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashflags)
-# define PmopSTASH_flags_set(o,flags) ((o)->op_pmstashstartu.op_pmstashthr.op_pmstashflags = flags)
-# define PmopSTASH(o) (PmopSTASHPV(o) \
- ? gv_stashpv((o)->op_pmstashstartu.op_pmstashthr.op_pmstashpv, \
- GV_ADD | PmopSTASH_flags(o)) : NULL)
-# define PmopSTASH_set(o,hv) (PmopSTASHPV_set(o, (hv) ? HvNAME_get(hv) : NULL), \
- PmopSTASH_flags_set(o, \
- ((hv) && HvNAME_HEK(hv) && \
- HvNAMEUTF8(hv)) \
- ? SVf_UTF8 \
- : 0))
-# define PmopSTASH_free(o) PerlMemShared_free(PmopSTASHPV(o))
-
+# define PmopSTASH(o) ((o)->op_pmflags & PMf_ONCE \
+ ? PL_stashpad[(o)->op_pmstashstartu.op_pmstashoff] \
+ : NULL)
+# define PmopSTASH_set(o,hv) \
+ (assert_((o)->op_pmflags & PMf_ONCE) \
+ (o)->op_pmstashstartu.op_pmstashoff = \
+ (hv) ? alloccopstash(hv) : 0)
#else
# define PmopSTASH(o) \
(((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL)
# else
# define PmopSTASH_set(o,hv) ((o)->op_pmstashstartu.op_pmstash = (hv))
# endif
-# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
- /* op_pmstashstartu.op_pmstash is not refcounted */
-# define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
-/* Note that if this becomes non-empty, then S_forget_pmop in op.c will need
- changing */
-# define PmopSTASH_free(o)
#endif
+#define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : NULL)
+ /* op_pmstashstartu.op_pmstash is not refcounted */
+#define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
struct svop {
BASEOP
#define cPVOPx(o) ((PVOP*)o)
#define cCOPx(o) ((COP*)o)
#define cLOOPx(o) ((LOOP*)o)
+#define cMETHOPx(o) ((METHOP*)o)
#define cUNOP cUNOPx(PL_op)
#define cBINOP cBINOPx(PL_op)
#ifdef USE_ITHREADS
# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
-# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
- && GvIN_PAD(v))
-# define IS_PADCONST(v) (v && SvREADONLY(v))
+# ifndef PERL_CORE
+# define IS_PADGV(v) (v && isGV(v))
+# define IS_PADCONST(v) \
+ (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v))))
+# endif
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \
? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ))
+# define cMETHOPx_class(v) (cMETHOPx(v)->op_class_targ ? \
+ PAD_SVl(cMETHOPx(v)->op_class_targ) : NULL)
#else
# define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv)
-# define IS_PADGV(v) FALSE
-# define IS_PADCONST(v) FALSE
+# ifndef PERL_CORE
+# define IS_PADGV(v) FALSE
+# define IS_PADCONST(v) FALSE
+# endif
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv)
# define cSVOPx_svp(v) (&cSVOPx(v)->op_sv)
+# define cMETHOPx_class(v) (cMETHOPx(v)->op_class_sv)
#endif
+# define cMETHOPx_meth(v) cSVOPx_sv(v)
+
#define cGVOP_gv cGVOPx_gv(PL_op)
#define cGVOPo_gv cGVOPx_gv(o)
#define kGVOP_gv cGVOPx_gv(kid)
#define OA_DANGEROUS 64
#define OA_DEFGV 128
-/* The next 4 bits encode op class information */
+/* The next 4 bits (8..11) encode op class information */
#define OCSHIFT 8
#define OA_CLASS_MASK (15 << OCSHIFT)
#define OA_BASEOP_OR_UNOP (11 << OCSHIFT)
#define OA_FILESTATOP (12 << OCSHIFT)
#define OA_LOOPEXOP (13 << OCSHIFT)
+#define OA_METHOP (14 << OCSHIFT)
+/* Each remaining nybble of PL_opargs (i.e. bits 12..15, 16..19 etc)
+ * encode the type for each arg */
#define OASHIFT 12
-/* Remaining nybbles of PL_opargs */
#define OA_SCALAR 1
#define OA_LIST 2
#define OA_AVREF 3
/* flags used by Perl_load_module() */
#define PERL_LOADMOD_DENY 0x1 /* no Module */
#define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */
-#define PERL_LOADMOD_IMPORT_OPS 0x4 /* use Module (...) */
+#define PERL_LOADMOD_IMPORT_OPS 0x4 /* import arguments
+ are passed as a sin-
+ gle op tree, not a
+ list of SVs */
-#if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C)
+#if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C)
#define ref(o, type) doref(o, type, TRUE)
#endif
=for apidoc Am|OP*|LINKLIST|OP *o
Given the root of an optree, link the tree in execution order using the
-C<op_next> pointers and return the first op executed. If this has
+C<op_next> pointers and return the first op executed. If this has
already been done, it will not be redone, and C<< o->op_next >> will be
-returned. If C<< o->op_next >> is not already set, I<o> should be at
+returned. If C<< o->op_next >> is not already set, I<o> should be at
least an C<UNOP>.
=cut
#include "reentr.h"
#endif
-#if defined(PL_OP_SLAB_ALLOC)
#define NewOp(m,var,c,type) \
(var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type)))
#define NewOpSz(m,var,size) \
(var = (OP *) Perl_Slab_Alloc(aTHX_ size))
#define FreeOp(p) Perl_Slab_Free(aTHX_ p)
-#else
-#define NewOp(m, var, c, type) \
- (var = (MEM_WRAP_CHECK_(c,type) \
- (type*)PerlMemShared_calloc(c, sizeof(type))))
-#define NewOpSz(m, var, size) \
- (var = (OP*)PerlMemShared_calloc(1, size))
-#define FreeOp(p) PerlMemShared_free(p)
+
+/*
+ * The per-CV op slabs consist of a header (the opslab struct) and a bunch
+ * of space for allocating op slots, each of which consists of two pointers
+ * followed by an op. The first pointer points to the next op slot. The
+ * second points to the slab. At the end of the slab is a null pointer,
+ * so that slot->opslot_next - slot can be used to determine the size
+ * of the op.
+ *
+ * Each CV can have multiple slabs; opslab_next points to the next slab, to
+ * form a chain. All bookkeeping is done on the first slab, which is where
+ * all the op slots point.
+ *
+ * Freed ops are marked as freed and attached to the freed chain
+ * via op_next pointers.
+ *
+ * When there is more than one slab, the second slab in the slab chain is
+ * assumed to be the one with free space available. It is used when allo-
+ * cating an op if there are no freed ops available or big enough.
+ */
+
+#ifdef PERL_CORE
+struct opslot {
+ /* keep opslot_next first */
+ OPSLOT * opslot_next; /* next slot */
+ OPSLAB * opslot_slab; /* owner */
+ OP opslot_op; /* the op itself */
+};
+
+struct opslab {
+ OPSLOT * opslab_first; /* first op in this slab */
+ OPSLAB * opslab_next; /* next slab */
+ OP * opslab_freed; /* chain of freed ops */
+ size_t opslab_refcnt; /* number of ops */
+# ifdef PERL_DEBUG_READONLY_OPS
+ U16 opslab_size; /* size of slab in pointers */
+ bool opslab_readonly;
+# endif
+ OPSLOT opslab_slots; /* slots begin here */
+};
+
+# define OPSLOT_HEADER STRUCT_OFFSET(OPSLOT, opslot_op)
+# define OPSLOT_HEADER_P (OPSLOT_HEADER/sizeof(I32 *))
+# define OpSLOT(o) (assert_(o->op_slabbed) \
+ (OPSLOT *)(((char *)o)-OPSLOT_HEADER))
+# define OpSLAB(o) OpSLOT(o)->opslot_slab
+# define OpslabREFCNT_dec(slab) \
+ (((slab)->opslab_refcnt == 1) \
+ ? opslab_free_nopad(slab) \
+ : (void)--(slab)->opslab_refcnt)
+ /* Variant that does not null out the pads */
+# define OpslabREFCNT_dec_padok(slab) \
+ (((slab)->opslab_refcnt == 1) \
+ ? opslab_free(slab) \
+ : (void)--(slab)->opslab_refcnt)
#endif
struct block_hooks {
Return the BHK's flags.
=for apidoc mx|void *|BhkENTRY|BHK *hk|which
-Return an entry from the BHK structure. I<which> is a preprocessor token
-indicating which entry to return. If the appropriate flag is not set
-this will return NULL. The type of the return value depends on which
+Return an entry from the BHK structure. I<which> is a preprocessor token
+indicating which entry to return. If the appropriate flag is not set
+this will return NULL. The type of the return value depends on which
entry you ask for.
=for apidoc Amx|void|BhkENTRY_set|BHK *hk|which|void *ptr
Set an entry in the BHK structure, and set the flags to indicate it is
-valid. I<which> is a preprocessing token indicating which entry to set.
+valid. I<which> is a preprocessing token indicating which entry to set.
The type of I<ptr> depends on the entry.
=for apidoc Amx|void|BhkDISABLE|BHK *hk|which
Temporarily disable an entry in this BHK structure, by clearing the
-appropriate flag. I<which> is a preprocessor token indicating which
+appropriate flag. I<which> is a preprocessor token indicating which
entry to disable.
=for apidoc Amx|void|BhkENABLE|BHK *hk|which
Re-enable an entry in this BHK structure, by setting the appropriate
-flag. I<which> is a preprocessor token indicating which entry to enable.
+flag. I<which> is a preprocessor token indicating which entry to enable.
This will assert (under -DDEBUGGING) if the entry doesn't contain a valid
pointer.
=for apidoc mx|void|CALL_BLOCK_HOOKS|which|arg
-Call all the registered block hooks for type I<which>. I<which> is a
+Call all the registered block hooks for type I<which>. I<which> is a
preprocessing token; the type of I<arg> depends on I<which>.
=cut
#define CALL_BLOCK_HOOKS(which, arg) \
STMT_START { \
if (PL_blockhooks) { \
- I32 i; \
- for (i = av_len(PL_blockhooks); i >= 0; i--) { \
+ SSize_t i; \
+ for (i = av_tindex(PL_blockhooks); i >= 0; i--) { \
SV *sv = AvARRAY(PL_blockhooks)[i]; \
BHK *hk; \
\
#define RV2CVOPCV_MARK_EARLY 0x00000001
#define RV2CVOPCV_RETURN_NAME_GV 0x00000002
+#define RV2CVOPCV_RETURN_STUB 0x00000004
+#ifdef PERL_CORE /* behaviour of this flag is subject to change: */
+# define RV2CVOPCV_MAYBE_NAME_GV 0x00000008
+#endif
+#define RV2CVOPCV_FLAG_MASK 0x0000000f /* all of the above */
#define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0)
Return the XOP's flags.
=for apidoc Am||XopENTRY|XOP *xop|which
-Return a member of the XOP structure. I<which> is a cpp token indicating
-which entry to return. If the member is not set this will return a
-default value. The return type depends on I<which>.
+Return a member of the XOP structure. I<which> is a cpp token
+indicating which entry to return. If the member is not set
+this will return a default value. The return type depends
+on I<which>. This macro evaluates its arguments more than
+once. If you are using C<Perl_custom_op_xop> to retreive a
+C<XOP *> from a C<OP *>, use the more efficient L</XopENTRYCUSTOM> instead.
+
+=for apidoc Am||XopENTRYCUSTOM|const OP *o|which
+Exactly like C<XopENTRY(XopENTRY(Perl_custom_op_xop(aTHX_ o), which)> but more
+efficient. The I<which> parameter is identical to L</XopENTRY>.
=for apidoc Am|void|XopENTRY_set|XOP *xop|which|value
-Set a member of the XOP structure. I<which> is a cpp token indicating
-which entry to set. See L<perlguts/"Custom Operators"> for details about
-the available members and how they are used.
+Set a member of the XOP structure. I<which> is a cpp token
+indicating which entry to set. See L<perlguts/"Custom Operators">
+for details about the available members and how
+they are used. This macro evaluates its argument
+more than once.
=for apidoc Am|void|XopDISABLE|XOP *xop|which
Temporarily disable a member of the XOP, by clearing the appropriate flag.
void (*xop_peep)(pTHX_ OP *o, OP *oldop);
};
+/* return value of Perl_custom_op_get_field, similar to void * then casting but
+ the U32 doesn't need truncation on 64 bit platforms in the caller, also
+ for easier macro writing */
+typedef union {
+ const char *xop_name;
+ const char *xop_desc;
+ U32 xop_class;
+ void (*xop_peep)(pTHX_ OP *o, OP *oldop);
+ XOP *xop_ptr;
+} XOPRETANY;
+
#define XopFLAGS(xop) ((xop)->xop_flags)
#define XOPf_xop_name 0x01
#define XOPf_xop_class 0x04
#define XOPf_xop_peep 0x08
+/* used by Perl_custom_op_get_field for option checking */
+typedef enum {
+ XOPe_xop_ptr = 0, /* just get the XOP *, don't look inside it */
+ XOPe_xop_name = XOPf_xop_name,
+ XOPe_xop_desc = XOPf_xop_desc,
+ XOPe_xop_class = XOPf_xop_class,
+ XOPe_xop_peep = XOPf_xop_peep
+} xop_flags_enum;
+
#define XOPd_xop_name PL_op_name[OP_CUSTOM]
#define XOPd_xop_desc PL_op_desc[OP_CUSTOM]
#define XOPd_xop_class OA_BASEOP
#define XopENTRY(xop, which) \
((XopFLAGS(xop) & XOPf_ ## which) ? (xop)->which : XOPd_ ## which)
+#define XopENTRYCUSTOM(o, which) \
+ (Perl_custom_op_get_field(aTHX_ o, XOPe_ ## which).which)
+
#define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which)
#define XopENABLE(xop, which) \
STMT_START { \
assert(XopENTRY(xop, which)); \
} STMT_END
+#define Perl_custom_op_xop(x) \
+ (Perl_custom_op_get_field(x, XOPe_xop_ptr).xop_ptr)
+
/*
=head1 Optree Manipulation Functions
=for apidoc Am|const char *|OP_NAME|OP *o
-Return the name of the provided OP. For core ops this looks up the name
+Return the name of the provided OP. For core ops this looks up the name
from the op_type; for custom ops from the op_ppaddr.
=for apidoc Am|const char *|OP_DESC|OP *o
=for apidoc Am|U32|OP_CLASS|OP *o
Return the class of the provided OP: that is, which of the *OP
-structures it uses. For core ops this currently gets the information out
+structures it uses. For core ops this currently gets the information out
of PL_opargs, which does not always accurately reflect the type used.
For custom ops the type is returned from the registration, and it is up
-to the registree to ensure it is accurate. The value returned will be
+to the registree to ensure it is accurate. The value returned will be
one of the OA_* constants from op.h.
+=for apidoc Am|bool|OP_TYPE_IS|OP *o, Optype type
+Returns true if the given OP is not a NULL pointer
+and if it is of the given type.
+
+The negation of this macro, C<OP_TYPE_ISNT> is also available
+as well as C<OP_TYPE_IS_NN> and C<OP_TYPE_ISNT_NN> which elide
+the NULL pointer check.
+
+=for apidoc Am|bool|OP_TYPE_IS_OR_WAS|OP *o, Optype type
+Returns true if the given OP is not a NULL pointer and
+if it is of the given type or used to be before being
+replaced by an OP of type OP_NULL.
+
+The negation of this macro, C<OP_TYPE_ISNT_AND_WASNT>
+is also available as well as C<OP_TYPE_IS_OR_WAS_NN>
+and C<OP_TYPE_ISNT_AND_WASNT_NN> which elide
+the NULL pointer check.
+
+=for apidoc Am|bool|OP_HAS_SIBLING|OP *o
+Returns true if o has a sibling
+
+=for apidoc Am|bool|OP_SIBLING|OP *o
+Returns the sibling of o, or NULL if there is no sibling
+
+=for apidoc Am|bool|OP_SIBLING_set|OP *o|OP *sib
+Sets the sibling of o to sib
+
=cut
*/
#define OP_NAME(o) ((o)->op_type == OP_CUSTOM \
- ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name) \
+ ? XopENTRYCUSTOM(o, xop_name) \
: PL_op_name[(o)->op_type])
#define OP_DESC(o) ((o)->op_type == OP_CUSTOM \
- ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc) \
+ ? XopENTRYCUSTOM(o, xop_desc) \
: PL_op_desc[(o)->op_type])
#define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \
- ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_class) \
+ ? XopENTRYCUSTOM(o, xop_class) \
: (PL_opargs[(o)->op_type] & OA_CLASS_MASK))
-#define newSUB(f, o, p, b) Perl_newATTRSUB(aTHX_ (f), (o), (p), NULL, (b))
-
-#ifdef PERL_MAD
-# define MAD_NULL 1
-# define MAD_PV 2
-# define MAD_OP 3
-# define MAD_SV 4
-
-struct madprop {
- MADPROP* mad_next;
- void *mad_val;
- U32 mad_vlen;
-/* short mad_count; */
- char mad_key;
- char mad_type;
-};
-
-struct token {
- I32 tk_type;
- YYSTYPE tk_lval;
- MADPROP* tk_mad;
-};
+#define OP_TYPE_IS(o, type) ((o) && (o)->op_type == (type))
+#define OP_TYPE_IS_NN(o, type) ((o)->op_type == (type))
+#define OP_TYPE_ISNT(o, type) ((o) && (o)->op_type != (type))
+#define OP_TYPE_ISNT_NN(o, type) ((o)->op_type != (type))
+
+#define OP_TYPE_IS_OR_WAS_NN(o, type) \
+ ( ((o)->op_type == OP_NULL \
+ ? (o)->op_targ \
+ : (o)->op_type) \
+ == (type) )
+
+#define OP_TYPE_IS_OR_WAS(o, type) \
+ ( (o) && OP_TYPE_IS_OR_WAS_NN(o, type) )
+
+#define OP_TYPE_ISNT_AND_WASNT_NN(o, type) \
+ ( ((o)->op_type == OP_NULL \
+ ? (o)->op_targ \
+ : (o)->op_type) \
+ != (type) )
+
+#define OP_TYPE_ISNT_AND_WASNT(o, type) \
+ ( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) )
+
+#ifdef PERL_OP_PARENT
+# define OP_HAS_SIBLING(o) (!cBOOL((o)->op_lastsib))
+# define OP_SIBLING(o) (0 + (o)->op_lastsib ? NULL : (o)->op_sibling)
+# define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib))
+#else
+# define OP_HAS_SIBLING(o) (cBOOL((o)->op_sibling))
+# define OP_SIBLING(o) (0 + (o)->op_sibling)
+# define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib))
#endif
+#define newATTRSUB(f, o, p, a, b) Perl_newATTRSUB_x(aTHX_ f, o, p, a, b, FALSE)
+#define newSUB(f, o, p, b) newATTRSUB((f), (o), (p), NULL, (b))
+
/*
- * Values that can be held by mad_key :
- * ^ unfilled head spot
- * , literal ,
- * ; literal ; (blank if implicit ; at end of block)
- * : literal : from ?: or attr list
- * + unary +
- * ? literal ? from ?:
- * ( literal (
- * ) literal )
- * [ literal [
- * ] literal ]
- * { literal {
- * } literal }
- * @ literal @ sigil
- * $ literal $ sigil
- * * literal * sigil
- * ! use is source filtered
- * & & or sub
- * # whitespace/comment following ; or }
- * # $# sigil
- * 1 1st ; from for(;;)
- * 1 retired protasis
- * 2 2nd ; from for(;;)
- * 2 retired apodosis
- * 3 C-style for list
- * a sub or var attributes
- * a non-method arrow operator
- * A method arrow operator
- * A use import args
- * b format block
- * B retired stub block
- * C constant conditional op
- * d declarator
- * D do block
- * e unreached "else" (see C)
- * e expression producing E
- * E tr/E/R/, /E/
- * f folded constant op
- * F peg op for format
- * g op was forced to be a word
- * i if/unless modifier
- * I if/elsif/unless statement
- * k local declarator
- * K retired kid op
- * l last index of array ($#foo)
- * L label
- * m modifier on regex
- * n sub or format name
- * o current operator/declarator name
- * o else/continue
- * O generic optimized op
- * p peg to hold extra whitespace at statement level
- * P peg op for package declaration
- * q opening quote
- * = quoted material
- * Q closing quote
- * Q optimized qw//
- * r expression producing R
- * R tr/E/R/ s/E/R/
- * s sub signature
- * S use import stub (no import)
- * S retired sort block
- * t unreached "then" (see C)
- * U use import op
- * v private sv of for loop
- * V use version
- * w while/until modifier
- * W while/for statement
- * x optimized qw
- * X random thing
- * _ whitespace/comments preceding anything else
- * ~ =~ operator
- */
+=head1 Hook manipulation
+*/
+
+#ifdef USE_ITHREADS
+# define OP_CHECK_MUTEX_INIT MUTEX_INIT(&PL_check_mutex)
+# define OP_CHECK_MUTEX_LOCK MUTEX_LOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_TERM MUTEX_DESTROY(&PL_check_mutex)
+#else
+# define OP_CHECK_MUTEX_INIT NOOP
+# define OP_CHECK_MUTEX_LOCK NOOP
+# define OP_CHECK_MUTEX_UNLOCK NOOP
+# define OP_CHECK_MUTEX_TERM NOOP
+#endif
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff