#define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
+/* whether trie related optimizations are enabled */
+#if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
+#define TRIE_STUDY_OPT
+#define TRIE_STCLASS
+#endif
/* Length of a variant. */
typedef struct scan_data_t {
{ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
#define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
-#define SF_BEFORE_SEOL 0x1
-#define SF_BEFORE_MEOL 0x2
+#define SF_BEFORE_SEOL 0x0001
+#define SF_BEFORE_MEOL 0x0002
#define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
#define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
#define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
#define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
-#define SF_IS_INF 0x40
-#define SF_HAS_PAR 0x80
-#define SF_IN_PAR 0x100
-#define SF_HAS_EVAL 0x200
-#define SCF_DO_SUBSTR 0x400
+#define SF_IS_INF 0x0040
+#define SF_HAS_PAR 0x0080
+#define SF_IN_PAR 0x0100
+#define SF_HAS_EVAL 0x0200
+#define SCF_DO_SUBSTR 0x0400
#define SCF_DO_STCLASS_AND 0x0800
#define SCF_DO_STCLASS_OR 0x1000
#define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
#define SCF_WHILEM_VISITED_POS 0x2000
+#define SCF_EXACT_TRIE 0x4000 /* should re study once we are done? */
+
#define UTF (RExC_utf8 != 0)
#define LOC ((RExC_flags & PMf_LOCALE) != 0)
#define FOLD ((RExC_flags & PMf_FOLD) != 0)
* Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
* element 2*n-1 of the array. Element #2n holds the byte length node #n.
* Element 0 holds the number n.
+ * Position is 1 indexed.
*/
-#define MJD_OFFSET_DEBUG(x)
-/* #define MJD_OFFSET_DEBUG(x) DEBUG_r(Perl_warn_nocontext x) */
-
-
#define Set_Node_Offset_To_R(node,byte) STMT_START { \
if (! SIZE_ONLY) { \
MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
- __LINE__, (node), (byte))); \
+ __LINE__, (node), (int)(byte))); \
if((node) < 0) { \
Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
} else { \
#define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
#define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
+#define Set_Node_Offset_Length(node,offset,len) STMT_START { \
+ Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
+ Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
+} STMT_END
+
+
+#if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
+#define EXPERIMENTAL_INPLACESCAN
+#endif
+
static void clear_re(pTHX_ void *r);
/* Mark that we cannot extend a found fixed substring at this point.
} STMT_END
#define TRIE_READ_CHAR STMT_START { \
+ wordlen++; \
if ( UTF ) { \
if ( folder ) { \
if ( foldlen > 0 ) { \
TRIE_LIST_LEN( state ) = 4; \
} STMT_END
-#define TRIE_HANDLE_WORD(state) STMT_START { \
- if ( !trie->states[ state ].wordnum ) { \
- /* we havent inserted this word into the structure yet. */\
+#define TRIE_HANDLE_WORD(state) STMT_START { \
+ if ( !trie->states[ state ].wordnum ) { \
+ /* we haven't inserted this word into the structure yet. */ \
+ if (trie->wordlen) \
+ trie->wordlen[ curword ] = wordlen; \
trie->states[ state ].wordnum = ++curword; \
DEBUG_r({ \
/* store the word for dumping */ \
SV* tmp; \
- if (OP(noper) != NOTHING ) \
- tmp=newSVpvn( STRING( noper ), STR_LEN( noper ) );\
+ if (OP(noper) != NOTHING) \
+ tmp = newSVpvn(STRING(noper), STR_LEN(noper)); \
else \
- tmp=newSVpvn( "", 0 ); \
+ tmp = newSVpvn( "", 0 ); \
if ( UTF ) SvUTF8_on( tmp ); \
av_push( trie->words, tmp ); \
}); \
} STMT_END
#ifdef DEBUGGING
-/*
+/*
dump_trie(trie)
dump_trie_interim_list(trie,next_alloc)
dump_trie_interim_table(trie,next_alloc)
These routines dump out a trie in a somewhat readable format.
- The _interim_ variants are used for debugging the interim
- tables that are used to generate the final compressed
- representation which is what dump_trie expects.
-
+ The _interim_ variants are used for debugging the interim
+ tables that are used to generate the final compressed
+ representation which is what dump_trie expects.
+
Part of the reason for their existance is to provide a form
of documentation as to how the different representations function.
-
-*/
+
+*/
/*
dump_trie(trie)
trie->states[ TRIE_NODENUM( state ) ].wordnum );
}
}
-}
+}
#endif
+#define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
+ ( ( base + charid >= ucharcount \
+ && base + charid < ubound \
+ && state == trie->trans[ base - ucharcount + charid ].check \
+ && trie->trans[ base - ucharcount + charid ].next ) \
+ ? trie->trans[ base - ucharcount + charid ].next \
+ : ( state==1 ? special : 0 ) \
+ )
+STATIC void
+S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
+{
+/* The Trie is constructed and compressed now so we can build a fail array now if its needed
+
+ This is apparently the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
+ "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
+ ISBN 0-201-10088-6
+
+ We find the fail state for each state in the trie, this state is the longest proper
+ suffix of the current states 'word' that is also a proper prefix of another word in our
+ trie. State 1 represents the word '' and is the thus the default fail state. This allows
+ the DFA not to have to restart after its tried and failed a word at a given point, it
+ simply continues as though it had been matching the other word in the first place.
+ Consider
+ 'abcdgu'=~/abcdefg|cdgu/
+ When we get to 'd' we are still matching the first word, we would encounter 'g' which would
+ fail, which would bring use to the state representing 'd' in the second word where we would
+ try 'g' and succeed, prodceding to match 'cdgu'.
+ */
+ /* add a fail transition */
+ reg_trie_data *trie=(reg_trie_data *)RExC_rx->data->data[ARG(source)];
+ U32 *q;
+ U32 ucharcount = trie->uniquecharcount;
+ U32 numstates = trie->laststate;
+ U32 ubound = trie->lasttrans + ucharcount;
+ U32 q_read = 0;
+ U32 q_write = 0;
+ U32 charid;
+ U32 base = trie->states[ 1 ].trans.base;
+ U32 newstate;
+ U32 *fail;
+ reg_ac_data *aho;
+ const U32 data_slot = add_data( pRExC_state, 1, "T" );
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ ARG_SET( stclass, data_slot );
+ Newxz( aho, 1, reg_ac_data );
+ RExC_rx->data->data[ data_slot ] = (void*)aho;
+ aho->trie=trie;
+ aho->states=(reg_trie_state *)savepvn((const char*)trie->states,
+ (trie->laststate+1)*sizeof(reg_trie_state));
+ Newxz( q, numstates, U32);
+ Newxz( aho->fail, numstates, U32 );
+ fail= aho->fail;
+ fail[ 0 ] = fail[ 1 ] = 1;
+
+ for ( charid = 0; charid < ucharcount ; charid++ ) {
+ newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
+ if ( newstate )
+ {
+ q[ q_write ] = newstate;
+ /* set to point at the root */
+ fail[ q[ q_write++ ] ]=1;
+ }
+ }
+ while ( q_read < q_write) {
+ U32 cur = q[ q_read++ % numstates ];
+ U32 ch_state;
+ base = trie->states[ cur ].trans.base;
+
+ for ( charid = 0 ; charid < ucharcount ; charid++ ) {
+ if ( ( ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ) ) ) {
+ U32 fail_state = cur;
+ U32 fail_base;
+ do {
+ fail_state = fail[ fail_state ];
+ fail_base = aho->states[ fail_state ].trans.base;
+ } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
+
+ fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
+ fail[ ch_state ] = fail_state;
+ if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
+ {
+ aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
+ }
+ q[ q_write++ % numstates] = ch_state;
+ }
+ }
+ }
+
+ DEBUG_TRIE_COMPILE_MORE_r({
+ PerlIO_printf(Perl_debug_log, "%*sFail: 1", (int)(depth * 2), "");
+ for( q_read=2; q_read<numstates; q_read++ ) {
+ PerlIO_printf(Perl_debug_log, ", %"UVuf, fail[q_read]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ });
+ Safefree(q);
+ /*RExC_seen |= REG_SEEN_TRIEDFA;*/
+}
*/
U16 trie_wordcount=0;
STRLEN trie_charcount=0;
- U32 trie_laststate=0;
+ /*U32 trie_laststate=0;*/
AV *trie_revcharmap;
#endif
GET_RE_DEBUG_FLAGS_DECL;
STRLEN foldlen = 0;
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
const U8 *scan = (U8*)NULL;
+ U32 wordlen = 0; /* required init */
STRLEN chars=0;
TRIE_WORDCOUNT(trie)++;
( trie->widecharmap ? "UTF8" : "NATIVE" ), TRIE_WORDCOUNT(trie),
(int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, trie->minlen, trie->maxlen )
);
-
+ Newxz( trie->wordlen, TRIE_WORDCOUNT(trie), U32 );
/*
We now know what we are dealing with in terms of unique chars and
U16 charid = 0; /* sanity init */
U8 *scan = (U8*)NULL; /* sanity init */
STRLEN foldlen = 0; /* required init */
+ U32 wordlen = 0; /* required init */
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
if (OP(noper) != NOTHING) {
U8 *scan = (U8*)NULL; /* sanity init */
STRLEN foldlen = 0; /* required init */
+ U32 wordlen = 0; /* required init */
U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
if ( OP(noper) != NOTHING ) {
DEBUG_TRIE_COMPILE_r(
dump_trie(trie,depth+1)
);
-
+
{ /* Modify the program and insert the new TRIE node*/
regnode *convert;
U8 nodetype =(U8)(flags & 0xFF);
char *str=NULL;
+#ifdef DEBUGGING
+ U32 mjd_offset;
+ U32 mjd_nodelen;
+#endif
/*
This means we convert either the first branch or the first Exact,
depending on whether the thing following (in 'last') is a branch
*/
/* Find the node we are going to overwrite */
if ( first == startbranch && OP( last ) != BRANCH ) {
+ /* whole branch chain */
convert = first;
- } else {
+ DEBUG_r({
+ const regnode *nop = NEXTOPER( convert );
+ mjd_offset= Node_Offset((nop));
+ mjd_nodelen= Node_Length((nop));
+ });
+ } else {
+ /* branch sub-chain */
convert = NEXTOPER( first );
NEXT_OFF( first ) = (U16)(last - first);
- }
+ DEBUG_r({
+ mjd_offset= Node_Offset((convert));
+ mjd_nodelen= Node_Length((convert));
+ });
+ }
+ DEBUG_OPTIMISE_r(
+ PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
+ (int)depth * 2 + 2, "",
+ mjd_offset,mjd_nodelen)
+ );
/* But first we check to see if there is a common prefix we can
split out as an EXACT and put in front of the TRIE node. */
{
if ( ++count > 1 ) {
SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0);
- const char *ch = SvPV_nolen_const( *tmp );
+ const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
if ( state == 1 ) break;
if ( count == 2 ) {
Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
state));
if (idx>-1) {
SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
- const char *ch = SvPV_nolen_const( *tmp );
+ const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
TRIE_BITMAP_SET(trie,*ch);
if ( folder )
TRIE_BITMAP_SET(trie, folder[ *ch ]);
DEBUG_OPTIMISE_r(
- PerlIO_printf(Perl_debug_log, ch)
+ PerlIO_printf(Perl_debug_log, (char*)ch)
);
}
}
}
if (str) {
regnode *n = convert+NODE_SZ_STR(convert);
- NEXT_OFF(convert)= NODE_SZ_STR(convert);
+ NEXT_OFF(convert) = NODE_SZ_STR(convert);
trie->startstate = state;
- trie->minlen-= (state-1);
- trie->maxlen-= (state-1);
+ trie->minlen -= (state - 1);
+ trie->maxlen -= (state - 1);
+ DEBUG_r({
+ regnode *fix = convert;
+ mjd_nodelen++;
+ Set_Node_Offset_Length(convert, mjd_offset, state - 1);
+ while( ++fix < n ) {
+ Set_Node_Offset_Length(fix, 0, 0);
+ }
+ });
if (trie->maxlen) {
convert = n;
} else {
/* needed for dumping*/
DEBUG_r({
regnode *optimize = convert + NODE_STEP_REGNODE + regarglen[ TRIE ];
+ regnode *opt = convert;
+ while (++opt<optimize) {
+ Set_Node_Offset_Length(opt,0,0);
+ }
/* We now need to mark all of the space originally used by the
branches as optimized away. This keeps the dumpuntil from
throwing a wobbly as it doesnt use regnext() to traverse the
opcodes.
+ We also "fix" the offsets
*/
while( optimize < last ) {
+ mjd_nodelen += Node_Length((optimize));
OP( optimize ) = OPTIMIZED;
+ Set_Node_Offset_Length(optimize,0,0);
optimize++;
}
+ Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
});
} /* end node insert */
-#ifndef DEBUGGING
+#ifndef DEBUGGING
SvREFCNT_dec(TRIE_REVCHARMAP(trie));
-#endif
+#endif
return 1;
}
# endif
#endif
+#define DEBUG_PEEP(str,scan,depth) \
+ DEBUG_OPTIMISE_r({ \
+ SV * const mysv=sv_newmortal(); \
+ regnode *Next = regnext(scan); \
+ regprop(RExC_rx, mysv, scan); \
+ PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s [%d]\n", \
+ (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
+ Next ? (REG_NODE_NUM(Next)) : 0 ); \
+ });
+
+#define JOIN_EXACT(scan,min,flags) \
+ if (PL_regkind[OP(scan)] == EXACT) \
+ join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
+
+U32
+S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
+ /* Merge several consecutive EXACTish nodes into one. */
+ regnode *n = regnext(scan);
+ U32 stringok = 1;
+ regnode *next = scan + NODE_SZ_STR(scan);
+ U32 merged = 0;
+ U32 stopnow = 0;
+#ifdef DEBUGGING
+ regnode *stop = scan;
+#endif
+ GET_RE_DEBUG_FLAGS_DECL;
+ DEBUG_PEEP("join",scan,depth);
+
+ /* Skip NOTHING, merge EXACT*. */
+ while (n &&
+ ( PL_regkind[OP(n)] == NOTHING ||
+ (stringok && (OP(n) == OP(scan))))
+ && NEXT_OFF(n)
+ && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
+
+ if (OP(n) == TAIL || n > next)
+ stringok = 0;
+ if (PL_regkind[OP(n)] == NOTHING) {
+
+ DEBUG_PEEP("skip:",n,depth);
+ NEXT_OFF(scan) += NEXT_OFF(n);
+ next = n + NODE_STEP_REGNODE;
+#ifdef DEBUGGING
+ if (stringok)
+ stop = n;
+#endif
+ n = regnext(n);
+ }
+ else if (stringok) {
+ const int oldl = STR_LEN(scan);
+ regnode * const nnext = regnext(n);
+
+ DEBUG_PEEP("merg",n,depth);
+
+ merged++;
+ if (oldl + STR_LEN(n) > U8_MAX)
+ break;
+ NEXT_OFF(scan) += NEXT_OFF(n);
+ STR_LEN(scan) += STR_LEN(n);
+ next = n + NODE_SZ_STR(n);
+ /* Now we can overwrite *n : */
+ Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
+#ifdef DEBUGGING
+ stop = next - 1;
+#endif
+ n = nnext;
+ if (stopnow) break;
+ }
+
+#ifdef EXPERIMENTAL_INPLACESCAN
+ if (flags && !NEXT_OFF(n)) {
+ DEBUG_PEEP("atch",val,depth);
+ if (reg_off_by_arg[OP(n)]) {
+ ARG_SET(n, val - n);
+ }
+ else {
+ NEXT_OFF(n) = val - n;
+ }
+ stopnow=1;
+ }
+#endif
+ }
+
+ if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
+ /*
+ Two problematic code points in Unicode casefolding of EXACT nodes:
+
+ U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
+ U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
+
+ which casefold to
+
+ Unicode UTF-8
+
+ U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
+ U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
+
+ This means that in case-insensitive matching (or "loose matching",
+ as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
+ length of the above casefolded versions) can match a target string
+ of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
+ This would rather mess up the minimum length computation.
+
+ What we'll do is to look for the tail four bytes, and then peek
+ at the preceding two bytes to see whether we need to decrease
+ the minimum length by four (six minus two).
+
+ Thanks to the design of UTF-8, there cannot be false matches:
+ A sequence of valid UTF-8 bytes cannot be a subsequence of
+ another valid sequence of UTF-8 bytes.
+
+ */
+ char * const s0 = STRING(scan), *s, *t;
+ char * const s1 = s0 + STR_LEN(scan) - 1;
+ char * const s2 = s1 - 4;
+ const char t0[] = "\xcc\x88\xcc\x81";
+ const char * const t1 = t0 + 3;
+
+ for (s = s0 + 2;
+ s < s2 && (t = ninstr(s, s1, t0, t1));
+ s = t + 4) {
+ if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
+ ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
+ *min -= 4;
+ }
+ }
+
+#ifdef DEBUGGING
+ /* Allow dumping */
+ n = scan + NODE_SZ_STR(scan);
+ while (n <= stop) {
+ if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
+ OP(n) = OPTIMIZED;
+ NEXT_OFF(n) = 0;
+ }
+ n++;
+ }
+#endif
+ DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
+ return stopnow;
+}
+
/* REx optimizer. Converts nodes into quickier variants "in place".
Finds fixed substrings. */
/* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
to the position after last scanned or to NULL. */
+
+
STATIC I32
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap,
regnode *last, scan_data_t *data, U32 flags, U32 depth)
GET_RE_DEBUG_FLAGS_DECL;
while (scan && OP(scan) != END && scan < last) {
-#ifdef DEBUGGING
- int merged=0;
-#endif
/* Peephole optimizer: */
- DEBUG_OPTIMISE_r({
- SV * const mysv=sv_newmortal();
- regprop(RExC_rx, mysv, scan);
- PerlIO_printf(Perl_debug_log, "%*s%4s~ %s (%d)\n",
- (int)depth*2, "",
- scan==*scanp ? "Peep" : "",
- SvPV_nolen_const(mysv), REG_NODE_NUM(scan));
- });
- if (PL_regkind[OP(scan)] == EXACT) {
- /* Merge several consecutive EXACTish nodes into one. */
- regnode *n = regnext(scan);
- U32 stringok = 1;
-#ifdef DEBUGGING
- regnode *stop = scan;
-#endif
- next = scan + NODE_SZ_STR(scan);
- /* Skip NOTHING, merge EXACT*. */
- while (n &&
- ( PL_regkind[OP(n)] == NOTHING ||
- (stringok && (OP(n) == OP(scan))))
- && NEXT_OFF(n)
- && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
- if (OP(n) == TAIL || n > next)
- stringok = 0;
- if (PL_regkind[OP(n)] == NOTHING) {
- DEBUG_OPTIMISE_r({
- SV * const mysv=sv_newmortal();
- regprop(RExC_rx, mysv, n);
- PerlIO_printf(Perl_debug_log, "%*sskip: %s (%d)\n",
- (int)depth*2, "", SvPV_nolen_const(mysv), REG_NODE_NUM(n));
- });
- NEXT_OFF(scan) += NEXT_OFF(n);
- next = n + NODE_STEP_REGNODE;
-#ifdef DEBUGGING
- if (stringok)
- stop = n;
-#endif
- n = regnext(n);
- }
- else if (stringok) {
- const int oldl = STR_LEN(scan);
- regnode * const nnext = regnext(n);
- DEBUG_OPTIMISE_r({
- SV * const mysv=sv_newmortal();
- regprop(RExC_rx, mysv, n);
- PerlIO_printf(Perl_debug_log, "%*s mrg: %s (%d)\n",
- (int)depth*2, "", SvPV_nolen_const(mysv), REG_NODE_NUM(n));
- merged++;
- });
- if (oldl + STR_LEN(n) > U8_MAX)
- break;
- NEXT_OFF(scan) += NEXT_OFF(n);
- STR_LEN(scan) += STR_LEN(n);
- next = n + NODE_SZ_STR(n);
- /* Now we can overwrite *n : */
- Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
-#ifdef DEBUGGING
- stop = next - 1;
-#endif
- n = nnext;
- }
- }
-
- if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
-/*
- Two problematic code points in Unicode casefolding of EXACT nodes:
-
- U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
- U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
-
- which casefold to
-
- Unicode UTF-8
-
- U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
- U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
-
- This means that in case-insensitive matching (or "loose matching",
- as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
- length of the above casefolded versions) can match a target string
- of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
- This would rather mess up the minimum length computation.
-
- What we'll do is to look for the tail four bytes, and then peek
- at the preceding two bytes to see whether we need to decrease
- the minimum length by four (six minus two).
-
- Thanks to the design of UTF-8, there cannot be false matches:
- A sequence of valid UTF-8 bytes cannot be a subsequence of
- another valid sequence of UTF-8 bytes.
-
-*/
- char * const s0 = STRING(scan), *s, *t;
- char * const s1 = s0 + STR_LEN(scan) - 1;
- char * const s2 = s1 - 4;
- const char t0[] = "\xcc\x88\xcc\x81";
- const char * const t1 = t0 + 3;
-
- for (s = s0 + 2;
- s < s2 && (t = ninstr(s, s1, t0, t1));
- s = t + 4) {
- if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
- ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
- min -= 4;
- }
- }
-
-#ifdef DEBUGGING
- /* Allow dumping */
- n = scan + NODE_SZ_STR(scan);
- while (n <= stop) {
- if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
- OP(n) = OPTIMIZED;
- NEXT_OFF(n) = 0;
- }
- n++;
- }
-#endif
- }
-
+ DEBUG_PEEP("Peep",scan,depth);
+ JOIN_EXACT(scan,&min,0);
/* Follow the next-chain of the current node and optimize
away all the NOTHINGs from it. */
NEXT_OFF(scan) = off;
}
- DEBUG_OPTIMISE_r({if (merged){
- SV * const mysv=sv_newmortal();
- regprop(RExC_rx, mysv, scan);
- PerlIO_printf(Perl_debug_log, "%*s res: %s (%d)\n",
- (int)depth*2, "", SvPV_nolen_const(mysv), REG_NODE_NUM(scan));
- }});
+
/* The principal pseudo-switch. Cannot be a switch, since we
look into several different things. */
pars++;
if (data) {
if (data_fake.flags & SF_HAS_EVAL)
- data->flags |= SF_HAS_EVAL;
+ data->flags |= SF_HAS_EVAL;
data->whilem_c = data_fake.whilem_c;
}
if (flags & SCF_DO_STCLASS)
it would just call its tail, no WHILEM/CURLY needed.
*/
- if (DO_TRIE) {
+ if (PERL_ENABLE_TRIE_OPTIMISATION) {
int made=0;
if (!re_trie_maxbuff) {
re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
if ( last ) {
made+= make_trie( pRExC_state, startbranch, first, scan, tail, optype, depth+1 );
#ifdef TRIE_STUDY_OPT
- if ( OP(first)!=TRIE && startbranch == first ) {
-
- }
+ if ( made && startbranch == first ) {
+ if ( OP(first)!=TRIE )
+ flags |= SCF_EXACT_TRIE;
+ else {
+ regnode *chk=*scanp;
+ while ( OP( chk ) == OPEN )
+ chk = regnext( chk );
+ if (chk==first)
+ flags |= SCF_EXACT_TRIE;
+ }
+ }
#endif
+ }
}
- }
} /* do trie */
}
else if (OP(scan) == TRIE) {
reg_trie_data *trie=RExC_rx->data->data[ ARG(scan) ];
min += trie->minlen;
+ delta += (trie->maxlen - trie->minlen);
flags &= ~SCF_DO_STCLASS; /* xxx */
if (flags & SCF_DO_SUBSTR) {
scan_commit(pRExC_state,data); /* Cannot expect anything... */
data->pos_min += trie->minlen;
- data->pos_delta+= (trie->maxlen-trie->minlen);
+ data->pos_delta += (trie->maxlen - trie->minlen);
+ if (trie->maxlen != trie->minlen)
+ data->longest = &(data->longest_float);
}
}
#endif
}
if (flags & SCF_DO_STCLASS_OR)
cl_and(data->start_class, &and_with);
+ if (flags & SCF_EXACT_TRIE)
+ data->flags |= SCF_EXACT_TRIE;
return min;
}
}
#endif
+
/*
- pregcomp - compile a regular expression into internal code
*
scan_data_t data;
RExC_state_t RExC_state;
RExC_state_t *pRExC_state = &RExC_state;
+#ifdef TRIE_STUDY_OPT
+ int restudied= 0;
+ RExC_state_t copyRExC_state;
+#endif
GET_RE_DEBUG_FLAGS_DECL;
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Required "));
DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" nodes ", (IV)RExC_size));
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nStarting second pass (creation)\n"));
+ DEBUG_PARSE_r({
+ RExC_lastnum=0;
+ RExC_lastparse=NULL;
+ });
+
/* Small enough for pointer-storage convention?
If extralen==0, this means that we will not need long jumps. */
if (RExC_size >= 0x10000L && RExC_extralen)
r->data = 0;
if (reg(pRExC_state, 0, &flags,1) == NULL)
return(NULL);
+ /* XXXX To minimize changes to RE engine we always allocate
+ 3-units-long substrs field. */
+ Newx(r->substrs, 1, struct reg_substr_data);
+reStudy:
+ Zero(r->substrs, 1, struct reg_substr_data);
+ StructCopy(&zero_scan_data, &data, scan_data_t);
+#ifdef TRIE_STUDY_OPT
+ if ( restudied ) {
+ DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
+ RExC_state=copyRExC_state;
+ if (data.longest_fixed)
+ SvREFCNT_dec(data.longest_fixed);
+ if (data.longest_float)
+ SvREFCNT_dec(data.longest_float);
+ if (data.last_found)
+ SvREFCNT_dec(data.last_found);
+ } else {
+ copyRExC_state=RExC_state;
+ }
+#endif
/* Dig out information for optimizations. */
r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
pm->op_pmflags = RExC_flags;
r->reganch |= ROPT_NAUGHTY;
scan = r->program + 1; /* First BRANCH. */
- /* XXXX To minimize changes to RE engine we always allocate
- 3-units-long substrs field. */
- Newxz(r->substrs, 1, struct reg_substr_data);
-
- StructCopy(&zero_scan_data, &data, scan_data_t);
/* XXXX Should not we check for something else? Usually it is OPEN1... */
if (OP(scan) != BRANCH) { /* Only one top-level choice. */
I32 fake;
STRLEN longest_float_length, longest_fixed_length;
- struct regnode_charclass_class ch_class;
+ struct regnode_charclass_class ch_class; /* pointed to by data */
int stclass_flag;
- I32 last_close = 0;
+ I32 last_close = 0; /* pointed to by data */
first = scan;
/* Skip introductions and multiplicators >= 1. */
while ((OP(first) == OPEN && (sawopen = 1)) ||
/* An OR of *one* alternative - should not happen now. */
(OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
+ /* for now we can't handle lookbehind IFMATCH*/
+ (OP(first) == IFMATCH && !first->flags) ||
(OP(first) == PLUS) ||
(OP(first) == MINMOD) ||
/* An {n,m} with n>0 */
- (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ) {
+ (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) )
+ {
+ DEBUG_PEEP("first:",first,0);
if (OP(first) == PLUS)
sawplus = 1;
else
first += regarglen[OP(first)];
- first = NEXTOPER(first);
+ if (OP(first) == IFMATCH) {
+ first = NEXTOPER(first);
+ first += EXTRA_STEP_2ARGS;
+ } else /*xxx possible optimisation for /(?=)/*/
+ first = NEXTOPER(first);
}
/* Starting-point info. */
again:
+ /* Ignore EXACT as we deal with it later. */
if (PL_regkind[OP(first)] == EXACT) {
if (OP(first) == EXACT)
NOOP; /* Empty, get anchored substr later. */
else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
r->regstclass = first;
}
+#ifdef TRIE_STCLASS
+ else if (OP(first) == TRIE &&
+ ((reg_trie_data *)r->data->data[ ARG(first) ])->minlen>0)
+ {
+ /* this can happen only on restudy */
+ struct regnode_1 *trie_op;
+ Newxz(trie_op,1,struct regnode_1);
+ StructCopy(first,trie_op,struct regnode_1);
+ make_trie_failtable(pRExC_state, (regnode *)first, (regnode *)trie_op, 0);
+ r->regstclass = (regnode *)trie_op;
+ }
+#endif
else if (strchr((const char*)PL_simple,OP(first)))
r->regstclass = first;
else if (PL_regkind[OP(first)] == BOUND ||
minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
&data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
+
+#ifdef TRIE_STUDY_OPT
+ if ( (data.flags & SCF_EXACT_TRIE) && ! restudied++ ) {
+ goto reStudy;
+ }
+#endif
+
if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
&& data.last_start_min == 0 && data.last_end > 0
&& !RExC_seen_zerolen
I32 last_close = 0;
DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n"));
+
scan = r->program + 1;
cl_init(pRExC_state, &ch_class);
data.start_class = &ch_class;
data.last_closep = &last_close;
- minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
+
+ minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size,
+ &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
+
+#ifdef TRIE_STUDY_OPT
+ if ( (data.flags & SCF_EXACT_TRIE) && ! restudied++ ) {
+ goto reStudy;
+ }
+#endif
+
r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
= r->float_substr = r->float_utf8 = NULL;
if (!(data.start_class->flags & ANYOF_EOS)
r->reganch |= ROPT_CANY_SEEN;
Newxz(r->startp, RExC_npar, I32);
Newxz(r->endp, RExC_npar, I32);
+
DEBUG_COMPILE_r({
if (SvIV(re_debug_flags)> (RE_DEBUG_COMPILE | RE_DEBUG_EXECUTE))
PerlIO_printf(Perl_debug_log,"Final program:\n");
RExC_lastparse=RExC_parse; \
})
+
+
#define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
DEBUG_PARSE_MSG((funcname)); \
PerlIO_printf(Perl_debug_log,"%4s","\n"); \
* is a trifle forced, but the need to tie the tails of the branches to what
* follows makes it hard to avoid.
*/
-#define REGTAIL(x,y,z) regtail(x,y,z,depth+1)
+#define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
+#ifdef DEBUGGING
+#define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
+#else
+#define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
+#endif
STATIC regnode *
S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
ender = reg_node(pRExC_state, END);
break;
}
- REGTAIL(pRExC_state, lastbr, ender);
+ REGTAIL_STUDY(pRExC_state, lastbr, ender);
if (have_branch && !SIZE_ONLY) {
/* Hook the tails of the branches to the closing node. */
- U8 exact= PSEUDO;
for (br = ret; br; br = regnext(br)) {
const U8 op = PL_regkind[OP(br)];
- U8 exact_ret;
if (op == BRANCH) {
- exact_ret=regtail_study(pRExC_state, NEXTOPER(br), ender,depth+1);
+ REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
}
else if (op == BRANCHJ) {
- exact_ret=regtail_study(pRExC_state, NEXTOPER(NEXTOPER(br)), ender,depth+1);
+ REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
}
- if ( exact == PSEUDO )
- exact= exact_ret;
- else if ( exact != exact_ret )
- exact= 0;
}
}
}
Set_Node_Cur_Length(ret);
Set_Node_Offset(ret, parse_start + 1);
ret->flags = flag;
- REGTAIL(pRExC_state, ret, reg_node(pRExC_state, TAIL));
+ REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
}
}
else {
STR_LEN(ret) = len;
RExC_emit += STR_SZ(len);
- }
+ }
}
break;
}
S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
{
dVAR;
- register UV value = 0;
+ register UV value;
register UV nextvalue;
register IV prevvalue = OOB_UNICODE;
register IV range = 0;
regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
case we need to change the emitted regop to an EXACT. */
+ const char * orig_parse = RExC_parse;
GET_RE_DEBUG_FLAGS_DECL;
DEBUG_PARSE("clas");
}
/* now is the next time */
- stored += (value - prevvalue + 1);
+ /*stored += (value - prevvalue + 1);*/
if (!SIZE_ONLY) {
if (prevvalue < 256) {
const IV ceilvalue = value < 256 ? value : 255;
}
else
#endif
- for (i = prevvalue; i <= ceilvalue; i++)
- ANYOF_BITMAP_SET(ret, i);
+ for (i = prevvalue; i <= ceilvalue; i++) {
+ if (!ANYOF_BITMAP_TEST(ret,i)) {
+ stored++;
+ ANYOF_BITMAP_SET(ret, i);
+ }
+ }
}
if (value > 255 || UTF) {
const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
const UV natvalue = NATIVE_TO_UNI(value);
-
+ stored+=2; /* can't optimize this class */
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
if (prevnatvalue < natvalue) { /* what about > ? */
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
) {
/* optimize single char class to an EXACT node
but *only* when its not a UTF/high char */
- RExC_emit = orig_emit;
+ const char * cur_parse= RExC_parse;
+ RExC_emit = (regnode *)orig_emit;
+ RExC_parse = (char *)orig_parse;
ret = reg_node(pRExC_state,
(U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
+ RExC_parse = (char *)cur_parse;
*STRING(ret)= (char)value;
STR_LEN(ret)= 1;
RExC_emit += STR_SZ(1);
dVAR;
register regnode *ptr;
regnode * const ret = RExC_emit;
+ GET_RE_DEBUG_FLAGS_DECL;
if (SIZE_ONLY) {
SIZE_ALIGN(RExC_size);
ptr = ret;
FILL_ADVANCE_NODE(ptr, op);
if (RExC_offsets) { /* MJD */
- MJD_OFFSET_DEBUG(("%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
+ MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
"reg_node", __LINE__,
reg_name[op],
- RExC_emit - RExC_emit_start > RExC_offsets[0]
- ? "Overwriting end of array!\n" : "OK",
- RExC_emit - RExC_emit_start,
- RExC_parse - RExC_start,
- RExC_offsets[0]));
+ (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
+ ? "Overwriting end of array!\n" : "OK",
+ (UV)(RExC_emit - RExC_emit_start),
+ (UV)(RExC_parse - RExC_start),
+ (UV)RExC_offsets[0]));
Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
}
-
+
RExC_emit = ptr;
return(ret);
dVAR;
register regnode *ptr;
regnode * const ret = RExC_emit;
+ GET_RE_DEBUG_FLAGS_DECL;
if (SIZE_ONLY) {
SIZE_ALIGN(RExC_size);
ptr = ret;
FILL_ADVANCE_NODE_ARG(ptr, op, arg);
if (RExC_offsets) { /* MJD */
- MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n",
+ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
"reganode",
__LINE__,
reg_name[op],
- RExC_emit - RExC_emit_start > RExC_offsets[0] ?
+ (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
"Overwriting end of array!\n" : "OK",
- RExC_emit - RExC_emit_start,
- RExC_parse - RExC_start,
- RExC_offsets[0]));
+ (UV)(RExC_emit - RExC_emit_start),
+ (UV)(RExC_parse - RExC_start),
+ (UV)RExC_offsets[0]));
Set_Cur_Node_Offset;
}
register regnode *dst;
register regnode *place;
const int offset = regarglen[(U8)op];
-
+ GET_RE_DEBUG_FLAGS_DECL;
/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
if (SIZE_ONLY) {
while (src > opnd) {
StructCopy(--src, --dst, regnode);
if (RExC_offsets) { /* MJD 20010112 */
- MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %u -> %u (max %u).\n",
+ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
"reg_insert",
__LINE__,
reg_name[op],
- dst - RExC_emit_start > RExC_offsets[0]
- ? "Overwriting end of array!\n" : "OK",
- src - RExC_emit_start,
- dst - RExC_emit_start,
- RExC_offsets[0]));
+ (UV)(dst - RExC_emit_start) > RExC_offsets[0]
+ ? "Overwriting end of array!\n" : "OK",
+ (UV)(src - RExC_emit_start),
+ (UV)(dst - RExC_emit_start),
+ (UV)RExC_offsets[0]));
Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
}
place = opnd; /* Op node, where operand used to be. */
if (RExC_offsets) { /* MJD */
- MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n",
+ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
"reginsert",
__LINE__,
reg_name[op],
- place - RExC_emit_start > RExC_offsets[0]
+ (UV)(place - RExC_emit_start) > RExC_offsets[0]
? "Overwriting end of array!\n" : "OK",
- place - RExC_emit_start,
- RExC_parse - RExC_start,
+ (UV)(place - RExC_emit_start),
+ (UV)(RExC_parse - RExC_start),
RExC_offsets[0]));
Set_Node_Offset(place, RExC_parse);
Set_Node_Length(place, 1);
}
}
+#ifdef DEBUGGING
/*
- regtail_study - set the next-pointer at the end of a node chain of p to val.
- Look for optimizable sequences at the same time.
- currently only looks for EXACT chains.
+
+This is expermental code. The idea is to use this routine to perform
+in place optimizations on branches and groups as they are constructed,
+with the long term intention of removing optimization from study_chunk so
+that it is purely analytical.
+
+Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
+to control which is which.
+
*/
/* TODO: All four parms should be const */
+
STATIC U8
S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
{
dVAR;
register regnode *scan;
- U8 exact= PSEUDO;
+ U8 exact = PSEUDO;
+#ifdef EXPERIMENTAL_INPLACESCAN
+ I32 min = 0;
+#endif
+
GET_RE_DEBUG_FLAGS_DECL;
+
if (SIZE_ONLY)
return exact;
scan = p;
for (;;) {
regnode * const temp = regnext(scan);
+#ifdef EXPERIMENTAL_INPLACESCAN
+ if (PL_regkind[OP(scan)] == EXACT)
+ if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
+ return EXACT;
+#endif
if ( exact ) {
switch (OP(scan)) {
case EXACT:
case EXACTFL:
if( exact == PSEUDO )
exact= OP(scan);
- else if ( exact != OP(scan) )
- exact= 0;
+ else if ( exact != OP(scan) )
+ exact= 0;
case NOTHING:
break;
default:
break;
scan = temp;
}
-
+ DEBUG_PARSE_r({
+ SV * const mysv_val=sv_newmortal();
+ DEBUG_PARSE_MSG("");
+ regprop(RExC_rx, mysv_val, val);
+ PerlIO_printf(Perl_debug_log, "~ attach to %s (%d) offset to %d\n",
+ SvPV_nolen_const(mysv_val),
+ REG_NODE_NUM(val),
+ val - scan
+ );
+ });
if (reg_off_by_arg[OP(scan)]) {
ARG_SET(scan, val - scan);
}
return exact;
}
+#endif
/*
- regcurly - a little FSA that accepts {\d+,?\d*}
DEBUG_OFFSETS_r({
U32 i;
PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
- for (i = 1; i <= len; i++)
+ for (i = 1; i <= len; i++) {
+ if (!(SvIV(re_debug_flags) & RE_DEBUG_OLD_OFFSETS)) {
+ if (r->offsets[i*2-1] || r->offsets[i*2])
+ PerlIO_printf(Perl_debug_log, "%"UVuf":",i);
+ else
+ continue;
+ }
PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
(UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
+ }
PerlIO_printf(Perl_debug_log, "\n");
});
}
Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
}
else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
- Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
+ Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
break;
case 'n':
break;
+ case 'T':
+ {
+ U32 refcount;
+ reg_ac_data *aho=(reg_ac_data*)r->data->data[n];
+ OP_REFCNT_LOCK;
+ refcount = --aho->refcount;
+ OP_REFCNT_UNLOCK;
+ if ( !refcount ) {
+ Safefree(aho->states);
+ Safefree(aho->fail);
+ aho->trie=NULL; /* not necessary to free this as it is
+ handled by the 't' case */
+ Safefree(r->data->data[n]); /* do this last!!!! */
+ }
+ }
+ break;
case 't':
- {
- reg_trie_data * const trie=(reg_trie_data*)r->data->data[n];
- U32 refcount;
- OP_REFCNT_LOCK;
- refcount = --trie->refcount;
- OP_REFCNT_UNLOCK;
- if ( !refcount ) {
- Safefree(trie->charmap);
- if (trie->widecharmap)
- SvREFCNT_dec((SV*)trie->widecharmap);
- Safefree(trie->states);
- Safefree(trie->trans);
- if (trie->bitmap)
- Safefree(trie->bitmap);
+ {
+ U32 refcount;
+ reg_trie_data *trie=(reg_trie_data*)r->data->data[n];
+ OP_REFCNT_LOCK;
+ refcount = --trie->refcount;
+ OP_REFCNT_UNLOCK;
+ if ( !refcount ) {
+ Safefree(trie->charmap);
+ if (trie->widecharmap)
+ SvREFCNT_dec((SV*)trie->widecharmap);
+ Safefree(trie->states);
+ Safefree(trie->trans);
+ if (trie->bitmap)
+ Safefree(trie->bitmap);
+ if (trie->wordlen)
+ Safefree(trie->wordlen);
#ifdef DEBUGGING
- if (trie->words)
- SvREFCNT_dec((SV*)trie->words);
- if (trie->revcharmap)
- SvREFCNT_dec((SV*)trie->revcharmap);
+ if (trie->words)
+ SvREFCNT_dec((SV*)trie->words);
+ if (trie->revcharmap)
+ SvREFCNT_dec((SV*)trie->revcharmap);
#endif
- Safefree(r->data->data[n]); /* do this last!!!! */
- }
- break;
+ Safefree(r->data->data[n]); /* do this last!!!! */
}
+ }
+ break;
default:
Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
}
Perl_sv_catpvf(aTHX_ sv, "%c", c);
}
-
#define CLEAR_OPTSTART \
if (optstart) STMT_START { \
- PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart); \
+ DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart)); \
optstart=NULL; \
} STMT_END
if (op == CLOSE)
l--;
next = regnext((regnode *)node);
+
/* Where, what. */
if (OP(node) == OPTIMIZED) {
if (!optstart && (SvIV(re_debug_flags) & RE_DEBUG_OPTIMISE))
goto after_print;
} else
CLEAR_OPTSTART;
+
regprop(r, sv, node);
PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
(int)(2*l + 1), "", SvPVX_const(sv));
const I32 arry_len = av_len(trie->words)+1;
I32 word_idx;
PerlIO_printf(Perl_debug_log,
- "%*s[Start:%"UVuf" Words:%d Chars:%d Unique:%d States:%"IVdf" Minlen:%d Maxlen:%d",
+ "%*s[StS:%"UVuf" Wds:%d Cs:%d Uq:%d #Sts:%"IVdf" Mn:%d Mx:%d",
(int)(2*(l+3)),
"",
trie->startstate,
rangestart = -1;
}
}
- PerlIO_printf(Perl_debug_log, " Start-Class:%s]\n", SvPVX_const(sv));
+ PerlIO_printf(Perl_debug_log, " Stcls:%s]\n", SvPVX_const(sv));
} else
- PerlIO_printf(Perl_debug_log, " No Start-Class]\n");
+ PerlIO_printf(Perl_debug_log, " No-Stcls]\n");
for (word_idx=0; word_idx < arry_len; word_idx++) {
SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
SvPV_nolen_const(*elem_ptr),
PL_colors[1]
);
- /*
- if (next == NULL)
- PerlIO_printf(Perl_debug_log, "(0)\n");
- else
- PerlIO_printf(Perl_debug_log, "(%"IVdf")\n", (IV)(next - start));
- */
}
-
}
node = NEXTOPER(node);
? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
: (U8*)(pos + off))
#define HOPBACKc(pos, off) \
- (char*)(PL_reg_match_utf8 \
- ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
- : (pos - off >= PL_bostr) \
+ (char*)(PL_reg_match_utf8\
+ ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
+ : (pos - off >= PL_bostr) \
? (U8*)pos - off \
: NULL)
/* Last resort... */
/* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
- if (prog->regstclass) {
+ if (prog->regstclass && OP(prog->regstclass)!=TRIE) {
/* minlen == 0 is possible if regstclass is \b or \B,
and the fixed substr is ''$.
Since minlen is already taken into account, s+1 is before strend;
const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
? CHR_DIST(str+STR_LEN(prog->regstclass), str)
: 1);
- const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
+ const char * endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
: (prog->float_substr || prog->float_utf8
? HOP3c(HOP3c(check_at, -start_shift, strbeg),
cl_l, strend)
: strend);
-
+ /*if (OP(prog->regstclass) == TRIE)
+ endpos++;*/
t = s;
s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
if (!s) {
/* We know what class REx starts with. Try to find this position... */
/* if reginfo is NULL, its a dryrun */
+/* annoyingly all the vars in this routine have different names from their counterparts
+ in regmatch. /grrr */
STATIC char *
-S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char
-*strend, const regmatch_info *reginfo)
+S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
+ const char *strend, const regmatch_info *reginfo)
{
dVAR;
const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
}
}
break;
+ case TRIE:
+ /*Perl_croak(aTHX_ "panic: unknown regstclass TRIE");*/
+ {
+ const enum { trie_plain, trie_utf8, trie_utf8_fold }
+ trie_type = do_utf8 ?
+ (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
+ : trie_plain;
+ /* what trie are we using right now */
+ reg_ac_data *aho
+ = (reg_ac_data*)prog->data->data[ ARG( c ) ];
+ reg_trie_data *trie=aho->trie;
+
+ const char *last_start = strend - trie->minlen;
+ const char *real_start = s;
+ STRLEN maxlen = trie->maxlen;
+ U8 **points;
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ Newxz(points,maxlen,U8 *);
+
+ if (trie->bitmap && trie_type != trie_utf8_fold) {
+ while (!TRIE_BITMAP_TEST(trie,*s) && s <= last_start ) {
+ s++;
+ }
+ }
+
+ while (s <= last_start) {
+ const U32 uniflags = UTF8_ALLOW_DEFAULT;
+ U8 *uc = (U8*)s;
+ U16 charid = 0;
+ U32 base = 1;
+ U32 state = 1;
+ UV uvc = 0;
+ STRLEN len = 0;
+ STRLEN foldlen = 0;
+ U8 *uscan = (U8*)NULL;
+ U8 *leftmost = NULL;
+
+ U32 pointpos = 0;
+
+ while ( state && uc <= (U8*)strend ) {
+ int failed=0;
+ if (aho->states[ state ].wordnum) {
+ U8 *lpos= points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1] ) % maxlen ];
+ if (!leftmost || lpos < leftmost)
+ leftmost= lpos;
+ if (base==0) break;
+ }
+ points[pointpos++ % maxlen]= uc;
+ switch (trie_type) {
+ case trie_utf8_fold:
+ if ( foldlen>0 ) {
+ uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
+ foldlen -= len;
+ uscan += len;
+ len=0;
+ } else {
+ U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
+ uvc = to_uni_fold( uvc, foldbuf, &foldlen );
+ foldlen -= UNISKIP( uvc );
+ uscan = foldbuf + UNISKIP( uvc );
+ }
+ break;
+ case trie_utf8:
+ uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
+ &len, uniflags );
+ break;
+ case trie_plain:
+ uvc = (UV)*uc;
+ len = 1;
+ }
+
+ if (uvc < 256) {
+ charid = trie->charmap[ uvc ];
+ }
+ else {
+ charid = 0;
+ if (trie->widecharmap) {
+ SV** const svpp = hv_fetch(trie->widecharmap,
+ (char*)&uvc, sizeof(UV), 0);
+ if (svpp)
+ charid = (U16)SvIV(*svpp);
+ }
+ }
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "Pos: %d Charid:%3x CV:%4"UVxf" ",
+ (int)((const char*)uc - real_start), charid, uvc)
+ );
+ uc += len;
+
+ do {
+ U32 word = aho->states[ state ].wordnum;
+ base = aho->states[ state ].trans.base;
+
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf" word=%"UVxf"\n",
+ failed ? "Fail transition to " : "",
+ state, base, uvc, word)
+ );
+ if ( base ) {
+ U32 tmp;
+ if (charid &&
+ (base + charid > trie->uniquecharcount )
+ && (base + charid - 1 - trie->uniquecharcount
+ < trie->lasttrans)
+ && trie->trans[base + charid - 1 -
+ trie->uniquecharcount].check == state
+ && (tmp=trie->trans[base + charid - 1 -
+ trie->uniquecharcount ].next))
+ {
+ state = tmp;
+ break;
+ }
+ else {
+ failed++;
+ if ( state == 1 )
+ break;
+ else
+ state = aho->fail[state];
+ }
+ }
+ else {
+ /* we must be accepting here */
+ failed++;
+ break;
+ }
+ } while(state);
+ if (failed) {
+ if (leftmost)
+ break;
+ else if (!charid && trie->bitmap && trie_type != trie_utf8_fold) {
+ while (!TRIE_BITMAP_TEST(trie,*uc) && uc <= (U8*)last_start ) {
+ uc++;
+ }
+ }
+ }
+ }
+ if ( aho->states[ state ].wordnum ) {
+ U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
+ if (!leftmost || lpos < leftmost)
+ leftmost = lpos;
+ }
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf"\n",
+ "All done: ",
+ state, base, uvc)
+ );
+ if (leftmost) {
+ s = (char*)leftmost;
+ if (!reginfo || regtry(reginfo, s))
+ goto got_it;
+ s = HOPc(s,1);
+ } else {
+ break;
+ }
+ }
+ }
+ break;
default:
Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
break;
}
else if ((c = prog->regstclass)) {
if (minlen) {
- I32 op = OP(prog->regstclass);
+ U8 op = OP(prog->regstclass);
/* don't bother with what can't match */
- if (PL_regkind[op] != EXACT && op != CANY)
+ if (PL_regkind[op] != EXACT && op != CANY && op != TRIE)
strend = HOPc(strend, -(minlen - 1));
}
DEBUG_EXECUTE_r({
sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
len1 = UTF ? (int)SvCUR(dsv1) : strend - s;
PerlIO_printf(Perl_debug_log,
- "Matching stclass \"%*.*s\" against \"%*.*s\"\n",
+ "Matching stclass \"%*.*s\" against \"%*.*s\" (%d chars)\n",
len0, len0, s0,
- len1, len1, s1);
+ len1, len1, s1, (int)(strend - s));
});
if (find_byclass(prog, c, s, strend, ®info))
goto got_it;
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
}
else {
dontbother = 0;
#define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
+#ifdef DEBUGGING
+STATIC void
+S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
+{
+ const int docolor = *PL_colors[0];
+ const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
+ int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
+ /* The part of the string before starttry has one color
+ (pref0_len chars), between starttry and current
+ position another one (pref_len - pref0_len chars),
+ after the current position the third one.
+ We assume that pref0_len <= pref_len, otherwise we
+ decrease pref0_len. */
+ int pref_len = (locinput - PL_bostr) > (5 + taill) - l
+ ? (5 + taill) - l : locinput - PL_bostr;
+ int pref0_len;
+
+ while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
+ pref_len++;
+ pref0_len = pref_len - (locinput - PL_reg_starttry);
+ if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
+ l = ( PL_regeol - locinput > (5 + taill) - pref_len
+ ? (5 + taill) - pref_len : PL_regeol - locinput);
+ while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
+ l--;
+ if (pref0_len < 0)
+ pref0_len = 0;
+ if (pref0_len > pref_len)
+ pref0_len = pref_len;
+ {
+ const char * const s0 =
+ do_utf8 && OP(scan) != CANY ?
+ pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
+ pref0_len, 60, UNI_DISPLAY_REGEX) :
+ locinput - pref_len;
+ const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
+ const char * const s1 = do_utf8 && OP(scan) != CANY ?
+ pv_uni_display(PERL_DEBUG_PAD(1),
+ (U8*)(locinput - pref_len + pref0_len),
+ pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
+ locinput - pref_len + pref0_len;
+ const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
+ const char * const s2 = do_utf8 && OP(scan) != CANY ?
+ pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
+ PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
+ locinput;
+ const int len2 = do_utf8 ? (int)strlen(s2) : l;
+ PerlIO_printf(Perl_debug_log,
+ "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
+ (IV)(locinput - PL_bostr),
+ PL_colors[4],
+ len0, s0,
+ PL_colors[5],
+ PL_colors[2],
+ len1, s1,
+ PL_colors[3],
+ (docolor ? "" : "> <"),
+ PL_colors[0],
+ len2, s2,
+ PL_colors[1],
+ 15 - l - pref_len + 1,
+ "");
+ }
+}
+#endif
+
STATIC I32 /* 0 failure, 1 success */
S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
{
DEBUG_EXECUTE_r( {
SV * const prop = sv_newmortal();
- const int docolor = *PL_colors[0];
- const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
- int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
- /* The part of the string before starttry has one color
- (pref0_len chars), between starttry and current
- position another one (pref_len - pref0_len chars),
- after the current position the third one.
- We assume that pref0_len <= pref_len, otherwise we
- decrease pref0_len. */
- int pref_len = (locinput - PL_bostr) > (5 + taill) - l
- ? (5 + taill) - l : locinput - PL_bostr;
- int pref0_len;
-
- while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
- pref_len++;
- pref0_len = pref_len - (locinput - PL_reg_starttry);
- if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
- l = ( PL_regeol - locinput > (5 + taill) - pref_len
- ? (5 + taill) - pref_len : PL_regeol - locinput);
- while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
- l--;
- if (pref0_len < 0)
- pref0_len = 0;
- if (pref0_len > pref_len)
- pref0_len = pref_len;
+ dump_exec_pos( locinput, scan, do_utf8 );
regprop(rex, prop, scan);
- {
- const char * const s0 =
- do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
- pref0_len, 60, UNI_DISPLAY_REGEX) :
- locinput - pref_len;
- const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
- const char * const s1 = do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(1),
- (U8*)(locinput - pref_len + pref0_len),
- pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
- locinput - pref_len + pref0_len;
- const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
- const char * const s2 = do_utf8 && OP(scan) != CANY ?
- pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
- PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
- locinput;
- const int len2 = do_utf8 ? (int)strlen(s2) : l;
- PerlIO_printf(Perl_debug_log,
- "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
- (IV)(locinput - PL_bostr),
- PL_colors[4],
- len0, s0,
- PL_colors[5],
- PL_colors[2],
- len1, s1,
- PL_colors[3],
- (docolor ? "" : "> <"),
- PL_colors[0],
- len2, s2,
- PL_colors[1],
- 15 - l - pref_len + 1,
- "",
- (IV)(scan - rex->program), PL_regindent*2, "",
- SvPVX_const(prop));
- }
+
+ PerlIO_printf(Perl_debug_log,
+ "%3"IVdf":%*s%s(%"IVdf")\n",
+ (IV)(scan - rex->program), PL_regindent*2, "",
+ SvPVX_const(prop),
+ PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
});
next = scan + NEXT_OFF(scan);
else
nextchr = UCHARAT(++locinput);
break;
-
-
-
- /*
- traverse the TRIE keeping track of all accepting states
- we transition through until we get to a failing node.
- */
case TRIE:
{
+ /* what type of TRIE am I? (utf8 makes this contextual) */
const enum { trie_plain, trie_utf8, trie_utf8_fold }
trie_type = do_utf8 ?
(scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
}
}
{
+ /*
+ traverse the TRIE keeping track of all accepting states
+ we transition through until we get to a failing node.
+ */
+
U8 *uc = ( U8* )locinput;
U16 charid = 0;
U32 base = 0;
base = trie->states[ state ].trans.base;
- DEBUG_TRIE_EXECUTE_r(
+ DEBUG_TRIE_EXECUTE_r({
+ dump_exec_pos( (char *)uc, scan, do_utf8 );
PerlIO_printf( Perl_debug_log,
"%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
- REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
+ 2+PL_regindent * 2, "", PL_colors[4],
(UV)state, (UV)base, (UV)st->u.trie.accepted );
- );
+ });
if ( base ) {
switch (trie_type) {
*/
if ( st->u.trie.accepted == 1 ) {
- DEBUG_EXECUTE_r({
- SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 );
- PerlIO_printf( Perl_debug_log,
- "%*s %sonly one match : #%d <%s>%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
- st->u.trie.accept_buff[ 0 ].wordnum,
- tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
- PL_colors[5] );
- });
PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
/* in this case we free tmps/leave before we call regmatch
as we wont be using accept_buff again. */
FREETMPS;
LEAVE;
+ /* do we need this? why dont we just do a break? */
REGMATCH(scan + NEXT_OFF(scan), TRIE1);
/*** all unsaved local vars undefined at this point */
} else {
st->u.trie.accept_buff[best].wordnum)
best = cur;
}
- DEBUG_EXECUTE_r({
- reg_trie_data * const trie = (reg_trie_data*)
- rex->data->data[ARG(scan)];
- SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 );
- PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at node #%d %s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
- st->u.trie.accept_buff[best].wordnum,
- tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
- PL_colors[5] );
- });
if ( best<st->u.trie.accepted ) {
reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
projects / p5sagit/p5-mst-13.2.git / commitdiff