implement ignoremark for moarvm backend

FROGGS · FROGGS · commit edc965fb0b8a · 2015-05-10T12:31:56.000+02:00
Ranges in character classes are still todo and require some thought.
Also, this patch does not include the required stage0 bump, which we
need because we use a new op called nqp::ordbaseat(str, offset).
diff --git a/src/QRegex/NFA.nqp b/src/QRegex/NFA.nqp
@@ -21,6 +21,8 @@ class QRegex::NFA {
     my $EDGE_CHARRANGE_NEG   := 13;
     my $EDGE_CODEPOINT_LL    := 14;
     my $EDGE_CODEPOINT_I_LL  := 15;
+    my $EDGE_CODEPOINT_M     := 16;
+    my $EDGE_CODEPOINT_M_NEG := 17;
 
     my $ACTIONS;
     my $nfadeb;
@@ -171,7 +173,7 @@ class QRegex::NFA {
         %cclass_code<n>  := nqp::const::CCLASS_NEWLINE;
         %cclass_code<nl> := nqp::const::CCLASS_NEWLINE;
         $nfadeb := nqp::existskey(nqp::getenvhash(),'NQP_NFA_DEB');
-        $ACTIONS := ['FATE','EPSILON','CODEPOINT','CODEPOINT_NEG','CHARCLASS','CHARCLASS_NEG','CHARLIST','CHARLIST_NEG','SUBRULE','CODEPOINT_I','CODEPOINT_I_NEG','GENERIC_VAR','CHARRANGE','CHARRANGE_NEG','CODEPOINT_LL','CODEPOINT_I_LL'];
+        $ACTIONS := ['FATE','EPSILON','CODEPOINT','CODEPOINT_NEG','CHARCLASS','CHARCLASS_NEG','CHARLIST','CHARLIST_NEG','SUBRULE','CODEPOINT_I','CODEPOINT_I_NEG','GENERIC_VAR','CHARRANGE','CHARRANGE_NEG','CODEPOINT_LL','CODEPOINT_I_LL','CODEPOINT_M','CODEPOINT_M_NEG'];
         # $ind := 0;
         # $indent := '';
         $nfatime := 0;
@@ -244,6 +246,15 @@ class QRegex::NFA {
                 dentout(self.addedge($from, $to, $!LITEND ?? $EDGE_CODEPOINT_I !!  $EDGE_CODEPOINT_I_LL,
                     [nqp::ord($litconst_lc, $i), nqp::ord($litconst_uc, $i)]));
             }
+            elsif $node.subtype eq 'ignoremark' {
+                my str $litconst := $node[0];
+                while $i <= $litlen {
+                    $from := self.addedge($from, -1, $EDGE_CODEPOINT_M, nqp::ordbaseat($litconst, $i));
+                    $i := $i + 1;
+                }
+                # XXX $EDGE_CODEPOINT_M_LL ?
+            }
+            # XXX elsif $node.subtype eq 'ignorecase+ignoremark' { ... }
             else {
                 my str $litconst := $node[0];
                 while $i < $litlen {
diff --git a/src/QRegex/P6Regex/Actions.nqp b/src/QRegex/P6Regex/Actions.nqp
@@ -119,7 +119,15 @@ class QRegex::P6Regex::Actions is HLL::Actions {
         }
         else {
             my $qast := QAST::Regex.new( ~$/, :rxtype<literal>, :node($/));
-            $qast.subtype('ignorecase') if %*RX<i>;
+            if %*RX<i> && %*RX<m> { # >
+                $qast.subtype('ignorecase+ignoremark')
+            }
+            elsif %*RX<i> {
+                $qast.subtype('ignorecase')
+            }
+            elsif %*RX<m> { # >
+                $qast.subtype('ignoremark')
+            }
             make $qast;
         }
     }
@@ -205,15 +213,31 @@ class QRegex::P6Regex::Actions is HLL::Actions {
         my $quote := $<quote_EXPR>.ast;
         if QAST::SVal.ACCEPTS($quote) { $quote := $quote.value; }
         my $qast := QAST::Regex.new( $quote, :rxtype<literal>, :node($/) );
-        $qast.subtype('ignorecase') if %*RX<i>;
+        if %*RX<i> && %*RX<m> { # >
+            $qast.subtype('ignorecase+ignoremark')
+        }
+        elsif %*RX<i> {
+            $qast.subtype('ignorecase')
+        }
+        elsif %*RX<m> { # >
+            $qast.subtype('ignoremark')
+        }
         make $qast;
     }
 
     method metachar:sym<">($/) {
         my $quote := $<quote_EXPR>.ast;
         if QAST::SVal.ACCEPTS($quote) { $quote := $quote.value; }
         my $qast := QAST::Regex.new( $quote, :rxtype<literal>, :node($/) );
-        $qast.subtype('ignorecase') if %*RX<i>;
+        if %*RX<i> && %*RX<m> { # >
+            $qast.subtype('ignorecase+ignoremark')
+        }
+        elsif %*RX<i> {
+            $qast.subtype('ignorecase')
+        }
+        elsif %*RX<m> { # >
+            $qast.subtype('ignoremark')
+        }
         make $qast;
     }
 
@@ -674,7 +698,7 @@ class QRegex::P6Regex::Actions is HLL::Actions {
                     $/.CURSOR.panic("Illegal reversed character range in regex: " ~ ~$_)
                         if $ord0 > $ord1;
                     @alts.push(QAST::Regex.new(
-                        %*RX<i> ?? 'ignorecase' !! '',
+                        %*RX<i> ?? 'ignorecase' !! '', # XXX ignoremark
                         QAST::IVal.new( :value($ord0) ),
                         QAST::IVal.new( :value($ord1) ),
                         :negate( $<sign> eq '-' ),
@@ -690,12 +714,23 @@ class QRegex::P6Regex::Actions is HLL::Actions {
                         @alts.push($bs);
                     }
                 }
-                else {
+                elsif %*RX<i> && %*RX<m> { # >
+                    my $c := nqp::chr(nqp::ordbaseat(~$_[0], 0));
+                    $str := $str ~ nqp::lc($c) ~ nqp::uc($c);
+                }
+                elsif %*RX<i> {
                     my $c := ~$_[0];
-                    $str := $str ~ (%*RX<i> ?? nqp::lc($c) ~ nqp::uc($c) !! $c);
+                    $str := $str ~ nqp::lc($c) ~ nqp::uc($c);
+                }
+                elsif %*RX<m> { # >
+                    $str := $str ~ nqp::chr(nqp::ordbaseat(~$_[0], 0));
+                }
+                else {
+                    $str := $str ~ ~$_[0];
                 }
             }
-            @alts.push(QAST::Regex.new( $str, :rxtype<enumcharlist>, :node($/), :negate( $<sign> eq '-' ) ))
+            @alts.push(QAST::Regex.new( $str, :rxtype<enumcharlist>, :node($/), :negate( $<sign> eq '-' ),
+                :subtype(%*RX<m> ?? 'ignoremark' !! '') )) # >
                 if nqp::chars($str);
             $qast := +@alts == 1 ?? @alts[0] !!
                 $<sign> eq '-' ??
diff --git a/src/QRegex/P6Regex/Grammar.nqp b/src/QRegex/P6Regex/Grammar.nqp
@@ -453,6 +453,12 @@ grammar QRegex::P6Regex::Grammar is HLL::Grammar {
 
     proto token mod_ident { <...> }
     token mod_ident:sym<ignorecase> { $<sym>=[i] 'gnorecase'? » }
+    token mod_ident:sym<ignoremark> {
+        [
+        | $<sym>=[m]
+        | 'ignore' $<sym>=[m] 'ark'
+        ] »
+    }
     token mod_ident:sym<ratchet>    { $<sym>=[r] 'atchet'? » }
     token mod_ident:sym<sigspace>   { $<sym>=[s] 'igspace'? » }
     token mod_ident:sym<dba>        { <sym> » }
diff --git a/src/vm/moar/QAST/QASTOperationsMAST.nqp b/src/vm/moar/QAST/QASTOperationsMAST.nqp
@@ -2147,6 +2147,7 @@ QAST::MASTOperations.add_core_moarop_mapping('split', 'split');
 QAST::MASTOperations.add_core_moarop_mapping('chr', 'chr');
 QAST::MASTOperations.add_core_moarop_mapping('ordfirst', 'ordfirst');
 QAST::MASTOperations.add_core_moarop_mapping('ordat', 'ordat');
+QAST::MASTOperations.add_core_moarop_mapping('ordbaseat', 'ordbaseat');
 QAST::MASTOperations.add_core_moarop_mapping('indexfrom', 'index_s');
 QAST::MASTOperations.add_core_moarop_mapping('rindexfrom', 'rindexfrom');
 QAST::MASTOperations.add_core_moarop_mapping('substr_s', 'substr_s');
diff --git a/src/vm/moar/QAST/QASTRegexCompilerMAST.nqp b/src/vm/moar/QAST/QASTRegexCompilerMAST.nqp
@@ -507,7 +507,20 @@ class QAST::MASTRegexCompiler {
     method enumcharlist($node) {
         my @ins;
         my $op := $node.negate ?? 'indexnat' !! 'indexat';
-        nqp::push(@ins, op($op, %!reg<tgt>, %!reg<pos>, sval($node[0]), %!reg<fail>));
+        if $node.subtype eq 'ignoremark' || $node.subtype eq 'ignorecase+ignoremark' {
+            my $i0 := $!regalloc.fresh_i();
+            my $s0 := $!regalloc.fresh_s();
+            merge_ins(@ins, [
+                op('ge_i', $i0, %!reg<pos>, %!reg<eos>),
+                op('if_i', $i0, %!reg<fail>),
+                op('ordbaseat', $i0, %!reg<tgt>, %!reg<pos>),
+                op('chr', $s0, $i0),
+                op($op, $s0, %!reg<zero>, sval($node[0]), %!reg<fail>),
+            ]);
+        }
+        else {
+            nqp::push(@ins, op($op, %!reg<tgt>, %!reg<pos>, sval($node[0]), %!reg<fail>));
+        }
         nqp::push(@ins, op('inc_i', %!reg<pos>))
             unless $node.subtype eq 'zerowidth';
         @ins
@@ -577,10 +590,8 @@ class QAST::MASTRegexCompiler {
 
     method literal($node) {
         my $litconst := $node[0];
-        my $eq_op := $node.subtype eq 'ignorecase' ?? 'eqatic_s' !! 'eqat_s';
         my $s0 := $!regalloc.fresh_s();
         my $i0 := $!regalloc.fresh_i();
-        my $cmpop := $node.negate ?? 'if_i' !! 'unless_i';
         my @ins;
         if $node.negate {
             # Need explicit check we're not going beyond the string end in the
@@ -594,11 +605,27 @@ class QAST::MASTRegexCompiler {
         # can happen only once at the beginning of a regex. hash of string constants
         # to the registers to which they are assigned.
         # XXX or make a specialized eqat_sc op that takes a constant string.
-        nqp::push(@ins, op('const_s', $s0, sval($litconst)));
         # also, consider making the op branch directly from the comparison
         # instead of storing an integer to a temporary register
-        nqp::push(@ins, op($eq_op, $i0, %!reg<tgt>, $s0, %!reg<pos>));
-        nqp::push(@ins, op($cmpop, $i0, %!reg<fail>));
+        if $node.subtype eq 'ignorecase+ignoremark' {
+            my $op := $node.negate ?? 'indexnat' !! 'indexat';
+            my $c  := nqp::chr(nqp::ordbaseat($litconst, 0));
+            merge_ins(@ins, [
+                op('ge_i', $i0, %!reg<pos>, %!reg<eos>),
+                op('if_i', $i0, %!reg<fail>),
+                op('ordbaseat', $i0, %!reg<tgt>, %!reg<pos>),
+                op('chr', $s0, $i0),
+                op($op, $s0, %!reg<zero>, sval(nqp::lc($c) ~ nqp::uc($c)), %!reg<fail>),
+            ]);
+        }
+        else {
+            my $eq_op := $node.subtype eq 'ignorecase' ?? 'eqatic_s' !!
+                         $node.subtype eq 'ignoremark' ?? 'eqatim_s' !! 'eqat_s';
+            my $cmpop := $node.negate ?? 'if_i' !! 'unless_i';
+            nqp::push(@ins, op('const_s', $s0, sval($litconst)));
+            nqp::push(@ins, op($eq_op, $i0, %!reg<tgt>, $s0, %!reg<pos>));
+            nqp::push(@ins, op($cmpop, $i0, %!reg<fail>));
+        }
         unless $node.subtype eq 'zerowidth' {
             nqp::push(@ins, op('const_i64', $i0, ival(nqp::chars($litconst))));
             nqp::push(@ins, op('add_i', %!reg<pos>, %!reg<pos>, $i0));
@@ -922,7 +949,7 @@ class QAST::MASTRegexCompiler {
             $looplabel,
             op('inc_i', %!reg<pos>),
         ];
-        if $node.list && $node.subtype ne 'ignorecase' {
+        if $node.list && $node.subtype ne 'ignorecase' && $node.subtype ne 'ignoremark' && $node.subtype ne 'ignorecase+ignoremark' {
             my $lit := $!regalloc.fresh_s();
             nqp::push(@ins, op('const_s', $lit, sval($node[0])));
             nqp::push(@ins, op('index_s', %!reg<pos>, %!reg<tgt>, $lit, %!reg<pos>));
