Changeset 21973 for src/perl6

Timestamp:

08/20/08 21:11:51 (3 months ago)

Author:

lwall

Message:

[STD etc.] squeezing out unnecessary calls to lazymap under ratchet

Location:

src/perl6

Files:

• Cursor.pmc (modified) (4 diffs)
• STD.pm (modified) (31 diffs)
• gimme5 (modified) (4 diffs)

src/perl6/Cursor.pmc

@@ -1091 +1091 @@
 }
 
+sub _MATCHIFYr { my $self = shift;
+    return () unless @_;
+    my $var = shift;
+    $var->{_from} = $self->{_from};
+    $var->retm();
+}
+
 sub _SCANf { my $self = shift;
 
@@ -1291 +1298 @@
     lazymap(sub { bless($_[0],ref($self))->retm() },
         $block->($self));
+}
+
+sub _BRACKETr { my $self = shift;
+    my $block = shift;
+
+    local $CTX = $self->callm if $DEBUG & DEBUG::trace_call;
+    my ($val) = $block->($self) or return ();
+    bless($val,ref($self))->retm();
 }
 
@@ -1419 +1434 @@
     lazymap(sub { $self->cursor_bind($names, $_[0])->retm() },
         $block->($self));
+}
+
+sub _SUBSUMEr { my $self = shift;
+    my $names = shift;
+    my $block = shift;
+
+    local $CTX = $self->callm($names ? "@$names" : "") if $DEBUG & DEBUG::trace_call;
+    my ($var) = $block->($self) or return ();
+    $self->cursor_bind($names, $var)->retm();
 }
 
@@ -2219 +2243 @@
 { package RE_noop; our @ISA = 'RE_base';
     sub longest { my $self = shift; my ($C) = @_; 
-        return;
+        return $IMP;
     }
 }

src/perl6/STD.pm

@@ -422 +422 @@
 
 token vws {
-    \v ::
+    \v
     { $COMPILING::LINE++ } # XXX wrong several ways, use self.lineof($¢.pos)
     [ '#DEBUG -1' { say "DEBUG"; $STD::DEBUG = $*DEBUG = -1; } ]?
@@ -441 +441 @@
             [ <!after ^^ . > || <.panic: "Can't use embedded comments in column 1"> ]
             <.quibble($¢.cursor_fresh( ::STD::Q ))>   {*}                               #= embedded
-         | :: \N*            {*}                                 #= end
+         | {} \N*            {*}                                 #= end
          ]
 }
@@ -773 +773 @@
     ]
     # XXX assuming no precedence change
-    ::
+    
     <prefix_postfix_meta_operator>*                 {*}         #= prepost
     { $+prevop = $<O> }
@@ -793 +793 @@
 token termish {
     [
-    | <pre>+ :: <noun>
+    | <pre>+ <noun>
     | <noun>
     ]
-    ::
 
     # also queue up any postfixes, since adverbs could change things
@@ -839 +838 @@
 
 token fatarrow {
-    <key=identifier> \h* '=>' :: <.ws> <val=EXPR(item %item_assignment)>
+    <key=identifier> \h* '=>' <.ws> <val=EXPR(item %item_assignment)>
 }
 
@@ -862 +861 @@
         { $key = ""; $value = $<postcircumfix>; }
         {*}                                                     #= structural
-    | $<var> = (<sigil> :: <twigil>? <desigilname>)
+    | $<var> = (<sigil> {} <twigil>? <desigilname>)
         { $key = $<var><desigilname>.text; $value = $<var>; }
         {*}                                                     #= varname
@@ -1088 +1087 @@
         <.unsp>?
         [
-        | '(' :: <in: ')', 'signature'>
-        | '[' :: <in: ']', 'semilist', 'shape definition'>
-        | '{' :: <in: '}', 'semilist', 'shape definition'>
+        | '(' <in: ')', 'signature'>
+        | '[' <in: ']', 'semilist', 'shape definition'>
+        | '{' <in: '}', 'semilist', 'shape definition'>
         | <?before '<'> <postcircumfix>
         ]*
@@ -1188 +1187 @@
         }}
         {*}                                                     #= block
