IfaceEnv: Only check for built-in OccNames if mod is GHC.Types

This check is not entirely cheap and will not succeed unless we are
looking for something in the module where built-in syntax lives,
GHC.Types.

Reviewers: simonpj, austin

Subscribers: simonpj, thomie, osa1

Differential Revision: https://phabricator.haskell.org/D2400

1 files changed, 43 insertions, 24 deletions

diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 8465cd98a2..86f1dde3d4 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -5,6 +5,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | This module is about types that can be defined in Haskell, but which
 --   must be wired into the compiler nonetheless.  C.f module TysPrim
@@ -134,7 +135,6 @@ import {-# SOURCE #-} ConLike
 import TyCon
 import Class            ( Class, mkClass )
 import RdrName
-import UniqFM
 import Name
 import NameSet          ( NameSet, mkNameSet, elemNameSet )
 import BasicTypes       ( Arity, Boxity(..),
@@ -148,6 +148,12 @@ import Outputable
 import Util
 import BooleanFormula   ( mkAnd )
 
+import qualified Data.ByteString.Char8 as BS
+#if !MIN_VERSION_bytestring(0,10,8)
+import qualified Data.ByteString.Internal as BSI
+import qualified Data.ByteString.Unsafe as BSU
+#endif
+
 alpha_tyvar :: [TyVar]
 alpha_tyvar = [alphaTyVar]
 
@@ -181,8 +187,7 @@ names in PrelNames, so they use wTcQual, wDataQual, etc
 -- define here.
 --
 -- Because of their infinite nature, this list excludes tuples, Any and implicit
--- parameter TyCons. Instead, we have a hack in lookupOrigNameCache to deal with
--- these names.
+-- parameter TyCons (see Note [Built-in syntax and the OrigNameCache]).
 --
 -- See also Note [Known-key names]
 wiredInTyCons :: [TyCon]
@@ -636,19 +641,42 @@ decl in GHC.Classes, so I think this part may not work properly. But
 it's unused I think.
 -}
 
-builtInOccNames :: UniqFM (OccName -> Name)
-builtInOccNames = listToUFM $
-    [ (fsLit "[]",    choose_ns listTyConName nilDataConName)
-    , (fsLit ":" ,    const consDataConName)
-    , (fsLit "[::]",  const parrTyConName)
-    , (fsLit "()",    tup_name Boxed 0)
-    , (fsLit "(##)",  tup_name Unboxed 0)
-    ] ++
-    [ (fsLit $ "("++replicate n ','++")", tup_name Boxed (n+1)) | n <- [1..62] ] ++
-    [ (fsLit $ "(#"++replicate n ','++"#)", tup_name Unboxed (n+1)) | n <- [1..62] ]
+-- | Built in syntax isn't "in scope" so these OccNames map to wired-in Names
+-- with BuiltInSyntax. However, this should only be necessary while resolving
+-- names produced by Template Haskell splices since we take care to encode
+-- built-in syntax names specially in interface files. See
+-- Note [Symbol table representation of names].
+isBuiltInOcc_maybe :: OccName -> Maybe Name
+isBuiltInOcc_maybe occ =
+    case name of
+      "[]"   -> Just $ choose_ns listTyConName nilDataConName
+      ":"    -> Just consDataConName
+      "[::]" -> Just parrTyConName
+      "()"   -> Just $ tup_name Boxed 0
+      "(##)" -> Just $ tup_name Unboxed 0
+      _ | Just rest <- "(" `stripPrefix` name
+        , (commas, rest') <- BS.span (==',') rest
+        , ")" <- rest'
+             -> Just $ tup_name Boxed (1+BS.length commas)
+      _ | Just rest <- "(#" `stripPrefix` name
+        , (commas, rest') <- BS.span (==',') rest
+        , "#)" <- rest'
+             -> Just $ tup_name Unboxed (1+BS.length commas)
+      _ -> Nothing
   where
-    choose_ns :: Name -> Name -> OccName -> Name
-    choose_ns tc dc occ
+    -- TODO: Drop when bytestring 0.10.8 can be assumed
+#if MIN_VERSION_bytestring(0,10,8)
+    stripPrefix = BS.stripPrefix
+#else
+    stripPrefix bs1@(BSI.PS _ _ l1) bs2
+      | bs1 `BS.isPrefixOf` bs2 = Just (BSU.unsafeDrop l1 bs2)
+      | otherwise = Nothing
+#endif
+
+    name = fastStringToByteString $ occNameFS occ
+
+    choose_ns :: Name -> Name -> Name
+    choose_ns tc dc
       | isTcClsNameSpace ns   = tc
       | isDataConNameSpace ns = dc
       | otherwise             = pprPanic "tup_name" (ppr occ)
@@ -658,15 +686,6 @@ builtInOccNames = listToUFM $
       = choose_ns (getName (tupleTyCon   boxity arity))
                   (getName (tupleDataCon boxity arity))
 
-
-isBuiltInOcc_maybe :: OccName -> Maybe Name
--- Built in syntax isn't "in scope" so these OccNames
--- map to wired-in Names with BuiltInSyntax
-isBuiltInOcc_maybe occ
-  = case lookupUFM builtInOccNames (occNameFS occ) of
-      Just f  -> Just (f occ)
-      Nothing -> Nothing
-
 mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
 -- No need to cache these, the caching is done in mk_tuple
 mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr   ar)