* 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 OP_ENTERSUB || 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 */
that was optimised away, so it should
not be bound via =~ */
/* On OP_CONST, from a constant CV */
- /* On OP_GLOB, use Perl glob function */
+ /* On OP_GLOB, two meanings:
+ - Before ck_glob, called as CORE::glob
+ - After ck_glob, use Perl glob function
+ */
+ /* On OP_PADRANGE, push @_ */
+ /* On OP_DUMP, has no label */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
/* 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 */
+/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry NATIVE_HINTS
+ * in op_private */
/* Private for lvalues */
#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
+/* Private for OP_LEAVE and OP_LEAVELOOP */
+#define OPpLVALUE 128 /* Do not copy return value */
+
/* Private for OP_AASSIGN */
#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
#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} */
+/* Private for OP_MATCH and OP_SUBST{,CONT} */
#define OPpRUNTIME 64 /* Pattern coming in on the stack */
/* Private for OP_TRANS */
#define OPpDEREF_HV 64 /* Want ref to HV. */
#define OPpDEREF_SV (32|64) /* Want ref to SV. */
+/* OP_ENTERSUB and OP_RV2CV flags
+
+Flags are set on entersub and rv2cv in three phases:
+ parser - the parser passes the flag to the op constructor
+ check - the check routine called by the op constructor sets the flag
+ context - application of scalar/ref/lvalue context applies the flag
+
+In the third stage, an entersub op might turn into an rv2cv op (undef &foo,
+\&foo, lock &foo, exists &foo, defined &foo). The two places where that
+happens (op_lvalue_flags and doref in op.c) need to make sure the flags do
+not conflict. Flags applied in the context phase are only set when there
+is no conversion of op type.
+
+ bit entersub flag phase rv2cv flag phase
+ --- ------------- ----- ---------- -----
+ 1 OPpENTERSUB_INARGS context
+ 2 HINT_STRICT_REFS check HINT_STRICT_REFS check
+ 4 OPpENTERSUB_HASTARG check
+ 8 OPpENTERSUB_AMPER parser
+ 16 OPpENTERSUB_DB check
+ 32 OPpDEREF_AV context
+ 64 OPpDEREF_HV context OPpMAY_RETURN_CONSTANT context
+ 128 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser
+
+*/
+
/* 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 */
+/* used by HINT_STRICT_REFS 2 */
/* 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 */
+#define OPpMAY_RETURN_CONSTANT 64 /* 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 */
+ /* OP_RV2[AH]V OP_[AH]SLICE */
+#define OPpSLICEWARNING 4 /* warn about @hash{$scalar} */
+ /* OP_RV2[SAH]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_RV2HV and OP_PADHV */
+#define OPpTRUEBOOL 32 /* %hash in (%hash || $foo) in
+ void context */
+#define OPpMAYBE_TRUEBOOL 64 /* %hash in (%hash || $foo) where
+ cx is not known till run time */
+
+ /* OP_SUBSTR only */
+#define OPpSUBSTR_REPL_FIRST 16 /* 1st arg is replacement string */
+
/* 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_PADRANGE only */
+ /* bit 7 is OPpLVAL_INTRO */
+#define OPpPADRANGE_COUNTMASK 127 /* bits 6..0 hold target range, */
+#define OPpPADRANGE_COUNTSHIFT 7 /* 7 bits in total */
+
/* 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) */
+#define OPpALLOW_FAKE 16 /* OK to return fake glob */
/* Private for OP_ENTERITER and OP_ITER */
#define OPpITER_REVERSED 4 /* for (reverse ...) */
#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. */
#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 COPs */
+#define OPpHUSH_VMSISH 32 /* hush DCL exit msg vmsish mode*/
+/* Note: Used for NATIVE_HINTS (shifted from the values in PL_hints),
+ currently defined by vms/vmsish.h:
+ 64
+ 128
+ */
/* 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" */
+#define OPpFT_AFTER_t 16 /* previous op was -t */
/* 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 */
+#define OPpEVAL_RE_REPARSING 32 /* eval_sv(..., G_RE_REPARSING) */
-/* Private for OP_CALLER and OP_WANTARRAY */
+/* 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. */
+/* These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE.
+ 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 */
+/* Private for OP_(LAST|REDO|NEXT|GOTO|DUMP) */
+#define OPpPV_IS_UTF8 128 /* label is in UTF8 */
+
+/* Private for OP_SPLIT */
+#define OPpSPLIT_IMPLIM 128 /* implicit limit */
+
struct op {
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
- char * op_pmstashpv; /* Only used in OP_MATCH, with PMf_ONCE set */
+ 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
* OP_MATCH and OP_QR */
#define PMf_ONCE (1<<(PMf_BASE_SHIFT+1))
-/* replacement contains variables */
-#define PMf_MAYBE_CONST (1<<(PMf_BASE_SHIFT+2))
-
-/* PMf_ONCE has matched successfully. Not used under threading. */
+/* PMf_ONCE, i.e. ?pat?, has matched successfully. Not used under threading. */
#define PMf_USED (1<<(PMf_BASE_SHIFT+3))
/* subst replacement is constant */
/* Return substituted string instead of modifying it. */
#define PMf_NONDESTRUCT (1<<(PMf_BASE_SHIFT+9))
-#if PMf_BASE_SHIFT+9 > 31
+/* the pattern has a CV attached (currently only under qr/...(?{}).../) */
+#define PMf_HAS_CV (1<<(PMf_BASE_SHIFT+10))
+
+/* 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 (1<<(PMf_BASE_SHIFT+11))
+
+/* 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 (1<<(PMf_BASE_SHIFT+12))
+#define PMf_USE_RE_EVAL (1<<(PMf_BASE_SHIFT+13)) /* use re'eval' in scope */
+
+#if PMf_BASE_SHIFT+13 > 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_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_pmstashpv = savesharedpv(pv)); \
- })
-# else
-# define PmopSTASHPV_set(o,pv) \
- ((o)->op_pmstashstartu.op_pmstashpv = savesharedpv(pv))
-# endif
-# define PmopSTASH(o) (PmopSTASHPV(o) \
- ? gv_stashpv((o)->op_pmstashstartu.op_pmstashpv,GV_ADD) : NULL)
-# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME_get(hv) : NULL))
-# 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 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))
+# define IS_PADCONST(v) \
+ (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v))))
# 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 \
#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_FILESTATOP (12 << OCSHIFT)
#define OA_LOOPEXOP (13 << 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
/* no longer used anywhere in core */
#ifndef PERL_CORE
#define cv_ckproto(cv, gv, p) \
- cv_ckproto_len((cv), (gv), (p), (p) ? strlen(p) : 0)
+ cv_ckproto_len_flags((cv), (gv), (p), (p) ? strlen(p) : 0, 0)
#endif
#ifdef PERL_CORE
#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
+#define RV2CVOPCV_FLAG_MASK 0x00000007 /* 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