[commit: ghc] wip/tdammers-7258: Factor out readField (#14364) (a6dd03e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/tdammers-7258
Link       : http://ghc.haskell.org/trac/ghc/changeset/a6dd03e751d17467be10eea3ff1b1773d8d35893/ghc

>---------------------------------------------------------------

commit a6dd03e751d17467be10eea3ff1b1773d8d35893
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Wed Oct 18 15:44:57 2017 +0200

    Factor out readField (#14364)
    
    Improves compiler performance of deriving Read instances.


>---------------------------------------------------------------

a6dd03e751d17467be10eea3ff1b1773d8d35893
 compiler/prelude/PrelNames.hs    |  4 ++++
 compiler/typecheck/TcGenDeriv.hs | 35 ++++++++++++++++++++---------------
 libraries/base/GHC/Read.hs       | 18 ++++++++++++++++++
 3 files changed, 42 insertions(+), 15 deletions(-)

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 760aea5..ae695d4 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -742,6 +742,10 @@ choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")
 lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")
 expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")
 
+readField_RDR, readSymField_RDR :: RdrName
+readField_RDR           = varQual_RDR gHC_READ (fsLit "readField")
+readSymField_RDR        = varQual_RDR gHC_READ (fsLit "readSymField")
+
 punc_RDR, ident_RDR, symbol_RDR :: RdrName
 punc_RDR                = dataQual_RDR lEX (fsLit "Punc")
 ident_RDR               = dataQual_RDR lEX (fsLit "Ident")
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 9e27ad5..2d004be 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1068,21 +1068,26 @@ gen_Read_binds get_fixity loc tycon
     read_arg a ty = ASSERT( not (isUnliftedType ty) )
                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 
-    read_field lbl a = read_lbl lbl ++
-                       [read_punc "=",
-                        noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
-
-        -- When reading field labels we might encounter
-        --      a  = 3
-        --      _a = 3
-        -- or   (#) = 4
-        -- Note the parens!
-    read_lbl lbl | isSym lbl_str
-                 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
-                 | otherwise
-                 = ident_h_pat lbl_str
-                 where
-                   lbl_str = unpackFS lbl
+    -- When reading field labels we might encounter
+    --      a  = 3
+    --      _a = 3
+    -- or   (#) = 4
+    -- Note the parens!
+    read_field lbl a =
+        [noLoc
+          (mkBindStmt
+            (nlVarPat a)
+            (nlHsApps
+              read_field
+              [nlHsLit (mkHsString lbl_str), nlHsVar readPrec_RDR]
+            )
+          )
+        ]
+        where
+          lbl_str = unpackFS lbl
+          read_field
+              | isSym lbl_str = readSymField_RDR
+              | otherwise = readField_RDR
 
 {-
 ************************************************************************
diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs
index ad29cc5..e69e4a0 100644
--- a/libraries/base/GHC/Read.hs
+++ b/libraries/base/GHC/Read.hs
@@ -36,6 +36,8 @@ module GHC.Read
   , choose
   , readListDefault, readListPrecDefault
   , readNumber
+  , readField
+  , readSymField
 
   -- Temporary
   , readParen
@@ -359,6 +361,22 @@ choose sps = foldr ((+++) . try_one) pfail sps
                                     L.Symbol s' | s==s' -> p
                                     _other              -> pfail }
 
+readField :: String -> ReadPrec a -> ReadPrec a
+readField fieldName readVal = do
+        expectP (L.Ident fieldName)
+        expectP (L.Punc "=")
+        readVal
+{-# NOINLINE readField #-}
+
+readSymField :: String -> ReadPrec a -> ReadPrec a
+readSymField fieldName readVal = do
+        expectP (L.Punc "(")
+        expectP (L.Symbol fieldName)
+        expectP (L.Punc ")")
+        expectP (L.Punc "=")
+        readVal
+{-# NOINLINE readSymField #-}
+
 --------------------------------------------------------------
 -- Simple instances of Read
 --------------------------------------------------------------