diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2023-04-26 13:52:51 +0200 |
|---|---|---|
| committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2023-04-27 12:36:11 +0200 |
| commit | 04ed536d9dd91a77725ca2ae4485f6146f7d9a8c (patch) | |
| tree | 81f9696dd556e0970730f13724d84cd972136ea8 | |
| parent | ab6c1d295cd9f492838dbd481ecc2a66bbd17393 (diff) | |
| download | haskell-wip/usage-env.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.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/UsageEnv.hs | 12 | ||||
| -rw-r--r-- | 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 |