Parsing performance improvements

Parsing lists of things is no longer O(n^2). Fixed using the 'Reversed' newtype.
Allocations stay roughly the same, time improvements are on the order of 3-7%

Also tweaked tests to clear out WIP.json on every run (since it can never still be relevant)

Author: harpocrates

benchmarks/allocation-benchmarks/Main.hs

@@ -3,16 +3,18 @@
 import Weigh
 
 import Control.Monad (filterM)
+import Control.Exception (catch, throwIO)
 import Data.Foldable (for_)
 import Data.Traversable (for)
 import GHC.Exts (fromString)
 
 import Language.Rust.Syntax (SourceFile)
 import Language.Rust.Parser (readInputStream, Span, parse')
 
-import System.Directory (getCurrentDirectory, listDirectory, createDirectoryIfMissing, doesFileExist)
+import System.Directory (getCurrentDirectory, listDirectory, createDirectoryIfMissing, doesFileExist, removeFile)
 import System.FilePath ((</>), (<.>), takeFileName)
 import System.Process (proc, readCreateProcess)
+import System.IO.Error (isDoesNotExistError)
 
 import Data.Aeson
 import qualified Data.ByteString.Lazy as BL
@@ -34,6 +36,10 @@ main = do
   entries <- map (sampleSources </>) <$> listDirectory sampleSources
   files <- filterM doesFileExist entries
 
+  -- Clear out previous WIP (if there is one)
+  catch (removeFile (workingDirectory </> "allocations" </> "WIP" <.> "json"))
+        (\e -> if isDoesNotExistError e then pure () else throwIO e)
+
   -- Run 'weigh' tests
   fileStreams <- for files $ \file -> do { is <- readInputStream file; pure (takeFileName file, is) }
   let weigh = do setColumns [ Case, Max, Allocated, GCs, Live ]

benchmarks/timing-benchmarks/Main.hs

@@ -6,15 +6,17 @@ import Criterion.Types (anMean, reportAnalysis, timeLimit, anOutlierVar, ovEffec
 import Statistics.Resampling.Bootstrap (Estimate(..))
 
 import Control.Monad (filterM)
+import Control.Exception (catch, throwIO)
 import Data.Traversable (for)
 import GHC.Exts (fromString)
 
 import Language.Rust.Syntax (SourceFile)
 import Language.Rust.Parser (readInputStream, Span, parse')
 
-import System.Directory (getCurrentDirectory, listDirectory, createDirectoryIfMissing, doesFileExist)
+import System.Directory (getCurrentDirectory, listDirectory, createDirectoryIfMissing, doesFileExist, removeFile)
 import System.FilePath ((</>), (<.>), takeFileName)
 import System.Process (proc, readCreateProcess)
+import System.IO.Error (isDoesNotExistError)
 
 import Data.Aeson
 import qualified Data.ByteString.Lazy as BL
@@ -33,6 +35,10 @@ main = do
   entries <- map (sampleSources </>) <$> listDirectory sampleSources
   files <- filterM doesFileExist entries
 
+  -- Clear out previous WIP (if there is one)
+  catch (removeFile (workingDirectory </> "timings" </> "WIP" <.> "json"))
+        (\e -> if isDoesNotExistError e then pure () else throwIO e)
+
   -- Run 'criterion' tests
   reports <- for files $ \f -> do
     let name = takeFileName f

src/Language/Rust/Parser/Internal.y

@@ -37,8 +37,10 @@ import Language.Rust.Data.Position
 import Language.Rust.Parser.Lexer (lexNonSpace, lexShebangLine)
 import Language.Rust.Parser.ParseMonad (pushToken, getPosition, P, parseError)
 import Language.Rust.Parser.Literals (translateLit)
+import Language.Rust.Parser.Reversed
 
-import Data.List.NonEmpty (NonEmpty(..), (<|), toList)
+import Data.Foldable (toList)
+import Data.List.NonEmpty (NonEmpty(..), (<|))
 import qualified Data.List.NonEmpty as N
 import Data.Semigroup ((<>))
 import Text.Read (readMaybe)
@@ -323,8 +325,8 @@ gt :: { () }
 -------------
 
 -- | One or more occurences of 'p'
-some(p) :: { NonEmpty a }
-  : some(p) p          { $1 |> $2 }
+some(p) :: { Reversed NonEmpty a }
+  : some(p) p          { let Reversed xs = $1 in Reversed ($2 <| xs) }
   | p                  { [$1] }
 
 -- | Zero or more occurences of 'p'
@@ -333,8 +335,8 @@ many(p) :: { [a] }
   | {- empty -}        { [] }
 
 -- | One or more occurences of 'p', seperated by 'sep'
-sep_by1(p,sep) :: { NonEmpty a }
-  : sep_by1(p,sep) sep p  { $1 |> $3 }
+sep_by1(p,sep) :: { Reversed NonEmpty a }
+  : sep_by1(p,sep) sep p  { let Reversed xs = $1 in Reversed ($3 <| xs) }
   | p                     { [$1] }
 
 -- | Zero or more occurrences of 'p', separated by 'sep'
@@ -343,7 +345,7 @@ sep_by(p,sep) :: { [a] }
   | {- empty -}        { [] }
 
 -- | One or more occurrences of 'p', seperated by 'sep', optionally ending in 'sep'
-sep_by1T(p,sep) :: { NonEmpty a }
+sep_by1T(p,sep) :: { Reversed NonEmpty a }
   : sep_by1(p,sep) sep { $1 }
   | sep_by1(p,sep)     { $1 }
 
@@ -540,7 +542,7 @@ ty_qual_path :: { Spanned (QSelf Span, Path Span) }
 
 -- parse_path_segments_without_colons()
 path_segments_without_colons :: { Spanned (NonEmpty (Ident, PathParameters Span)) }
-  : sep_by1(path_segment_without_colons, '::')  { sequence $1 }
+  : sep_by1(path_segment_without_colons, '::')  { sequence (toNonEmpty $1) }
 
 -- No corresponding function - see path_segments_without_colons
 path_segment_without_colons :: { Spanned (Ident, PathParameters Span) }
@@ -609,7 +611,7 @@ ty_general :: { Ty Span }
 -- All types, including trait types with plus
 ty :: { Ty Span }
   : ty_no_plus                                                    { $1 }
-  | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| $3) ($1 # $3) }
+  | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| toNonEmpty $3) ($1 # $3) }
 
 -- parse_ty_no_plus()
 ty_no_plus :: { Ty Span }
@@ -621,7 +623,7 @@ ty_no_plus :: { Ty Span }
 ty_prim :: { Ty Span }
   : no_for_ty_prim                   { $1 }
   | for_ty_no_plus                   { $1 }
-  | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| $3) ($1 # $3) }
+  | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| toNonEmpty $3) ($1 # $3) }
 
 -- All (non-sum) types not starting with a 'for'
 no_for_ty :: { Ty Span }
@@ -665,7 +667,7 @@ for_ty_no_plus :: { Ty Span }
     }
 
 impl_ty :: { Ty Span }
-  : impl sep_by1(ty_param_bound_mod,'+') %prec IMPLTRAIT { ImplTrait $2 ($1 # $2) }
+  : impl sep_by1(ty_param_bound_mod,'+') %prec IMPLTRAIT { ImplTrait (toNonEmpty $2) ($1 # $2) }
 
 -- An optional lifetime followed by an optional mutability
 lifetime_mut :: { (Maybe (Lifetime Span), Mutability) }
@@ -810,8 +812,8 @@ pat_tup :: { ([Pat Span], Maybe Int, Bool) }
 pat_slice :: { ([Pat Span], Maybe (Pat Span), [Pat Span]) }
   : sep_by1(pat,',') ',' '..' ',' sep_by1T(pat,',')    { (toList $1, Just (WildP mempty), toList $5) }
   | sep_by1(pat,',') ',' '..'                          { (toList $1, Just (WildP mempty), []) }
-  | sep_by1(pat,',')     '..' ',' sep_by1T(pat,',')    { (N.init $1, Just (N.last $1),    toList $4) }
-  | sep_by1(pat,',')     '..'                          { (N.init $1, Just (N.last $1),    []) }
+  | sep_by1(pat,',')     '..' ',' sep_by1T(pat,',')    { let (xs, x) = unsnoc $1 in (toList xs, Just x,    toList $4) }
+  | sep_by1(pat,',')     '..'                          { let (xs, x) = unsnoc $1 in (toList xs, Just x,    []) }
   |                               sep_by1T(pat,',')    { (toList $1, Nothing,             []) }
   |                      '..' ',' sep_by1T(pat,',')    { ([],        Just (WildP mempty), toList $3) }
   |                      '..'                          { ([],        Just (WildP mempty), []) }
@@ -1050,7 +1052,7 @@ arms :: { [Arm Span] }
   : ntArm                                               { [$1] }
   | ntArm arms                                          { $1 : $2 }
   | many(outer_attribute) sep_by1(pat,'|') arm_guard '=>' expr_arms
-    { let (e,as) = $> in (Arm $1 $2 $3 e ($1 # $2 # e) : as) }
+    { let (e,as) = $> in (Arm $1 (toNonEmpty $2) $3 e ($1 # $2 # e) : as) }
 
 arm_guard :: { Maybe (Expr Span) }
   : {- empty -}  { Nothing }
@@ -1453,14 +1455,14 @@ def :: { Spanned Defaultness }
   | default              { Spanned Default (spanOf $1) }
 
 view_path :: { ViewPath Span }
-  : '::' sep_by1(self_or_ident,'::')                                 { let n = fmap unspan $2 in ViewPathSimple True (N.init n) (PathListItem (N.last n) Nothing mempty) ($1 # $>) }
-  | '::' sep_by1(self_or_ident,'::') as ident                        { let n = fmap unspan $2 in ViewPathSimple True (N.init n) (PathListItem (N.last n) (Just (unspan $>)) mempty) ($1 # $>) }
+  : '::' sep_by1(self_or_ident,'::')                                 { let (ns,n) = unsnoc (fmap unspan $2) in ViewPathSimple True (toList ns) (PathListItem n Nothing mempty) ($1 # $>) }
+  | '::' sep_by1(self_or_ident,'::') as ident                        { let (ns,n) = unsnoc (fmap unspan $2) in ViewPathSimple True (toList ns) (PathListItem n (Just (unspan $>)) mempty) ($1 # $>) }
   | '::'                                  '*'                        { ViewPathGlob True [] ($1 # $2) }
   | '::' sep_by1(self_or_ident,'::') '::' '*'                        { ViewPathGlob True (fmap unspan (toList $2)) ($1 # $>) }
   | '::' sep_by1(self_or_ident,'::') '::' '{' sep_byT(plist,',') '}' { ViewPathList True (map unspan (toList $2)) $5 ($1 # $>) }
   | '::'                                  '{' sep_byT(plist,',') '}' { ViewPathList True [] $3 ($1 # $>) }
-  |      sep_by1(self_or_ident,'::')                                 { let n = fmap unspan $1 in ViewPathSimple False (N.init n) (PathListItem (N.last n) Nothing mempty) ($1 # $>) }
-  |      sep_by1(self_or_ident,'::') as ident                        { let n = fmap unspan $1 in ViewPathSimple False (N.init n) (PathListItem (N.last n) (Just (unspan $>)) mempty) ($1 # $>) }
+  |      sep_by1(self_or_ident,'::')                                 { let (ns,n) = unsnoc (fmap unspan $1) in ViewPathSimple False (toList ns) (PathListItem n Nothing mempty) ($1 # $>) }
+  |      sep_by1(self_or_ident,'::') as ident                        { let (ns,n) = unsnoc (fmap unspan $1) in ViewPathSimple False (toList ns) (PathListItem n (Just (unspan $>)) mempty) ($1 # $>) }
   |                                       '*'                        { ViewPathGlob False [] (spanOf $1) }
   |      sep_by1(self_or_ident,'::') '::' '*'                        { ViewPathGlob False (fmap unspan (toList $1)) ($1 # $>) }
   |      sep_by1(self_or_ident,'::') '::' '{' sep_byT(plist,',') '}' { ViewPathList False (map unspan (toList $1)) $4 ($1 # $>) }

src/Language/Rust/Parser/Reversed.hs

@@ -13,16 +13,22 @@ along with the usual class instances.
 {-# LANGUAGE FlexibleInstances, TypeFamilies #-}
 
 module Language.Rust.Parser.Reversed (
-  Reversed(..), toNonEmpty
+  Reversed(..), toNonEmpty, unsnoc
 ) where
 
 import Data.Foldable
+import Data.Semigroup
 import qualified Data.List.NonEmpty as N
 import qualified GHC.Exts as G
 
+import Language.Rust.Data.Position
+
 -- | Wrap a data type where all the operations are reversed
 newtype Reversed f a = Reversed (f a)
 
+instance Functor f => Functor (Reversed f) where
+  fmap f (Reversed xs) = Reversed (fmap f xs)
+
 instance Foldable (Reversed []) where
   foldMap f (Reversed xs) = foldMap f (reverse xs)
   toList (Reversed xs) = reverse xs
@@ -31,6 +37,9 @@ instance Foldable (Reversed N.NonEmpty) where
   foldMap f (Reversed xs) = foldMap f (N.reverse xs)
   toList (Reversed xs) = reverse (toList xs)
 
+instance Semigroup (f a) => Semigroup (Reversed f a) where
+  Reversed xs <> Reversed ys = Reversed (ys <> xs)
+
 instance Monoid (f a) => Monoid (Reversed f a) where
   mempty = Reversed mempty
   mappend (Reversed xs) (Reversed ys) = Reversed (mappend ys xs)
@@ -40,9 +49,15 @@ instance G.IsList (f a) => G.IsList (Reversed f a) where
   fromList xs = Reversed (G.fromList (reverse xs))
   toList (Reversed xs) = reverse (G.toList xs)
 
+instance Located (f a) => Located (Reversed f a) where
+  spanOf (Reversed xs) = spanOf xs
+
 -- | Convert a reversed 'N.NonEmpty' back into a normal one.
+{-# INLINE toNonEmpty #-}
 toNonEmpty :: Reversed N.NonEmpty a -> N.NonEmpty a
 toNonEmpty (Reversed xs) = N.reverse xs
-  
-
 
+-- TODO
+{-# INLINE unsnoc #-}
+unsnoc :: Reversed N.NonEmpty a -> (Reversed [] a, a)
+unsnoc (Reversed (x N.:| xs)) = (Reversed xs, x)