Changeset 22886 for src

Show
Ignore:
Timestamp:
11/05/08 03:04:39 (2 months ago)
Author:
lwall
Message:

[Cursor] refactor cursor_fate for cleanliness and slight speed gains

Location:
src/perl6
Files:
2 modified

Legend:

Unmodified
Added
Removed

  • src/perl6/Cursor.pmc

    r22853 r22886  
    430430} 
    431431 
    432 sub _AUTOLEXnow { my $self = shift; 
    433     my $key = shift; 
     432sub delete { 
     433    my $self = shift; 
     434    delete $self->{@_}; 
     435} 
     436 
     437{ package Match; 
     438    sub new { my $self = shift; 
     439        my %args = @_; 
     440        CORE::bless \%args, $self; 
     441    } 
     442 
     443    sub from { my $self = shift; 
     444        $self->{_f}; 
     445    } 
     446 
     447    sub to { my $self = shift; 
     448        $self->{_t}; 
     449    } 
     450} 
     451 
     452sub cursor_peek { my $self = shift; 
     453    $self->deb("cursor_peek") if $DEBUG & DEBUG::cursors; 
     454    my %r = %$self; 
     455    $r{_peek} = 1; 
     456    CORE::bless \%r, ref $self; 
     457} 
     458 
     459sub cursor_fresh { my $self = shift; 
     460    my %r; 
     461    my $lang = @_ && $_[0] ? shift() : ref $self; 
     462    $self->deb("cursor_fresh lang $lang") if $DEBUG & DEBUG::cursors; 
     463   # $r{_from} = 
     464    $r{_pos} = $self->{_pos}; 
     465    $r{_fate} = $self->{_fate}; 
     466    $r{_herelang} = $self->{_herelang} if $self->{_herelang}; 
     467    CORE::bless \%r, ref $lang || $lang; 
     468} 
     469 
     470sub cursor_herelang { my $self = shift; 
     471    $self->deb("cursor_herelang") if $DEBUG & DEBUG::cursors; 
     472    my %r = %$self; 
     473    $r{_herelang} = $self; 
     474    CORE::bless \%r, 'STD::Q'; 
     475} 
     476 
     477# remove consistent leading whitespace (mutates text nibbles in place) 
     478 
     479sub trim_heredoc { my $doc = shift; 
     480    my ($stopper) = $doc->{stopper}[0] or 
     481        $doc->panic("Couldn't find delimiter for heredoc\n"); 
     482    my $ws = $stopper->{ws}->text; 
     483    return $stopper if $ws eq ''; 
     484 
     485    my $wsequiv = $ws; 
     486    $wsequiv =~ s{^(\t+)}[' ' x (length($1) * ($::TABSTOP // 8))]xe; 
     487 
     488    # We can't use ^^ after escapes, since the escape may be mid-line 
     489    # and we'd get false positives.  Use a fake newline instead. 
     490    $doc->{nibbles}[0] =~ s/^/\n/; 
     491 
     492    for (@{$doc->{nibbles}}) { 
     493        next if ref $_;   # next unless $_ =~ Str; 
     494 
     495        # prefer exact match over any ws 
     496        s{(?<=\n)(\Q$ws\E|[ \t]+)}{ 
     497            my $white = $1; 
     498            if ($white eq $ws) { 
     499                ''; 
     500            } 
     501            else { 
     502                $white =~ s[^ (\t+) ][ ' ' x (length($1) * ($::TABSTOP // 8)) ]xe; 
     503                if ($white =~ s/^\Q$wsequiv\E//) { 
     504                    $white; 
     505                } 
     506                else { 
     507                    ''; 
     508                } 
     509            } 
     510        }eg; 
     511    } 
     512    $doc->{nibbles}[0] =~ s/^\n//;  # undo fake newline 
     513    $stopper; 
     514} 
     515 
     516sub clean { 
     517    my $self = shift; 
     518    delete $self->{_fate}; 
     519    delete $self->{_pos};       # EXPR blows up without this for some reason 
     520    delete $self->{_reduced}; 
     521    for my $k (values %$self) { 
     522        next unless ref $k; 
     523        if (ref $k eq 'ARRAY') { 
     524            for my $k2 (@$k) { 
     525                eval { 
     526                    $k2->clean if ref $k2; 
     527                } 
     528            } 
     529        } 
     530        else { 
     531            eval { 
     532                $k->clean; 
     533            } 
     534        } 
     535    } 
     536    $self; 
     537} 
     538 
     539sub dump { 
     540    my $self = shift; 
     541    my %copy = %$self; 
     542    delete $copy{_reduced}; 
     543    delete $copy{_fate}; 
     544    my $text = STD::Dump(\%copy); 
     545    $text; 
     546} 
     547 
     548sub cursor_bind { my $self = shift;     # this is parent's match cursor 
     549    my $bindings = shift; 
     550    my $submatch = shift;               # this is the submatch's cursor 
     551    delete $self->{_fate}; 
     552 
     553    $self->deb("cursor_bind @$bindings") if $DEBUG & DEBUG::cursors; 
     554    my %r = %$self; 
     555    if ($bindings) { 
     556        for my $binding (@$bindings) { 
     557            if (ref $r{$binding} eq 'ARRAY') { 
     558                push(@{$r{$binding}}, $submatch); 
     559            } 
     560            else { 
     561                $r{$binding} = $submatch; 
     562            } 
     563        } 
     564    } 
     565    $submatch->{_from} = $r{_from} = $r{_pos}; 
     566    $r{_pos} = $submatch->{_pos}; 
     567    CORE::bless \%r, ref $self;         # return new match cursor for parent 
     568} 
     569 
     570sub cursor_fate { my $self = shift; 
     571    my $pkg = shift; 
     572    my $name = shift; 
    434573    my $retree = shift; 
    435  
    436     $self->deb("AUTOLEXnow $key") if $DEBUG & DEBUG::autolexer; 
    437     my $lexer = $self->lexers->{$key} // do { 
     574    # $_[0] is now ref to a $trystate; 
     575 
     576    $self->deb("cursor_fate $pkg $name") if $DEBUG & DEBUG::cursors; 
     577    my $tag; 
     578    my $try; 
     579    my $relex; 
     580     
     581    my $lexer = $self->lexers->{$name} // do { 
    438582        local %AUTOLEXED; 
    439         $self->_AUTOLEXpeek($key,$retree); 
     583        $self->_AUTOLEXpeek($name,$retree); 
    440584    }; 
    441585    if ($self->{_pos} >= $::HIGHWATER) { 
    … …  
    450594    my $P = $self->{_pos}; 
    451595    if ($P >= @::ORIG) { 
    452         return sub { return }; 
     596        return $self,'', 0, sub {}; 
    453597    } 
    454598    pos($::ORIG) = $P; 
    … …  
    456600    my $ch2 = $1; 
    457601 
    458     $lexer->{$ch2} //= do { 
     602    $relex = $lexer->{$ch2} //= do { 
    459603        my @pats; 
    460604        my $file = $lexer->{FILE} . '__' . ::mangle($ch2); 
    … …  
    462606            binmode(PATS, ":utf8"); 
    463607#           print STDERR "<$file\n"; 
    464             $self->deb("Using cached $key patterns starting with '$ch2'") if $DEBUG & DEBUG::autolexer; 
     608            $self->deb("Using cached $name patterns starting with '$ch2'") if $DEBUG & DEBUG::autolexer; 
    465609            chomp(@pats = <PATS>); 
    466610            close PATS; 
    … …  
    468612        else { 
    469613#           print STDERR ">$file\n"; 
    470             $self->deb("Selecting $key patterns starting with '$ch2'") if $DEBUG & DEBUG::autolexer; 
     614            $self->deb("Selecting $name patterns starting with '$ch2'") if $DEBUG & DEBUG::autolexer; 
    471615            @pats = grep { canmatch($_, $ch2) } @{ 
    472616                $lexer->{FASTPATS} //= [ 
    … …  
    489633        my @rxlenmemo; 
    490634        if (!@pats) { 
    491             $self->deb("No $key patterns start with '$ch2'") if $DEBUG & DEBUG::autolexer; 
     635            $self->deb("No $name patterns start with '$ch2'") if $DEBUG & DEBUG::autolexer; 
    492636            sub { return }; 
    493637        } 
    … …  
    500644            } 
    501645            for (@pats) { 
    502                 s/\(\?#FATE +(.*?)\)/(?#$i FATE $1)/ or return sub { return }; 
     646                s/\(\?#FATE +(.*?)\)/(?#$i FATE $1)/; 
    503647                my $fstr = $1; 
    504648                my $fate = $fates->[$i] = [0,0,0,$fstr]; 
    … …  
    556700                    $peek =~ s/\n/\\n/g; 
    557701                    $peek =~ s/\t/\\t/g; 
    558                     $self->deb("looking for $key at --------->$GREEN$peek$CLEAR"); 
     702                    $self->deb("looking for $name at --------->$GREEN$peek$CLEAR"); 
    559703                } 
    560704 
    … …  
    683827                    } 
    684828                } 
    685             } 
     829            }; 
    686830        } 
    687831    }; 
    688 } 
    689  
    690 sub delete { 
    691     my $self = shift; 
    692     delete $self->{@_}; 
    693 } 
    694  
    695 { package Match; 
    696     sub new { my $self = shift; 
    697         my %args = @_; 
    698         CORE::bless \%args, $self; 
    699     } 
    700  
    701     sub from { my $self = shift; 
    702         $self->{_f}; 
    703     } 
    704  
    705     sub to { my $self = shift; 
    706         $self->{_t}; 
    707     } 
    708 } 
    709  
    710 sub cursor_peek { my $self = shift; 
    711     $self->deb("cursor_peek") if $DEBUG & DEBUG::cursors; 
    712     my %r = %$self; 
    713     $r{_peek} = 1; 
    714     CORE::bless \%r, ref $self; 
    715 } 
    716  
    717 sub cursor_fresh { my $self = shift; 
    718     my %r; 
    719     my $lang = @_ && $_[0] ? shift() : ref $self; 
    720     $self->deb("cursor_fresh lang $lang") if $DEBUG & DEBUG::cursors; 
    721    # $r{_from} = 
    722     $r{_pos} = $self->{_pos}; 
    723     $r{_fate} = $self->{_fate}; 
    724     $r{_herelang} = $self->{_herelang} if $self->{_herelang}; 
    725     CORE::bless \%r, ref $lang || $lang; 
    726 } 
    727  
    728 sub cursor_herelang { my $self = shift; 
    729     $self->deb("cursor_herelang") if $DEBUG & DEBUG::cursors; 
    730     my %r = %$self; 
    731     $r{_herelang} = $self; 
    732     CORE::bless \%r, 'STD::Q'; 
    733 } 
    734  
    735 # remove consistent leading whitespace (mutates text nibbles in place) 
    736  
    737 sub trim_heredoc { my $doc = shift; 
    738     my ($stopper) = $doc->{stopper}[0] or 
    739         $doc->panic("Couldn't find delimiter for heredoc\n"); 
    740     my $ws = $stopper->{ws}->text; 
    741     return $stopper if $ws eq ''; 
    742  
    743     my $wsequiv = $ws; 
    744     $wsequiv =~ s{^(\t+)}[' ' x (length($1) * ($::TABSTOP // 8))]xe; 
    745  
    746     # We can't use ^^ after escapes, since the escape may be mid-line 
    747     # and we'd get false positives.  Use a fake newline instead. 
    748     $doc->{nibbles}[0] =~ s/^/\n/; 
    749  
    750     for (@{$doc->{nibbles}}) { 
    751         next if ref $_;   # next unless $_ =~ Str; 
    752  
    753         # prefer exact match over any ws 
    754         s{(?<=\n)(\Q$ws\E|[ \t]+)}{ 
    755             my $white = $1; 
    756             if ($white eq $ws) { 
    757                 ''; 
    758             } 
    759             else { 
    760                 $white =~ s[^ (\t+) ][ ' ' x (length($1) * ($::TABSTOP // 8)) ]xe; 
    761                 if ($white =~ s/^\Q$wsequiv\E//) { 
    762                     $white; 
    763                 } 
    764                 else { 
    765                     ''; 
    766                 } 
    767             } 
    768         }eg; 
    769     } 
    770     $doc->{nibbles}[0] =~ s/^\n//;  # undo fake newline 
    771     $stopper; 
    772 } 
    773  
    774 sub clean { 
    775     my $self = shift; 
    776     delete $self->{_fate}; 
    777     delete $self->{_pos};       # EXPR blows up without this for some reason 
    778     delete $self->{_reduced}; 
    779     for my $k (values %$self) { 
    780         next unless ref $k; 
    781         if (ref $k eq 'ARRAY') { 
    782             for my $k2 (@$k) { 
    783                 eval { 
    784                     $k2->clean if ref $k2; 
    785                 } 
    786             } 
    787         } 
    788         else { 
    789             eval { 
    790                 $k->clean; 
    791             } 
    792         } 
    793     } 
    794     $self; 
    795 } 
    796  
    797 sub dump { 
    798     my $self = shift; 
    799     my %copy = %$self; 
    800     delete $copy{_reduced}; 
    801     delete $copy{_fate}; 
    802     my $text = STD::Dump(\%copy); 
    803     $text; 
    804 } 
    805  
    806 sub cursor_bind { my $self = shift;     # this is parent's match cursor 
    807     my $bindings = shift; 
    808     my $submatch = shift;               # this is the submatch's cursor 
    809     delete $self->{_fate}; 
    810  
    811     $self->deb("cursor_bind @$bindings") if $DEBUG & DEBUG::cursors; 
    812     my %r = %$self; 
    813     if ($bindings) { 
    814         for my $binding (@$bindings) { 
    815             if (ref $r{$binding} eq 'ARRAY') { 
    816                 push(@{$r{$binding}}, $submatch); 
    817             } 
    818             else { 
    819                 $r{$binding} = $submatch; 
    820             } 
    821         } 
    822     } 
    823     $submatch->{_from} = $r{_from} = $r{_pos}; 
    824     $r{_pos} = $submatch->{_pos}; 
    825     CORE::bless \%r, ref $self;         # return new match cursor for parent 
    826 } 
    827  
    828 sub cursor_fate { my $self = shift; 
    829     my $pkg = shift; 
    830     my $name = shift; 
    831     my $retree = shift; 
    832     # $_[0] is now ref to a $trystate; 
    833  
    834     $self->deb("cursor_fate $pkg $name") if $DEBUG & DEBUG::cursors; 
    835     my $tag; 
    836     my $try; 
    837     my $relex; 
    838      
    839     my $fate = $self->{_fate}; 
    840     if ($fate) { 
    841         if ($fate->[0] eq $name) { 
    842             $self->deb("Fate passed to $name: $$fate[3]") if $DEBUG & DEBUG::fates; 
    843             ($tag, $try, $fate) = @$fate; 
    844             $self->{_fate} = $fate; 
    845             return $self, $tag, $try, $relex; 
    846         } 
    847         elsif ($fate->[0] . ':*' eq $name) { 
    848             $self->deb("Fate passed to $name: $$fate[3]") if $DEBUG & DEBUG::fates; 
    849             ($tag, $try, $fate) = @$fate; 
    850             $self->{_fate} = $fate; 
    851             return $self, $tag, $try, $relex; 
    852         } 
    853 #       else { 
    854 #           warn Dump($fate); 
    855 #           warn "FATE mismatch: $name vs " . $fate->[0] . "\n"; 
    856 #       } 
    857     } 
    858  
    859     $relex = $self->_AUTOLEXnow($name,$retree); 
    860     $fate = $relex->($self,$_[0]); 
    861     if ($fate) { 
     832 
     833    if (my $fate = $relex->($self,$_[0])) { 
    862834        $self->deb("FATE OF ${pkg}::$name: $$fate[3]") if $DEBUG & DEBUG::fates; 
    863835        ($tag, $try, $fate) = @$fate; 

  • src/perl6/gimme5

    r22853 r22886  
    331331    my \@result = eval { 
    332332        my \$trystate; 
    333         my (\$C, \$tag, \$try, \$relex) = \$C->cursor_fate('$PKG', '$name:*', \$retree, \$trystate); 
    334         my \@try = \$tag eq '$name' ? (\$try,\$relex) : (); 
    335      
     333        my (\$tag, \$try, \$relex); 
     334        my \@try; 
     335        if (my \$fate = \$C->{_fate}) { 
     336            if (\$fate->[0] eq '$name') { 
     337                \$C->deb("Fate passed to $name: \$\$fate[3]") if \$DEBUG & DEBUG::fates; 
     338                (\$tag, \$try, \$fate) = \@\$fate; 
     339                \$C->{_fate} = \$fate; 
     340                \@try = (\$try); 
     341            } 
     342        } 
     343        else { 
     344            (\$C, \$tag, \$try, \$relex) = \$C->cursor_fate('$PKG', '$name:*', \$retree, \$trystate); 
     345            \@try = (\$try,\$relex) if \$tag; 
     346        } 
     347 
    336348        my \@gather = (); 
    337349        while (\@try and not \@gather) { 
    … …  
    24612473            my $policy; 
    24622474            if ($failover) { 
     2475                die "failover no longer implemented"; 
    24632476                $policy = <<"END" 
    2464     my \@try = @{[ '0..' . ($alt-1) ]}; 
    2465     unshift \@try, splice(\@try,\$try,1) if \$tag eq '$altname'; 
    2466     splice(\@try,1,0,\$relex) if \$relex; 
     2477        \@try = @{[ '0..' . ($alt-1) ]}; 
     2478        unshift \@try, splice(\@try,\$try,1) if \$tag eq '$altname'; 
     2479        splice(\@try,1,0,\$relex) if \$relex; 
    24672480END 
    24682481            } 
    24692482            else { 
    24702483                $policy = <<"END" 
    2471     my \@try = \$tag eq '$altname' ? (\$try,\$relex) : (); 
     2484        \@try = \$tag eq '$altname' ? (\$try,\$relex) : (); 
    24722485END 
    24732486            } 
    … …  
    24762489  my \@result = eval { 
    24772490    my \$trystate; 
    2478     my (\$C, \$tag, \$try, \$relex) = \$C->cursor_fate('${PKG}', '$altname', \$retree, \$trystate); 
     2491    my (\$tag, \$try, \$relex); 
     2492    my \@try; 
     2493    my \$fate; 
     2494    if (\$fate = \$C->{_fate} and \$fate->[0] eq '$altname') { 
     2495        \$C->deb("Fate passed to $altname: \$\$fate[3]") if \$DEBUG & DEBUG::fates; 
     2496        (\$tag, \$try, \$fate) = \@\$fate; 
     2497        \$C->{_fate} = \$fate; 
     2498        \@try = (\$try); 
     2499    } 
     2500    else { 
     2501        (\$C, \$tag, \$try, \$relex) = \$C->cursor_fate('${PKG}', '$altname', \$retree, \$trystate); 
    24792502$policy 
     2503    } 
    24802504END 
    24812505