summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2023-04-26 13:52:51 +0200
committerKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2023-04-27 12:36:11 +0200
commit04ed536d9dd91a77725ca2ae4485f6146f7d9a8c (patch)
tree81f9696dd556e0970730f13724d84cd972136ea8
parentab6c1d295cd9f492838dbd481ecc2a66bbd17393 (diff)
downloadhaskell-04ed536d9dd91a77725ca2ae4485f6146f7d9a8c.tar.gz
linear types: Don't add external names to the usage envwip/usage-env
This has no observable effect, but avoids storing useless data.
-rw-r--r--compiler/GHC/Core/Lint.hs2
-rw-r--r--compiler/GHC/Core/UsageEnv.hs12
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs4
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