Changeset 23015 for src

Show
Ignore:
Timestamp:
11/14/08 20:40:51 (8 weeks ago)
Author:
lwall
Message:

[Cursor] refactor to trie and Storable implementation, which uses less

time and memory except for programs using overloading

now uses a fate cache to avoid dup fate lists; no longer stores intermediate

fates as strings, but reproduces from list when debugging

[tryfile] now reports time and memory usage (at least on linux)

Location:
src/perl6
Files:
3 modified

Legend:

Unmodified
Added
Removed

  • src/perl6/Cursor.pmc

    r22986 r23015  
    44no warnings 'recursion'; 
    55use utf8; 
     6 
     7my $TRIE = 1; 
     8my $STORABLE = 1; 
    69 
    710use feature 'say', 'state'; 
    … …  
    3437    $::COMPILING::FILE = '(eval)'; 
    3538    $::GOAL = "(eof)"; 
     39} 
     40 
     41sub ::fatestr { my $f = shift; 
     42    my $text = ''; 
     43    while ($f) { 
     44        $text .= $f->[0] . " " . $f->[1]; 
     45        $text .= ' ' if $f = $f->[2]; 
     46    } 
     47    $text; 
    3648} 
    3749 
    … …  
    191203 
    192204use YAML::XS; 
     205use Storable; 
    193206 
    194207sub from { $_[0]->{_from} // $_[0]->{_pos} } 
    … …  
    242255    return $::LEXERS{ref $self}->{$key} //= $self->_AUTOLEXgen($key, $retree); 
    243256} 
     257 
     258our %FATECACHE; 
    244259 
    245260sub _AUTOLEXgen { my $self = shift; 
    … …  
    262277    } 
    263278 
    264     if (open(LEX, "$dir/$file")) { 
     279    if ($STORABLE and -e "$dir/$file.store") { 
     280        my $lexer = retrieve("$dir/$file.store"); 
     281        my $pat = $lexer->{PATS}; 
     282        my $fates; 
     283        my $i = 0; 
     284        for (@$pat) { 
     285            my $fstr; 
     286            if ( m/\(\?#FATE(\d+) +(.*?)\)/) { 
     287                warn "MISMATCH $i $1" unless $i == $1; 
     288                $fstr = $2; 
     289            } 
     290            else { 
     291                die "Whoops, no fate in storage"; 
     292            } 
     293            my $fate; 
     294            if ($fate = $FATECACHE{$fstr}) { 
     295                $fates->[$i] = $fate; 
     296            } 
     297            else { 
     298                $FATECACHE{$fstr} = $fate = $fates->[$i] = [0,0,0]; 
     299                while ($fstr =~ s/(\S+)\s+(\S+)\s*//) { 
     300                    $fate->[0] = $1; 
     301                    $fate->[1] = $2; 
     302                    if ($fate->[2] = $FATECACHE{$fstr}) { 
     303                        last; 
     304                    } 
     305                    $fate = $fate->[2] //= [0,0,0] if $fstr ne ''; 
     306                } 
     307            } 
     308            $i++; 
     309        } 
     310        $lexer->{FATES} = $fates; 
     311        return $lexer; 
     312    } 
     313    elsif (open(LEX, "$dir/$file")) { 
    265314        binmode(LEX, ":utf8"); 
    266315        $self->deb("using cached $dir/$file") if $DEBUG & DEBUG::autolexer; 
    … …  
    281330            s/\(\?#FATE\d* +(.*?)\)/(?#FATE$i $1)/; 
    282331            my $fstr = $1; 
    283             my $fate = $fates->[$i] = [0,0,0,$fstr]; 
     332            my $fate = $fates->[$i] = [0,0,0]; 
    284333            while ($fstr =~ s/(\S+)\s+(\S+)\s*//) { 
    285334                $fate->[0] = $1; 
    286335                $fate->[1] = $2; 
    287                 $fate = $fate->[2] = [0,0,0,$fstr] if $fstr ne ''; 
     336                $fate = $fate->[2] = [0,0,0] if $fstr ne ''; 
    288337            } 
    289338            $i++; 
    290339        } 
    291340        $lexer{FATES} = $fates; 
    292  
    293 #       if (@para > 0 and $para[1]) { 
    294 #           for (split(/\n/, $para[1])) {} 
    295 #       } 
     341        eval { 
     342            $lexer{T} = Load($para[1]) if $TRIE and @para > 1; 
     343        }; 
    296344 
    297345        return \%lexer; 
    … …  
    351399                $fstr = ""; 
    352400            } 
    353             my $fate = $fates->[$i] = [0,0,0,$fstr]; 
    354             while ($fstr =~ s/(\S+)\s+(\S+)\s*//) { 
    355                 $fate->[0] = $1; 
    356                 $fate->[1] = $2; 
    357                 $fate = $fate->[2] = [0,0,0,$fstr] if $fstr ne ''; 
     401            my $fate; 
     402            if ($fate = $FATECACHE{$fstr}) { 
     403                $fates->[$i] = $fate; 
     404            } 
     405            else { 
     406                $FATECACHE{$fstr} = $fate = $fates->[$i] = [0,0,0]; 
     407                while ($fstr =~ s/(\S+)\s+(\S+)\s*//) { 
     408                    $fate->[0] = $1; 
     409                    $fate->[1] = $2; 
     410                    if ($fate->[2] = $FATECACHE{$fstr}) { 
     411                        last; 
     412                    } 
     413                    $fate = $fate->[2] //= [0,0,0] if $fstr ne ''; 
     414                } 
    358415            } 
    359416            $i++; 
    … …  
    364421        $AUTOLEXED{$key} = $oldfakepos; 
    365422 
    366         $lexer = { "NAME" => $name, "FILE" => "$dir/$file", "PATS" => [@pat], "FATES" => $fates, "DBA" => $dba}; 
     423        my $T; 
     424        if ($TRIE) { 
     425            $T = {}; 
     426          PAT: 
     427            for my $fnum (0..@pat-1) { 
     428                my ($chars) = $pat[$fnum]; 
     429                $chars =~ s/\(\?#::\)//g; 
     430                my @chars; 
     431                my $final = ''; 
     432                while ($chars ne '') { 
     433                    last if $chars =~ m/^\t/; 
     434                    if ($chars =~ s/^\\(\W)([*+?{]?)//) { 
     435                        if ($2) { 
     436                            $final = "\\$1$2$chars"; 
     437                            last; 
     438                        } 
     439                        push(@chars, ord($1)); 
     440                        next; 
     441                    } 
     442                    if ($chars =~ s/^(\\\w.*)//) { 
     443                        $final = $1; 
     444                        last; 
     445                    } 
     446                    if ($chars =~ /^(\[\S+)/) { 
     447                        $final = $1; 
     448                        last; 
     449                    } 
     450                    if ($chars =~ /^(\.\S+)/) { 
     451                        $final = $1; 
     452                        last; 
     453                    } 
     454                    if ($chars =~ s/^(.)([*+?{]?)//) { 
     455                        if ($2) { 
     456                            $final = "$1$2$chars"; 
     457                            last; 
     458                        } 
     459                        push(@chars, unpack('U',$1)); 
     460                        next; 
     461                    } 
     462                } 
     463                my $state = $T; 
     464                for my $ch (@chars) { 
     465                    my $char = chr($ch); 
     466                    if (my $next = $state->{$char}) { 
     467                        $state = $next; 
     468                    } 
     469                    else { 
     470                        $state = $state->{$char} = {}; 
     471                    } 
     472                } 
     473                push @{$state->{'~~'}}, $final, $fnum; 
     474            } 
     475        } 
     476 
     477 
     478        $lexer = { "NAME" => $name, "FILE" => "$dir/$file", "PATS" => [@pat], "FATES" => $fates, "T" => $T, "DBA" => $dba}; 
    367479 
    368480        return $lexer if $lang =~ /ANON/; 
    … …  
    372484            mkpath($dir); 
    373485        } 
    374  
    375         open(my $cache, '>', "$dir/$file") // die "Can't print: $!"; 
    376         binmode($cache, ":utf8"); 
     486        if ($STORABLE) { 
     487            delete $lexer->{FATES}; 
     488            store($lexer, "$dir/$file.store"); 
     489            $lexer->{FATES} = $fates; 
     490            if ($file eq 'termish') { 
     491                system "cp $dir/termish.store $dir/EXPR.store"; 
     492            } 
     493            return $lexer; 
     494        } 
     495 
     496        open(my $cache, '>:utf8', "$dir/$file") // die "Can't print: $!"; 
    377497        print $cache $name,"\n"; 
    378         print $cache join("\n",@pat),"\n" or die "Can't print: $!"; 
     498        print $cache join("\n",@pat),"\n\n" or die "Can't print: $!"; 
     499        print $cache Dump($T) if $T; 
    379500        close($cache) or die "Can't close: $!"; 
    380501        $self->deb("regenerated $dir/$file") if $DEBUG & DEBUG::autolexer; 
    … …  
    658779    } 
    659780 
    660     # A rudimentary trie walker, unused so far.  It assumes a prebuilt trie; 
    661     # it will need some revisions to build it on the fly.  Also, it's currently 
    662     # written for clarity rather than speed, and that will also change later. 
    663     # There is an arbitrary cutoff between characters we look up by array 
    664     # vs characters we look up by hash. ->{T}[0] is the array, [1] is the hash. 
    665     # and [2] contains actual results generator closure.  At the moment we just 
    666     # drop through if we don't get a result, which is always. 
     781    # A rudimentary trie walker. 
    667782 
    668783    if (my $state = $lexer->{T}) { 
     784        my @candidates; 
    669785        my $p = $P; 
    670786        my $ch = $::ORIG[$p]; 
    671787        my $next; 
    672         while ($next = $state->[0][$ch] // $state->[1]{chr $ch}) { 
     788        print STDERR "=" x 10,"\n$p TRIE for ${pkg}::$name in ", ref $self, "\n", 
     789                $p," ", pack("U",$ch), "\n" if $DEBUG & DEBUG::autolexer; 
     790        for (;;) { 
     791            if ($state->{'~~'}) { 
     792                if (not $state->{''}++) { 
     793                    for (@{$state->{'~~'}}) { 
     794                        next if /^\d/; 
     795                        next unless $_; 
     796                        next if ref $_ eq 'CODE'; 
     797                        our %RXCACHE; 
     798                        $_ = $RXCACHE{$_} //= eval "sub { \$::ORIG =~ /\\G$_/xsgc }"; 
     799                    } 
     800                } 
     801                my @x = @{$state->{'~~'}}; 
     802                while (my ($final,$fnum) = splice(@x,0,2)) { 
     803                    my $pend = $p; 
     804                    if ($final) { 
     805                        print STDERR $p,"     probing $fnum\n" if $DEBUG & DEBUG::autolexer; 
     806                        pos($::ORIG) = $p; 
     807                        next unless &$final; 
     808                        $pend = pos($::ORIG); 
     809                    } 
     810                    push(@{$candidates[$pend - $P][$p - $P]}, $fnum); 
     811                    print STDERR $pend," FNUM $fnum @",$pend - $P,"\n" if $DEBUG & DEBUG::autolexer; 
     812                } 
     813            } 
     814            last unless $next = $state->{chr $ch}; 
     815            if ($DEBUG & DEBUG::autolexer) { 
     816                print STDERR substr($::ORIG, $P, $p - $P), "\n"; 
     817                print STDERR $p," ", pack("U",$ch), "\n"; 
     818            } 
    673819            $ch = $::ORIG[++$p]; 
    674820            $state = $next; 
    675821        } 
    676         if ($state->[2]) { 
    677             return $state->[2]; 
    678         } 
    679     } 
     822        my @fnums = map { $_ ? map({ $_ ? @$_ : () } reverse @$_) : () } reverse @candidates; 
     823        print STDERR $p," FNUMS @fnums\n" if $DEBUG & DEBUG::autolexer; 
     824        for my $fnum (@fnums) { 
     825            my $f = $lexer->{FATES}; 
     826            print STDERR "$fnum ",::fatestr($f->[$fnum]),"\n" if $DEBUG & DEBUG::autolexer; 
     827        } 
     828 
     829        my @FATES = @{$lexer->{FATES}}[@fnums]; 
     830        return sub { splice(@FATES,0) }; 
     831    } 
     832    print STDERR "FAILED trie at $P\n" if $DEBUG & DEBUG::autolexer; 
    680833 
    681834    pos($::ORIG) = $P; 
    … …  
    98811411; 
    9891142END 
     1143        $lang->deb("derive $genpkg from $WHAT adding $mangle") if $DEBUG & DEBUG::mixins; 
    9901144        eval $e or die "Can't create $name: $@\n"; 
    9911145        $::PARSER = $lang->cursor_fresh($genpkg); 
    … …  
    21152269            } 
    21162270            elsif ($_ eq '$$') { 
    2117                 return '(?:$|\\x0a)'; 
     2271                return '(?:\\x0a|$)'; 
    21182272            } 
    21192273            elsif ($_ eq ':' or $_ eq '^^') { 

  • src/perl6/gimme5

    r22909 r23015  
    278278        $out .= <<'END' if $TOP eq 'STD'; 
    279279    $self->_AUTOLEXpeek('termish',$retree); 
    280     system('cp','lex/'.ref($self).'/termish','lex/'.ref($self).'/EXPR'); 
    281280END 
    282281 
    … …  
    337336        if (my \$fate = \$C->{_fate}) { 
    338337            if (\$fate->[0] eq '$name') { 
    339                 \$C->deb("Fate passed to $name: \$\$fate[3]") if \$DEBUG & DEBUG::fates; 
     338                \$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$DEBUG & DEBUG::fates; 
    340339                (\$tag, \$try, \$fate) = \@\$fate; 
    341340                \$C->{_fate} = \$fate; 
    … …  
    24872486    my \$fate; 
    24882487    if (\$fate = \$C->{_fate} and \$fate->[0] eq '$altname') { 
    2489         \$C->deb("Fate passed to $altname: \$\$fate[3]") if \$DEBUG & DEBUG::fates; 
     2488        \$C->deb("Fate passed to $altname: ", ::fatestr(\$fate)) if \$DEBUG & DEBUG::fates; 
    24902489        (\$tag, \$try, \$fate) = \@\$fate; 
    24912490        \$C->{_fate} = \$fate; 

  • src/perl6/tryfile

    r22911 r23015  
    33use STD; 
    44use utf8; 
    5 use YAML::XS; 
    6 use Encode; 
    75 
    86my $failures = 0; 
    … …  
    1614    warn $file,"\n" if @ARGV > 1; 
    1715    eval { 
    18         STD->parsefile($file); 
     16        warn "Undefined\n" unless defined STD->parsefile($file); 
    1917    }; 
    2018    if ($@) { 
    … …  
    2321    } 
    2422} 
     23my ($time, $vsz) = split(' ', `ps -o "time= vsz=" $$`); 
     24$time =~ s/^00://; 
     25$vsz =~ s/\d\d\d$/m/; 
     26warn "$time $vsz\n" if $vsz; 
    2527 
    2628exit $failures;