From e3ddf58d26cb490e5bf523d45b37c4d95379f19c Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Wed, 26 Apr 2023 13:52:51 +0200
Subject: linear types: Don't add external names to the usage env

This has no observable effect, but avoids storing useless data.
---
 compiler/GHC/Core/Lint.hs     |  2 +-
 compiler/GHC/Core/UsageEnv.hs | 12 +++++++++---
 compiler/GHC/Tc/Gen/Head.hs   |  4 ++--
 3 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 2465a2ffdf..483d7168f7 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -3210,7 +3210,7 @@ varCallSiteUsage :: Id -> LintM UsageEnv
 varCallSiteUsage id =
   do m <- getUEAliases
      return $ case lookupNameEnv m (getName id) of
-         Nothing    -> unitUE id OneTy
+         Nothing    -> singleUsageUE id
          Just id_ue -> id_ue
 
 ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM ()
diff --git a/compiler/GHC/Core/UsageEnv.hs b/compiler/GHC/Core/UsageEnv.hs
index 3f28178fe2..4b40ac67c6 100644
--- a/compiler/GHC/Core/UsageEnv.hs
+++ b/compiler/GHC/Core/UsageEnv.hs
@@ -10,13 +10,14 @@ module GHC.Core.UsageEnv
   , scaleUsage
   , supUE
   , supUEs
-  , unitUE
+  , singleUsageUE
   , zeroUE
   ) where
 
 import Data.Foldable
 import GHC.Prelude
 import GHC.Core.Multiplicity
+import GHC.Types.Var
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Utils.Outputable
@@ -54,8 +55,13 @@ scaleUsage x     (MUsage y) = MUsage $ mkMultMul x y
 -- For now, we use extra multiplicity Bottom for empty case.
 data UsageEnv = UsageEnv !(NameEnv Mult) Bool
 
-unitUE :: NamedThing n => n -> Mult -> UsageEnv
-unitUE x w = UsageEnv (unitNameEnv (getName x) w) False
+-- | Record a single usage of an Id, i.e. {n: 1}
+-- Exception: We do not record external names (both GlobalIds and top-level LocalIds)
+-- because they're not relevant to linearity checking.
+singleUsageUE :: Id -> UsageEnv
+singleUsageUE x | isExternalName n = zeroUE
+                | otherwise = UsageEnv (unitNameEnv n OneTy) False
+  where n = getName x
 
 zeroUE, bottomUE :: UsageEnv
 zeroUE = UsageEnv emptyNameEnv False
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index a5ad2f1733..8849296e73 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -48,7 +48,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
 import GHC.Tc.Utils.Instantiate
 import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
 import GHC.Core.FamInstEnv    ( FamInstEnvs )
-import GHC.Core.UsageEnv      ( unitUE )
+import GHC.Core.UsageEnv      ( singleUsageUE )
 import GHC.Tc.Errors.Types
 import GHC.Tc.Solver          ( InferMode(..), simplifyInfer )
 import GHC.Tc.Utils.Env
@@ -1091,7 +1091,7 @@ tc_infer_id id_name
 check_local_id :: Id -> TcM ()
 check_local_id id
   = do { checkThLocalId id
-       ; tcEmitBindingUsage $ unitUE (idName id) OneTy }
+       ; tcEmitBindingUsage $ singleUsageUE id }
 
 check_naughty :: OccName -> TcId -> TcM ()
 check_naughty lbl id
-- 
cgit v1.2.1