-    || <?{ $+begin_compunit }> :: <?before ';'>
+    || <?{ $+begin_compunit }> {} <?before ';'>
         {
             $longname orelse $¢.panic("Compilation unit cannot be anonymous");
@@ -1500 +1499 @@
 
 token variable {
-    <?before <sigil> > ::
+    <?before <sigil> > {}
     [
     || '&' <twigil>?  <sublongname> {*}                                   #= subnoun
@@ -1561 +1560 @@
     [
     | <identifier>
-    | '(' :: <in: ')', 'EXPR', 'indirect name'>
+    | '(' <in: ')', 'EXPR', 'indirect name'>
     ]
 }
@@ -1665 +1664 @@
 token rad_number {
     ':' $<radix> = [\d+] <.unsp>?      # XXX optional dot here?
-    ::           # don't recurse in lexer
+    {}           # don't recurse in lexer
     [
     || '<'
@@ -1771 +1770 @@
 
     $start <left=nibble($lang)> $stop 
-    [ <?{ $start ne $stop }> ::
+    [ <?{ $start ne $stop }>
         <.ws>
         [ '=' || <.panic: "Missing '='"> ]
@@ -1788 +1787 @@
 
     $start <left=nibble($lang)> $stop 
-    [ <?{ $start ne $stop }> ::
+    [ <?{ $start ne $stop }>
         <.ws> <quibble($lang2)>
     || 
@@ -2153 +2152 @@
 
 token codepoint {
-    '[' :: ( [<!before ']'> .]*? ) ']'
+    '[' {} ( [<!before ']'> .]*? ) ']'
 }
 
@@ -2174 +2173 @@
             | <codepoint>
             | \d+
-            | :: [ <[ ?.._ ]> || <.panic: "Unrecognized \\c character"> ]
+            | [ <[ ?.._ ]> || <.panic: "Unrecognized \\c character"> ]
             ]
         }
@@ -2271 +2270 @@
 
         # in single quotes, keep backslash on random character by default
-        token backslash:misc { :: (.) { $<text> = "\\" ~ $0; } }
+        token backslash:misc { {} (.) { $<text> = "\\" ~ $0; } }
 
         # begin tweaks (DO NOT ERASE)
@@ -2283 +2282 @@
         token stopper { \" }
         # in double quotes, omit backslash on random \W backslash by default
-        token backslash:misc { :: [ (\W) { $<text> = $0.text; } | $<x>=(\w) <.panic("Unrecognized backslash sequence: '\\" ~ $<x>.text ~ "'")> ] }
+        token backslash:misc { {} [ (\W) { $<text> = $0.text; } | $<x>=(\w) <.panic("Unrecognized backslash sequence: '\\" ~ $<x>.text ~ "'")> ] }
 
         # begin tweaks (DO NOT ERASE)
@@ -2342 +2341 @@
 grammar Quasi is STD {
     token term:unquote {
-        <starter><starter><starter> :: <statementlist> <stopper><stopper><stopper>
+        <starter><starter><starter> <statementlist> <stopper><stopper><stopper>
     }
 
@@ -2387 +2386 @@
     | <sigil> '.'
         [
-        | '(' :: <in: ')', 'signature'>
-        | '[' :: <in: ']', 'signature'>
-        | '{' :: <in: '}', 'signature'>
+        | '(' <in: ')', 'signature'>
+        | '[' <in: ']', 'signature'>
+        | '{' <in: '}', 'signature'>
         | <?before '<'> <postcircumfix>
         ]
@@ -2512 +2511 @@
     [
         # Is it a longname declaration?
-    || <?{ $<sigil>.text eq '&' }> <?identifier> ::
+    || <?{ $<sigil>.text eq '&' }> <?ident> {}
         <identifier=sublongname>
 
@@ -3089 +3088 @@
     | '(' <in: ')', 'semilist', 'argument list'> {*}              #= func args
     | <.unsp> '.'? '(' <in: ')', 'semilist', 'argument list'> {*} #= func args
-    | :: [<?before \s> <!{ $istype }> <.ws> <!infixstopper> <arglist>]? { $listopy = 1 }
+    | {} [<?before \s> <!{ $istype }> <.ws> <!infixstopper> <arglist>]? { $listopy = 1 }
     ]
 
@@ -3103 +3102 @@
 token term:name ( --> Term)
 {
-    <longname> ::
+    <longname>
     [
     ||  <?{
             $¢.is_type($<longname>.text) or substr($<longname>.text,0,2) eq '::'
-        }> ::
+        }>
         # parametric type?
         <.unsp>? [ <?before '['> <postcircumfix> ]?
@@ -3522 +3521 @@
         [
         | \w
-        | <metachar>
-        | :: <.panic: "Unrecognized regex metacharacter">
+        | <metachar> ::
+        | <.panic: "Unrecognized regex metacharacter">
         ]
     }
@@ -3545 +3544 @@
 
     token metachar:sym<{ }> {
+        <?before '{'>
         <codeblock>
         {{ $/<sym> := <{ }> }}
@@ -3567 +3567 @@
 
     token metachar:sym<[ ]> {
-        '[' :: [:lang(self.unbalanced(']')) <nibbler>]
+        '[' {} [:lang(self.unbalanced(']')) <nibbler>]
         [ ']' || <.panic: "Unable to parse regex; couldn't find right bracket"> ]
         { $/<sym> := <[ ]> }
@@ -3573 +3573 @@
 
     token metachar:sym<( )> {
-        '(' :: [:lang(self.unbalanced(')')) <nibbler>]
+        '(' {} [:lang(self.unbalanced(')')) <nibbler>]
         [ ')' || <.panic: "Unable to parse regex; couldn't find right parenthesis"> ]
         { $/<sym> := <( )> }
@@ -3592 +3592 @@
 
     token metachar:sym«< >» {
-        '<' <unsp>? :: <assertion>
+        '<' <unsp>? {} <assertion>
         [ '>' || <.panic: "regex assertion not terminated by angle bracket"> ]
     }
@@ -3638 +3638 @@
         | <codepoint>
         | \d+
-        | :: [ <[ ?.._ ]> || <.panic: "Unrecognized \\c character"> ]
+        | [ <[ ?.._ ]> || <.panic: "Unrecognized \\c character"> ]
         ]
     }
@@ -3654 +3654 @@
     token backslash:x { :i <sym> [ <hexint> | '[' [<.ws><hexint><.ws> ] ** ',' ']' ] }
     token backslash:misc { $<litchar>=(\W) }
-    token backslash:oops { :: <.panic: "Unrecognized regex backslash sequence"> }
+    token backslash:oops { <.panic: "Unrecognized regex backslash sequence"> }
 
     token assertion:sym<...> { <sym> }
@@ -3684 +3684 @@
                                     | ':' <.ws>
                                         [ :lang($¢.cursor_fresh($+LANG).unbalanced('>')) <arglist> ]
-                                    | '(' ::
+                                    | '(' {}
                                         [ :lang($¢.cursor_fresh($+LANG)) <arglist> ]
                                         [ ')' || <.panic: "Assertion call missing right parenthesis"> ]
@@ -3698 +3698 @@
                                     | ':' <.ws>
                                         [ :lang($¢.cursor_fresh($+LANG).unbalanced('>')) <arglist> ]
-                                    | '(' ::
+                                    | '(' {}
                                         [ :lang($¢.cursor_fresh($+LANG)) <arglist> ]
                                         [ ')' || <.panic: "Assertion call missing right parenthesis"> ]

src/perl6/gimme5

@@ -463 +463 @@
             }
 
+            my $pkg;
             if ($args =~ s/ *--> *(\w*) *$//) {
-                my $pkg = $pkg_really{$1} || "${PKG}::$1";
-                $coercion = " Cursor::lazymap sub { $pkg->coerce(\$_[0]) }, ";
+                $pkg = $pkg_really{$1} || "${PKG}::$1";
             }
             $args .= ', ';
@@ -605 +605 @@
             }
             else {
+                if ($pkg) {
+                    if ($MAYBACKTRACK) {
+                        $coercion = " Cursor::lazymap sub { $pkg->coerce(\$_[0]) }, ";
+                    }
+                    else {
+                        $coercion = " map { $pkg->coerce(\$_) } ";
+                    }
+                }
+                my $ratchet = $MAYBACKTRACK ? '' : 'r';
                 $body .= <<"END";
 
-    \$self->_MATCHIFY($coercion
+    \$self->_MATCHIFY$ratchet($coercion
 <<MEAT>>
     );
@@ -1492 +1501 @@
         my $re = shift;
         return $re unless @BINDINGS;
-        $re = "\$C->_SUBSUME([" .
+        my $ratchet = $MAYBACKTRACK ? '' : 'r';
+        $re = "\$C->_SUBSUME$ratchet([" .
             join(',', map {"'$_'"} @BINDINGS) .
             "], sub {\n" . ::indent("my \$C = shift()->cursor_fresh;\n" . $re) . "\n})";
@@ -1638 +1648 @@
             $re = ::indent($$self{re}->walk(@_));
         }
-        $re = "\$C->_BRACKET$REV( sub { my \$C=shift;\n" . ::indent($re) . "\n})";
+        my $ratchet = $MAYBACKTRACK ? '' : 'r';
+        $re = "\$C->_BRACKET$ratchet( sub { my \$C=shift;\n" . ::indent($re) . "\n})";
         $self->bind($re);
     }