Commit 2a942285 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

PmCheck: Disattach COMPLETE pragma lookup from TyCons

By not attaching COMPLETE pragmas with a particular TyCon and instead
assume that every COMPLETE pragma is applicable everywhere, we can
drastically simplify the logic that tries to initialise available
COMPLETE sets of a variable during the pattern-match checking process,
as well as fixing a few bugs.

Of course, we have to make sure not to report any of the
ill-typed/unrelated COMPLETE sets, which came up in a few regression
tests.

In doing so, we fix #17207, #18277 and #14422.

There was a metric decrease in #18478 by ~20%.

Metric Decrease:
    T18478
parent fb6e29e8
Pipeline #24569 passed with stages
in 346 minutes and 41 seconds
......@@ -61,7 +61,7 @@ module GHC.Driver.Types (
lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,
PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
PackageCompleteMatchMap,
PackageCompleteMatches,
mkSOName, mkHsSOName, soExt,
......@@ -146,8 +146,7 @@ module GHC.Driver.Types (
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
CompleteMatch(..), CompleteMatchMap,
mkCompleteMatchMap, extendCompleteMatchMap,
ConLikeSet, CompleteMatch, CompleteMatches,
-- * Exstensible Iface fields
ExtensibleFields(..), FieldName,
......@@ -735,7 +734,7 @@ lookupIfaceByModule hpt pit mod
-- of its own, but it doesn't seem worth the bother.
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details)
hptCompleteSigs = hptAllThings (md_complete_matches . hm_details)
-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
......@@ -1093,7 +1092,7 @@ data ModIface_ (phase :: ModIfacePhase)
-- itself) but imports some trustworthy modules from its own
-- package (which does require its own package be trusted).
-- See Note [Trust Own Package] in GHC.Rename.Names
mi_complete_sigs :: [IfaceCompleteMatch],
mi_complete_matches :: [IfaceCompleteMatch],
mi_doc_hdr :: Maybe HsDocString,
-- ^ Module header.
......@@ -1184,7 +1183,7 @@ instance Binary ModIface where
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
mi_complete_sigs = complete_sigs,
mi_complete_matches = complete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
......@@ -1230,7 +1229,7 @@ instance Binary ModIface where
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
put_ bh complete_sigs
put_ bh complete_matches
lazyPut bh doc_hdr
lazyPut bh decl_docs
lazyPut bh arg_docs
......@@ -1263,7 +1262,7 @@ instance Binary ModIface where
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
complete_sigs <- get bh
complete_matches <- get bh
doc_hdr <- lazyGet bh
decl_docs <- lazyGet bh
arg_docs <- lazyGet bh
......@@ -1287,7 +1286,7 @@ instance Binary ModIface where
mi_trust = trust,
mi_trust_pkg = trust_pkg,
-- And build the cached values
mi_complete_sigs = complete_sigs,
mi_complete_matches = complete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
......@@ -1332,7 +1331,7 @@ emptyPartialModIface mod
mi_hpc = False,
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False,
mi_complete_sigs = [],
mi_complete_matches = [],
mi_doc_hdr = Nothing,
mi_decl_docs = emptyDeclDocMap,
mi_arg_docs = emptyArgDocMap,
......@@ -1388,7 +1387,7 @@ data ModDetails
md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules
md_anns :: ![Annotation], -- ^ Annotations present in this module: currently
-- they only annotate things also declared in this module
md_complete_sigs :: [CompleteMatch]
md_complete_matches :: [CompleteMatch]
-- ^ Complete match pragmas for this module
}
......@@ -1401,7 +1400,7 @@ emptyModDetails
md_rules = [],
md_fam_insts = [],
md_anns = [],
md_complete_sigs = [] }
md_complete_matches = [] }
-- | Records the modules directly imported by a module for extracting e.g.
-- usage information, and also to give better error message
......@@ -1464,7 +1463,7 @@ data ModGuts
-- ^ Files to be compiled with the C compiler
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches
mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module
mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
......@@ -2685,7 +2684,7 @@ type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageAnnEnv = AnnEnv
type PackageCompleteMatchMap = CompleteMatchMap
type PackageCompleteMatches = CompleteMatches
-- | Information about other packages that we have slurped in by reading
-- their interface files
......@@ -2747,8 +2746,8 @@ data ExternalPackageState
-- from all the external-package modules
eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated
-- from all the external-package modules
eps_complete_matches :: !PackageCompleteMatchMap,
-- ^ The total 'CompleteMatchMap' accumulated
eps_complete_matches :: !PackageCompleteMatches,
-- ^ The total 'CompleteMatches' accumulated
-- from all the external-package modules
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
......@@ -3204,83 +3203,14 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
-------------------------------------------
type ConLikeSet = UniqDSet ConLike
-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
-- See also Note [Implementation of COMPLETE pragmas].
type CompleteMatch = ConLikeSet
-- See Note [Implementation of COMPLETE signatures]
data CompleteMatch = CompleteMatch {
completeMatchConLikes :: [Name]
-- ^ The ConLikes that form a covering family
-- (e.g. Nothing, Just)
, completeMatchTyCon :: Name
-- ^ The TyCon that they cover (e.g. Maybe)
}
instance Outputable CompleteMatch where
ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl
<+> dcolon <+> ppr ty
-- | A map keyed by the 'completeMatchTyCon' which has type Name.
-- See Note [Implementation of COMPLETE signatures]
type CompleteMatchMap = UniqFM Name [CompleteMatch]
mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap
mkCompleteMatchMap = extendCompleteMatchMap emptyUFM
extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]
-> CompleteMatchMap
extendCompleteMatchMap = foldl' insertMatch
where
insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap
insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]
{-
Note [Implementation of COMPLETE signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A COMPLETE signature represents a set of conlikes (i.e., constructors or
pattern synonyms) such that if they are all pattern-matched against in a
function, it gives rise to a total function. An example is:
newtype Boolean = Boolean Int
pattern F, T :: Boolean
pattern F = Boolean 0
pattern T = Boolean 1
{-# COMPLETE F, T #-}
-- This is a total function
booleanToInt :: Boolean -> Int
booleanToInt F = 0
booleanToInt T = 1
COMPLETE sets are represented internally in GHC with the CompleteMatch data
type. For example, {-# COMPLETE F, T #-} would be represented as:
CompleteMatch { complateMatchConLikes = [F, T]
, completeMatchTyCon = Boolean }
Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the
cases in which it's ambiguous, you can also explicitly specify it in the source
language by writing this:
{-# COMPLETE F, T :: Boolean #-}
For efficiency purposes, GHC collects all of the CompleteMatches that it knows
about into a CompleteMatchMap, which is a map that is keyed by the
completeMatchTyCon. In other words, you could have a multiple COMPLETE sets
for the same TyCon:
{-# COMPLETE F, T1 :: Boolean #-}
{-# COMPLETE F, T2 :: Boolean #-}
And looking up the values in the CompleteMatchMap associated with Boolean
would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].
dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup.
Also see Note [Typechecking Complete Matches] in GHC.Tc.Gen.Bind for a more detailed
explanation for how GHC ensures that all the conlikes in a COMPLETE set are
consistent.
-}
type CompleteMatches = [CompleteMatch]
-- | Foreign language of the phase if the phase deals with a foreign code
phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang
......
......@@ -228,7 +228,7 @@ deSugar hsc_env
mg_modBreaks = modBreaks,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports,
mg_complete_sigs = complete_matches,
mg_complete_matches = complete_matches,
mg_doc_hdr = doc_hdr,
mg_decl_docs = decl_docs,
mg_arg_docs = arg_docs
......
......@@ -88,7 +88,6 @@ import GHC.Driver.Ppr
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )
import GHC.Types.Literal ( mkLitString )
import GHC.Types.CostCentre.State
......@@ -210,13 +209,15 @@ mkDsEnvsFromTcGbl :: MonadIO m
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { cc_st_var <- liftIO $ newIORef newCostCentreState
; eps <- liftIO $ hscEPS hsc_env
; let dflags = hsc_dflags hsc_env
this_mod = tcg_mod tcg_env
type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
complete_matches = hptCompleteSigs hsc_env
++ tcg_complete_matches tcg_env
complete_matches = hptCompleteSigs hsc_env -- from the home package
++ tcg_complete_matches tcg_env -- from the current module
++ eps_complete_matches eps -- from imports
; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var cc_st_var complete_matches
}
......@@ -239,13 +240,15 @@ initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts hsc_env guts thing_inside
= do { cc_st_var <- newIORef newCostCentreState
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
; let dflags = hsc_dflags hsc_env
type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
rdr_env = mg_rdr_env guts
fam_inst_env = mg_fam_inst_env guts
this_mod = mg_module guts
complete_matches = hptCompleteSigs hsc_env
++ mg_complete_sigs guts
complete_matches = hptCompleteSigs hsc_env -- from the home package
++ mg_complete_matches guts -- from the current module
++ eps_complete_matches eps -- from imports
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
......@@ -281,7 +284,7 @@ initTcDsForSolver thing_inside
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
-> IORef Messages -> IORef CostCentreState -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
complete_matches
......@@ -290,7 +293,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
NotBoot
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
completeMatchMap = mkCompleteMatchMap complete_matches
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv)
......@@ -299,7 +301,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
(mkHomeUnitFromFlags dflags)
rdr_env
, ds_msgs = msg_var
, ds_complete_matches = completeMatchMap
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
......@@ -533,18 +535,9 @@ dsGetFamInstEnvs
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
eps <- getEps
env <- getGblEnv
-- We index into a UniqFM from Name -> elt, for tyCon it holds that
-- getUnique (tyConName tc) == getUnique tc. So we lookup using the
-- unique directly instead.
let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc)
eps_matches_list = lookup_completes $ eps_complete_matches eps
env_matches_list = lookup_completes $ ds_complete_matches env
return $ eps_matches_list ++ env_matches_list
-- | The @COMPLETE@ pragmas that are in scope.
dsGetCompleteMatches :: DsM CompleteMatches
dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
......
This diff is collapsed.
......@@ -24,8 +24,8 @@ module GHC.HsToCore.PmCheck.Types (
literalToPmLit, negatePmLit, overloadPmLit,
pmLitAsStringLit, coreExprAsPmLit,
-- * Caching partially matched COMPLETE sets
ConLikeSet, PossibleMatches(..),
-- * Caching residual COMPLETE sets
ConLikeSet, ResidualCompleteMatches(..), getRcm,
-- * PmAltConSet
PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,
......@@ -69,10 +69,10 @@ import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Tc.Utils.TcType (evVarPred)
import GHC.Driver.Types (ConLikeSet)
import Numeric (fromRat)
import Data.Foldable (find)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Ratio
import qualified Data.Semigroup as Semi
......@@ -415,21 +415,32 @@ instance Outputable PmAltCon where
instance Outputable PmEquality where
ppr = text . show
type ConLikeSet = UniqDSet ConLike
-- | A data type that caches for the 'VarInfo' of @x@ the results of querying
-- 'dsGetCompleteMatches' and then striking out all occurrences of @K@ for
-- which we already know @x /~ K@ from these sets.
--
-- For motivation, see Section 5.3 in Lower Your Guards.
-- See also Note [Implementation of COMPLETE pragmas]
data ResidualCompleteMatches
= RCM
{ rcm_vanilla :: !(Maybe ConLikeSet)
-- ^ The residual set for the vanilla COMPLETE set from the data defn.
-- Tracked separately from 'rcm_pragmas', because it might only be
-- known much later (when we have enough type information to see the 'TyCon'
-- of the match), or not at all even. Until that happens, it is 'Nothing'.
, rcm_pragmas :: !(Maybe [ConLikeSet])
-- ^ The residual sets for /all/ COMPLETE sets from pragmas that are
-- visible when compiling this module. Querying that set with
-- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing'
-- until first needed in a 'DsM' context.
}
-- | A data type caching the results of 'completeMatchConLikes' with support for
-- deletion of constructors that were already matched on.
data PossibleMatches
= PM (NonEmpty.NonEmpty ConLikeSet)
-- ^ Each ConLikeSet is a (subset of) the constructors in a COMPLETE set
-- 'NonEmpty' because the empty case would mean that the type has no COMPLETE
-- set at all, for which we have 'NoPM'.
| NoPM
-- ^ No COMPLETE set for this type (yet). Think of overloaded literals.
getRcm :: ResidualCompleteMatches -> [ConLikeSet]
getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas
instance Outputable PossibleMatches where
ppr (PM cs) = ppr (NonEmpty.toList cs)
ppr NoPM = text "<NoPM>"
instance Outputable ResidualCompleteMatches where
-- formats as "[{Nothing,Just},{P,Q}]"
ppr rcm = ppr (getRcm rcm)
-- | Either @Indirect x@, meaning the value is represented by that of @x@, or
-- an @Entry@ containing containing the actual value it represents.
......@@ -516,8 +527,8 @@ data TmState
-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,
-- and negative ('vi_neg') facts, like "x is not (:)".
-- Also caches the type ('vi_ty'), the 'PossibleMatches' of a COMPLETE set
-- ('vi_cache').
-- Also caches the type ('vi_ty'), the 'ResidualCompleteMatches' of a COMPLETE set
-- ('vi_rcm').
--
-- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.PmCheck.Oracle".
data VarInfo
......@@ -559,7 +570,7 @@ data VarInfo
-- * 'IsBot': @x ~ ⊥@
-- * 'IsNotBot': @x ≁ ⊥@
, vi_cache :: !PossibleMatches
, vi_rcm :: !ResidualCompleteMatches
-- ^ A cache of the associated COMPLETE sets. At any time a superset of
-- possible constructors of each COMPLETE set. So, if it's not in here, we
-- can't possibly match on it. Complementary to 'vi_neg'. We still need it
......
......@@ -38,7 +38,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.IfaceToCore
( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
, tcIfaceAnnotations, tcIfaceCompleteSigs )
, tcIfaceAnnotations, tcIfaceCompleteMatches )
import GHC.Driver.Session
import GHC.Driver.Backend
......@@ -479,7 +479,7 @@ loadInterface doc_str mod from
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
......@@ -509,9 +509,7 @@ loadInterface doc_str mod from
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
= extendCompleteMatchMap
(eps_complete_matches eps)
new_eps_complete_sigs,
= eps_complete_matches eps ++ new_eps_complete_matches,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
......@@ -1037,9 +1035,8 @@ initExternalPackageState home_unit
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules',
-- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_complete_matches = emptyUFM,
eps_mod_fam_inst_env = emptyModuleEnv,
eps_complete_matches = [],
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
......@@ -1181,7 +1178,7 @@ pprModIface iface@ModIface{ mi_final_exts = exts }
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
, vcat (map ppr (mi_complete_sigs iface))
, vcat (map ppr (mi_complete_matches iface))
, text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
, text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
, text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
......
......@@ -57,6 +57,7 @@ import GHC.Types.Avail
import GHC.Types.Name.Reader
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Unique.DSet
import GHC.Unit
import GHC.Utils.Error
import GHC.Utils.Outputable
......@@ -220,7 +221,7 @@ mkIface_ hsc_env
md_anns = anns,
md_types = type_env,
md_exports = exports,
md_complete_sigs = complete_sigs }
md_complete_matches = complete_matches }
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want
......@@ -256,7 +257,7 @@ mkIface_ hsc_env
iface_fam_insts = map famInstToIfaceFamInst fam_insts
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
icomplete_sigs = map mkIfaceCompleteSig complete_sigs
icomplete_matches = map mkIfaceCompleteMatch complete_matches
ModIface {
mi_module = this_mod,
......@@ -285,7 +286,7 @@ mkIface_ hsc_env
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
mi_complete_sigs = icomplete_sigs,
mi_complete_matches = icomplete_matches,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
......@@ -322,8 +323,9 @@ mkIface_ hsc_env
************************************************************************
-}
mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteMatch cls =
IfaceCompleteMatch (map conLikeName (uniqDSetToList cls))
{-
......
......@@ -324,11 +324,11 @@ data IfaceAnnotation
type IfaceAnnTarget = AnnTarget OccName
data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
newtype IfaceCompleteMatch = IfaceCompleteMatch [IfExtName]
instance Outputable IfaceCompleteMatch where
ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls
<+> dcolon <+> ppr ty
ppr (IfaceCompleteMatch cls) = text "COMPLETE" <> colon <+> ppr cls
......@@ -2481,8 +2481,8 @@ instance Binary IfaceTyConParent where
return $ IfDataInstance ax pr ty
instance Binary IfaceCompleteMatch where
put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
get bh = IfaceCompleteMatch <$> get bh <*> get bh
put_ bh (IfaceCompleteMatch cs) = put_ bh cs
get bh = IfaceCompleteMatch <$> get bh
{-
......@@ -2638,7 +2638,7 @@ instance NFData IfaceConAlt where
IfaceLitAlt lit -> lit `seq` ()
instance NFData IfaceCompleteMatch where
rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2
rnf (IfaceCompleteMatch f1) = rnf f1
instance NFData IfaceRule where
rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =
......
......@@ -143,7 +143,7 @@ mkBootModDetailsTc hsc_env
tcg_patsyns = pat_syns,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_complete_matches = complete_sigs,
tcg_complete_matches = complete_matches,
tcg_mod = this_mod
}
= -- This timing isn't terribly useful since the result isn't forced, but
......@@ -151,13 +151,13 @@ mkBootModDetailsTc hsc_env
Err.withTiming dflags
(text "CoreTidy"<+>brackets (ppr this_mod))
(const ()) $
return (ModDetails { md_types = type_env'
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
, md_anns = []
, md_exports = exports
, md_complete_sigs = complete_sigs
return (ModDetails { md_types = type_env'
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
, md_anns = []
, md_exports = exports
, md_complete_matches = complete_matches
})
where
dflags = hsc_dflags hsc_env
......@@ -346,22 +346,22 @@ three places this is actioned:
-}
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_exports = exports
, mg_rdr_env = rdr_env
, mg_tcs = tcs
, mg_insts = cls_insts
, mg_fam_insts = fam_insts
, mg_binds = binds
, mg_patsyns = patsyns
, mg_rules = imp_rules
, mg_anns = anns
, mg_complete_sigs = complete_sigs
, mg_deps = deps
, mg_foreign = foreign_stubs
, mg_foreign_files = foreign_files
, mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks
tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_exports = exports
, mg_rdr_env = rdr_env
, mg_tcs = tcs
, mg_insts = cls_insts
, mg_fam_insts = fam_insts
, mg_binds = binds
, mg_patsyns = patsyns
, mg_rules = imp_rules
, mg_anns = anns
, mg_complete_matches = complete_matches
, mg_deps = deps
, mg_foreign = foreign_stubs
, mg_foreign_files = foreign_files
, mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks
})
= Err.withTiming dflags
......@@ -467,13 +467,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
cg_modBreaks = modBreaks,
cg_spt_entries = spt_entries },
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_cls_insts,
md_fam_insts = fam_insts,
md_exports = exports,
md_anns = anns, -- are already tidy
md_complete_sigs = complete_sigs
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_cls_insts,
md_fam_insts = fam_insts,
md_exports = exports,
md_anns = anns, -- are already tidy
md_complete_matches = complete_matches
})
}
where
......
......@@ -17,7 +17,7 @@ module GHC.IfaceToCore (
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceAnnotations, tcIfaceCompleteMatches,
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
tcIfaceOneShot
......@@ -67,6 +67,7 @@ import GHC.Types.Name.Set
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Unit.Module
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet ( mkUniqDSet )
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Data.Maybe
......@@ -179,7 +180,7 @@ typecheckIface iface
; exports <- ifaceExportNames (mi_exports iface)
-- Complete Sigs
; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-- Finished
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
......@@ -193,7 +194,7 @@ typecheckIface iface
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
, md_complete_matches = complete_matches
}
}
......@@ -392,14 +393,14 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
, md_complete_matches = complete_matches
}
return (global_type_env, details)
......@@ -431,14 +432,14 @@ typecheckIfaceForInstantiate nsubst iface =
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
, md_complete_matches = complete_matches
}
-- Note [Resolving never-exported Names]
......@@ -1146,11 +1147,14 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
************************************************************************
-}
tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch
tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteMatch (IfaceCompleteMatch ms) =
mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms
where
doc = text "COMPLETE sig" <+> ppr ms