diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -53,7 +53,7 @@ -- * Loading\/compiling the program depanal, depanalE, - load, LoadHowMuch(..), InteractiveImport(..), + load, loadWithCache, LoadHowMuch(..), InteractiveImport(..), SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, @@ -63,6 +63,7 @@ TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, parsedSource, coreModule, + PkgQual(..), -- ** Compiling to Core CoreModule(..), @@ -116,6 +117,8 @@ -- ** Inspecting the current context getBindings, getInsts, getPrintUnqual, findModule, lookupModule, + findQualifiedModule, lookupQualifiedModule, + renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, getRdrNamesInScope, @@ -321,7 +324,6 @@ import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval -import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes @@ -338,6 +340,7 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -387,6 +390,8 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv +import GHC.Types.BreakInfo +import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Env @@ -1469,7 +1474,7 @@ -- | get the GlobalRdrEnv for a session getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +getGRE = withSession $ \hsc_env-> return $ icReaderEnv (hsc_IC hsc_env) -- | Retrieve all type and family instances in the environment, indexed -- by 'Name'. Each name's lists will contain every instance in which that name @@ -1631,37 +1636,49 @@ -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> do +findModule mod_name maybe_pkg = do + pkg_qual <- renamePkgQualM maybe_pkg + findQualifiedModule pkg_qual mod_name + + +findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module +findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do let fc = hsc_FC hsc_env let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - case maybe_pkg of - Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule fc fopts units home_unit mod_name maybe_pkg - case res of - Found _ m -> return m - err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err - _otherwise -> do + case pkgqual of + ThisPkg _ -> do home <- lookupLoadedHomeModule mod_name case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule fc fopts units home_unit mod_name maybe_pkg + res <- findImportedModule fc fopts units home_unit mod_name pkgqual case res of Found loc m | not (isHomeModule home_unit m) -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err - where + _ -> liftIO $ do + res <- findImportedModule fc fopts units home_unit mod_name pkgqual + case res of + Found _ m -> return m + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err + modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) +renamePkgQualM :: GhcMonad m => Maybe FastString -> m PkgQual +renamePkgQualM p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) p) + +renameRawPkgQualM :: GhcMonad m => RawPkgQual -> m PkgQual +renameRawPkgQualM p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) p) + -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'. In -- this case, 'findModule' will throw an error (module not loaded), @@ -1670,8 +1687,12 @@ -- returned. If not, the usual module-not-found error will be thrown. -- lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) -lookupModule mod_name Nothing = withSession $ \hsc_env -> do +lookupModule mod_name maybe_pkg = do + pkgqual <- renamePkgQualM maybe_pkg + lookupQualifiedModule pkgqual mod_name + +lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module +lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do home <- lookupLoadedHomeModule mod_name case home of Just m -> return m @@ -1680,10 +1701,11 @@ let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units mod_name Nothing + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -496,7 +496,7 @@ -- tag instructions with register liveness information -- also drops dead code. We don't keep the cfg in sync on -- some backends, so don't use it there. - let livenessCfg = if backendMaintainsCfg platform + let livenessCfg = if ncgEnableDeadCodeElimination config then Just nativeCfgWeights else Nothing let (withLiveness, usLive) = @@ -643,7 +643,7 @@ let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks getBlks _ = [] - when ( backendMaintainsCfg platform && + when ( ncgEnableDeadCodeElimination config && (ncgAsmLinting config || debugIsOn )) $ do let blocks = concatMap getBlks shorted let labels = setFromList $ fmap blockId blocks :: LabelSet diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -445,6 +445,11 @@ -- TODO handle CmmInt 0 specially, use wzr or xzr. + CmmInt i W8 | i >= 0 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) + CmmInt i W16 | i >= 0 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) + CmmInt i W8 -> do return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowS W8 i)))))) CmmInt i W16 -> do diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -600,7 +600,7 @@ = pprString' $ hcat $ map escapeChar $ if str `lengthIs` utf8EncodedLength str then str - else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str + else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str -- | Escape a single non-unicode character escapeChar :: Char -> SDoc diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -140,7 +140,6 @@ import Data.Maybe import Data.List (partition, nub) import Control.Monad -import Control.Applicative -- ----------------------------------------------------------------------------- -- Top level of the register allocator @@ -253,7 +252,7 @@ linearRegAlloc' config initFreeRegs entry_ids block_live sccs = do us <- getUniqueSupplyM let !(_, !stack, !stats, !blocks) = - runR config mapEmpty initFreeRegs emptyRegMap emptyStackMap us + runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us $ linearRA_SCCs entry_ids block_live [] sccs return (blocks, stats, getStackUse stack) @@ -323,7 +322,7 @@ go (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR - if isJust (mapLookup id block_assig) || id `elem` entry_ids + if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids then do b' <- processBlock block_live b go blocks next_round (b' : accum) True @@ -355,7 +354,7 @@ initBlock id block_live = do platform <- getPlatform block_assig <- getBlockAssigR - case mapLookup id block_assig of + case lookupBlockAssignment id block_assig of -- no prior info about this block: we must consider -- any fixed regs to be allocated, but we can ignore -- virtual regs (presumably this is part of a loop, @@ -852,19 +851,11 @@ -- variables are likely to end up in the same registers at the -- end and start of the loop, avoiding redundant reg-reg moves. -- Note: I tried returning a list of past assignments, but that --- turned out to barely matter but added a few tenths of --- a percent to compile time. +-- turned out to barely matter. findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg) findPrefRealReg vreg = do - bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc)) - return $ foldr (findVirtRegAssig) Nothing bassig - where - findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg - findVirtRegAssig assig z = - z <|> case lookupUFM (toVRegMap $ snd assig) vreg of - Just (InReg real_reg) -> Just real_reg - Just (InBoth real_reg _) -> Just real_reg - _ -> z + bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) + return $ lookupFirstUsed vreg bassig -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE RecordWildCards #-} -- | Put common type definitions here to break recursive module dependencies. module GHC.CmmToAsm.Reg.Linear.Base ( BlockAssignment, + lookupBlockAssignment, + lookupFirstUsed, + emptyBlockAssignment, + updateBlockAssignment, Loc(..), regsOfLoc, @@ -29,6 +34,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Collections +import GHC.CmmToAsm.Reg.Utils data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) @@ -37,8 +44,41 @@ -- target a particular label. We have to insert fixup code to make -- the register assignments from the different sources match up. -- -type BlockAssignment freeRegs - = BlockMap (freeRegs, RegMap Loc) +data BlockAssignment freeRegs + = BlockAssignment { blockMap :: !(BlockMap (freeRegs, RegMap Loc)) + , firstUsed :: !(UniqFM VirtualReg RealReg) } + +-- | Find the register mapping for a specific BlockId. +lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc) +lookupBlockAssignment bid ba = mapLookup bid (blockMap ba) + +-- | Lookup which register a virtual register was first assigned to. +lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg +lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr + +-- | An initial empty 'BlockAssignment' +emptyBlockAssignment :: BlockAssignment freeRegs +emptyBlockAssignment = BlockAssignment mapEmpty mempty + +-- | Add new register mappings for a specific block. +updateBlockAssignment :: BlockId + -> (freeRegs, RegMap Loc) + -> BlockAssignment freeRegs + -> BlockAssignment freeRegs +updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = + BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap) + (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap)) + where + -- The blocks are processed in dependency order, so if there's already an + -- entry in the map then keep that assignment rather than writing the new + -- assignment. + combWithExisting :: RealReg -> Loc -> Maybe RealReg + combWithExisting old_reg _ = Just $ old_reg + + fromLoc :: Loc -> Maybe RealReg + fromLoc (InReg rr) = Just rr + fromLoc (InBoth rr _) = Just rr + fromLoc _ = Nothing -- | Where a vreg is currently stored diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -100,7 +100,7 @@ , not (elemUniqSet_Directly reg live_set) , r <- regsOfLoc loc ] - case mapLookup dest block_assig of + case lookupBlockAssignment dest block_assig of Nothing -> joinToTargets_first block_live new_blocks block_id instr dest dests @@ -136,7 +136,7 @@ let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free -- remember the current assignment on entry to this block. - setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig) joinToTargets' block_live new_blocks block_id instr dests diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -21,18 +21,15 @@ import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Core.DataCon import GHC.Core.FamInstEnv -import GHC.Core.Multiplicity -import GHC.Core.Opt.WorkWrap.Utils -import GHC.Core.TyCon +import GHC.Core.DataCon import GHC.Core.Type -import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) +import GHC.Core.Utils import GHC.Core import GHC.Core.Seq +import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet -import GHC.Data.Maybe ( isJust ) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -193,12 +190,12 @@ cprAnalTopBind env (NonRec id rhs) = (env', NonRec id' rhs') where - (id', rhs', env') = cprAnalBind TopLevel env id rhs + (id', rhs', env') = cprAnalBind env id rhs cprAnalTopBind env (Rec pairs) = (env', Rec pairs') where - (env', pairs') = cprFix TopLevel env pairs + (env', pairs') = cprFix env pairs -- -- * Analysing expressions @@ -256,13 +253,13 @@ cprAnal' env (Let (NonRec id rhs) body) = (body_ty, Let (NonRec id' rhs') body') where - (id', rhs', env') = cprAnalBind NotTopLevel env id rhs + (id', rhs', env') = cprAnalBind env id rhs (body_ty, body') = cprAnal env' body cprAnal' env (Let (Rec pairs) body) = body_ty `seq` (body_ty, Let (Rec pairs') body') where - (env', pairs') = cprFix NotTopLevel env pairs + (env', pairs') = cprFix env pairs (body_ty, body') = cprAnal env' body cprAnalAlt @@ -395,11 +392,10 @@ -- -- Recursive bindings -cprFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding +cprFix :: AnalEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info -cprFix top_lvl orig_env orig_pairs +cprFix orig_env orig_pairs = loop 1 init_env init_pairs where init_sig id @@ -432,17 +428,16 @@ where go env (id, rhs) = (env', (id', rhs')) where - (id', rhs', env') = cprAnalBind top_lvl env id rhs + (id', rhs', env') = cprAnalBind env id rhs -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well. cprAnalBind - :: TopLevelFlag - -> AnalEnv + :: AnalEnv -> Id -> CoreExpr -> (Id, CoreExpr, AnalEnv) -cprAnalBind top_lvl env id rhs +cprAnalBind env id rhs | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs. = (id, rhs, extendSigEnv env id topCprSig) -- See Note [CPR for data structures] @@ -455,10 +450,8 @@ -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - -- See Note [CPR for sum types] - | returns_local_sum = trimCprTy rhs_ty - | otherwise = rhs_ty + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' id' = setIdCprSig id sig @@ -468,14 +461,6 @@ stays_thunk = is_thunk && not_strict is_thunk = not (exprIsHNF rhs) && not (isJoinId id) not_strict = not (isStrUsedDmd (idDemandInfo id)) - -- See Note [CPR for sum types] - (_, ret_ty) = splitPiTys (idType id) - returns_product - | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty - = isJust (tyConSingleAlgDataCon_maybe tc) - | otherwise - = False - returns_local_sum = not (isTopLevel top_lvl) && not returns_product isDataStructure :: Id -> Bool -- See Note [CPR for data structures] @@ -653,30 +638,23 @@ -- See Note [CPR for binders that will be unboxed]. extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv extendSigEnvForArg env id - = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id))) + = extendSigEnv env id (CprSig (argCprType (idDemandInfo id))) -- | Produces a 'CprType' according to how a strict argument will be unboxed. -- Examples: -- --- * A head-strict demand @1L@ on @Int@ would translate to @1@ --- * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@ --- * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@, --- because the unboxing strategy would not unbox the @a@. -argCprType :: AnalEnv -> Type -> Demand -> CprType -argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) +-- * A head-strict demand @1!L@ would translate to @1@ +-- * A product demand @1!P(1!L,L)@ would translate to @1(1,)@ +-- * A product demand @1!P(1L,L)@ would translate to @1(,)@, +-- because the first field will not be unboxed. +argCprType :: Demand -> CprType +argCprType dmd = CprType 0 (go dmd) where - go ty dmd - | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds - <- wantToUnboxArg (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd - -- No existentials; see Note [Which types are unboxed?]) - -- Otherwise we'd need to call dataConRepInstPat here and thread a - -- UniqSupply. So argCprType is a bit less aggressive than it could - -- be, for the sake of coding convenience. - , null (dataConExTyCoVars dc) - , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args) - = ConCpr (dataConTag dc) (zipWith go arg_tys ds) - | otherwise - = topCpr + go (n :* sd) + | isAbs n = topCpr + | Prod Unboxed ds <- sd = ConCpr fIRST_TAG (strictMap go ds) + | Poly Unboxed _ <- sd = ConCpr fIRST_TAG [] + | otherwise = topCpr {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -750,44 +728,6 @@ See Historic Note [Optimistic field binder CPR]. * See Note [CPR examples] - -Note [CPR for sum types] -~~~~~~~~~~~~~~~~~~~~~~~~ -Aug 21: This Note is out of date. It says that the subsequent WW split after -CPR for sum types destroys join points, but that is no longer correct; we have -the tools to track join points today and simply don't WW join points, -see Note [Don't w/w join points for CPR]. -Yet the issue persists. It is tracked in #5075 and the ultimate reason is a bit -unclear. All regressions involve CPR'ing functions returning lists, which are -recursive data structures. If we don't CPR them -(due to Note [CPR for recursive data constructors]), we might be able to finally -remove this hack, after doing the proper perf checks. - -Historic Note: - -At the moment we do not do CPR for let-bindings that - * non-top level - * bind a sum type -Reason: I found that in some benchmarks we were losing let-no-escapes, -which messed it all up. Example - let j = \x. .... - in case y of - True -> j False - False -> j True -If we w/w this we get - let j' = \x. .... - in case y of - True -> case j' False of { (# a #) -> Just a } - False -> case j' True of { (# a #) -> Just a } -Notice that j' is not a let-no-escape any more. - -However this means in turn that the *enclosing* function -may be CPR'd (via the returned Justs). But in the case of -sums, there may be Nothing alternatives; and that messes -up the sum-type CPR. - -Conclusion: only do this for products. It's still not -guaranteed OK for products, but sums definitely lose sometimes. Note [CPR for thunks] ~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -32,7 +32,8 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) -import GHC.Core.Coercion ( Coercion, coVarsOfCo ) +import GHC.Core.Coercion ( Coercion ) +import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc @@ -55,8 +56,9 @@ -} -- | Options for the demand analysis -newtype DmdAnalOpts = DmdAnalOpts - { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries +data DmdAnalOpts = DmdAnalOpts + { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries + , dmd_unbox_width :: !Int -- ^ Use strict dictionaries } -- This is a strict alternative to (,) @@ -276,8 +278,10 @@ where WithDmdType body_ty body' = anal_body env WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - !id' = setBindIdDemandInfo top_lvl id id_dmd - (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs + -- See Note [Finalising boxity for demand signature] in "GHC.Core.Opt.WorkWrap.Utils" + id_dmd' = finaliseBoxity (ae_fam_envs env) NotInsideInlineableFun (idType id) id_dmd + !id' = setBindIdDemandInfo top_lvl id id_dmd' + (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs -- See Note [Absence analysis for stable unfoldings and RULES] rule_fvs = bndrRuleAndUnfoldingIds id @@ -425,21 +429,24 @@ | is_single_data_alt alt = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs - WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs + WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! + -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is + -- what we want, because then `seq` will put a `seqDmd` on its scrut. (_ :* case_bndr_sd) = case_bndr_dmd -- Compute demand on the scrutinee -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv !(!bndrs', !scrut_sd) | DataAlt _ <- alt - , id_dmds <- addCaseBndrDmd case_bndr_sd dmds - -- See Note [Demand on scrutinee of a product case] - = let !new_info = setBndrsDemandInfo bndrs id_dmds - !new_prod = mkProd id_dmds - in (new_info, new_prod) + -- See Note [Demand on the scrutinee of a product case] + -- See Note [Demand on case-alternative binders] + , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds + , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' + = (bndrs', scrut_sd) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once. @@ -454,7 +461,6 @@ WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd @@ -482,8 +488,9 @@ WithDmdType rest_ty as' = combineAltDmds as in WithDmdType (lubDmdType cur_ty rest_ty) (a':as') - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr + WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives @@ -549,12 +556,30 @@ | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on scrutinee of a product case] - id_dmds = addCaseBndrDmd case_bndr_sd dmds + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs id_dmds + !new_ids = setBndrsDemandInfo bndrs dmds' = WithDmdType alt_ty (Alt con new_ids rhs') +-- Precondition: The SubDemand is not a Call +-- See Note [Demand on the scrutinee of a product case] +-- and Note [Demand on case-alternative binders] +addCaseBndrDmd :: SubDemand -- On the case binder + -> [Demand] -- On the fields of the constructor + -> (SubDemand, [Demand]) + -- SubDemand on the case binder incl. field demands + -- and final demands for the components of the constructor +addCaseBndrDmd case_sd fld_dmds + | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd + = (scrut_sd, ds) + | otherwise + = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition + where + scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds + {- Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -674,6 +699,51 @@ x = (a, absent-error) and that'll crash. +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis, forgetting (b): + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +Note that ds_dnz is syntactically dead, but the expression bound to it is +reachable through the case binder wild_X7. Now watch what happens if we inline +foo's wrapper: + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of _ [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> $wfoo_soq GHC.Types.True ds_dnz } + +Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second +run of demand analysis would no longer infer ds_dnz to be absent. +But unlike occurrence analysis, which infers properties of the *syntactic* +shape of the program, the results of demand analysis describe expressions +*semantically* and are supposed to be mostly stable across Simplification. +That's why we should better account for (b). +In #10148, we ended up emitting a single-entry thunk instead of an updateable +thunk for a let binder that was an an absent case-alt binder during DmdAnal. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates @@ -725,43 +795,42 @@ ************************************************************************ -} -dmdTransform :: AnalEnv -- ^ The strictness environment - -> Id -- ^ The function - -> SubDemand -- ^ The demand on the function - -> DmdType -- ^ The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables - +dmdTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The variable + -> SubDemand -- ^ The evaluation context of the var + -> DmdType -- ^ The demand type unleashed by the variable in this + -- context. The returned DmdEnv includes the demand on + -- this function plus demand on its free variables -- See Note [What are demand signatures?] in "GHC.Types.Demand" -dmdTransform env var dmd +dmdTransform env var sd -- Data constructors | isDataConWorkId var - = dmdTransformDataConSig (idArity var) dmd + = dmdTransformDataConSig (idArity var) sd -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. | Just _ <- isClassOpId_maybe var - = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $ - dmdTransformDictSelSig (idDmdSig var) dmd + = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $ + dmdTransformDictSelSig (idDmdSig var) sd -- Imported functions | isGlobalId var - , let res = dmdTransformSig (idDmdSig var) dmd - = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr dmd, ppr res]) + , let res = dmdTransformSig (idDmdSig var) sd + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res]) res -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). -- In that case, we have a strictness signature to unleash in our AnalEnv. | Just (sig, top_lvl) <- lookupSigEnv env var - , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + , let fn_ty = dmdTransformSig sig sd + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $ case top_lvl of - NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd) + NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd) TopLevel | isInterestingTopLevelFn var -- Top-level things will be used multiple times or not at -- all anyway, hence the multDmd below: It means we don't -- have to track whether @var@ is used strictly or at most -- once, because ultimately it never will. - -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness + -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness | otherwise -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later -- Everything else: @@ -769,8 +838,8 @@ -- * Lambda binders -- * Case and constructor field binders | otherwise - = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ - unitDmdType (unitVarEnv var (C_11 :* dmd)) + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ + unitDmdType (unitVarEnv var (C_11 :* sd)) {- ********************************************************************* * * @@ -802,15 +871,21 @@ where rhs_arity = idArity id -- See Note [Demand signatures are computed for a threshold demand based on idArity] - rhs_dmd -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_arity matches the join arity of the join point - | isJoinId id - = mkCalledOnceDmds rhs_arity let_dmd - | otherwise - = mkCalledOnceDmds rhs_arity topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs + rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd + + body_dmd + | isJoinId id + -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- rhs_arity matches the join arity of the join point + = let_dmd + | otherwise + -- See Note [Unboxed demand on function bodies returning small products] + = unboxedWhenSmall (ae_opts env) (unboxableResultWidth env id) topSubDmd + + -- See Note [Do not unbox class dictionaries] + WithDmdType rhs_dmd_ty rhs' = dmdAnal (adjustInlFun id env) rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) @@ -829,6 +904,7 @@ -- might turn into used-many even if the signature was stable and -- we'd have to do an additional iteration. reuseEnv makes sure that -- we never get used-once info for FVs of recursive functions. + -- See #14816 where we try to get rid of reuseEnv. rhs_fv1 = case rec_flag of Recursive -> reuseEnv rhs_fv NonRecursive -> rhs_fv @@ -839,6 +915,26 @@ -- See Note [Lazy and unleashable free variables] !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 +unboxableResultWidth :: AnalEnv -> Id -> Maybe Arity +unboxableResultWidth env id + | (pis,ret_ty) <- splitPiTys (idType id) + , count (not . isNamedBinder) pis == idArity id + , Just (tc, _tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty + , Just dc <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars dc) -- Can't unbox results with existentials + = Just (dataConRepArity dc) + | otherwise + = Nothing + +unboxedWhenSmall :: DmdAnalOpts -> Maybe Arity -> SubDemand -> SubDemand +-- See Note [Unboxed demand on function bodies returning small products] +unboxedWhenSmall opts mb_n sd + | Just n <- mb_n + , n <= dmd_unbox_width opts + = unboxSubDemand sd + | otherwise + = sd + -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body). @@ -1056,34 +1152,6 @@ (since it is apparently Absent) and then inline (\x. fst g) we get disaster. But regardless, #18638 was a more complicated version of this, that actually happened in practice. - -Historical Note [Product demands for function body] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 2013 I spotted this example, in shootout/binary_trees: - - Main.check' = \ b z ds. case z of z' { I# ip -> - case ds_d13s of - Main.Nil -> z' - Main.Node s14k s14l s14m -> - Main.check' (not b) - (Main.check' b - (case b { - False -> I# (-# s14h s14k); - True -> I# (+# s14h s14k) - }) - s14l) - s14m } } } - -Here we *really* want to unbox z, even though it appears to be used boxed in -the Nil case. Partly the Nil case is not a hot path. But more specifically, -the whole function gets the CPR property if we do. - -That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where -(solely because the result was a product) we used a product demand -(albeit with lazy components) for the body. But that gives very silly -behaviour -- see #17932. Happily it turns out now to be entirely -unnecessary: we get good results with C1(C1(C1(L))). So I simply -deleted the special case. -} {- ********************************************************************* @@ -1159,7 +1227,6 @@ {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Fixed-point iteration may fail to terminate. But we cannot simply give up and return the environment and code unchanged! We still need to do one additional round, for two reasons: @@ -1231,9 +1298,12 @@ unitDmdType dmd_env = DmdType dmd_env [] topDiv coercionDmdEnv :: Coercion -> DmdEnv -coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) - -- The VarSet from coVarsOfCo is really a VarEnv Var +coercionDmdEnv co = coercionsDmdEnv [co] +coercionsDmdEnv :: [Coercion] -> DmdEnv +coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos) + -- The VarSet from coVarsOfCos is really a VarEnv Var + addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res @@ -1283,18 +1353,6 @@ setBndrsDemandInfo [] ds = assert (null ds) [] setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) -annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var --- The returned env has the var deleted --- The returned var is annotated with demand info --- according to the result demand of the provided demand type --- No effect on the argument demands -annotateBndr env dmd_ty var - | isId var = WithDmdType dmd_ty' new_id - | otherwise = WithDmdType dmd_ty var - where - new_id = setIdDemandInfo var dmd - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty var - annotateLamIdBndr :: AnalEnv -> DmdType -- Demand type of body -> Id -- Lambda binder @@ -1308,8 +1366,11 @@ -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ WithDmdType main_ty new_id where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' + -- See Note [Finalising boxity for demand signature] in "GHC.Core.Opt.WorkWrap.Utils" + -- and Note [Do not unbox class dictionaries] + dmd' = finaliseBoxity (ae_fam_envs env) (ae_inl_fun env) (idType id) dmd + new_id = setIdDemandInfo id dmd' + main_ty = addDemand dmd' dmd_ty' WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id {- Note [NOINLINE and strictness] @@ -1389,11 +1450,14 @@ data AnalEnv = AE - { ae_strict_dicts :: !Bool -- ^ Enable strict dict - , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only - -- See Note [Initialising strictness] - , ae_fam_envs :: !FamInstEnvs + { ae_opts :: !DmdAnalOpts -- ^ Analysis options + , ae_sigs :: !SigEnv + , ae_virgin :: !Bool -- ^ True on first iteration only + -- See Note [Initialising strictness] + , ae_fam_envs :: !FamInstEnvs + , ae_inl_fun :: !InsideInlineableFun + -- ^ Whether we analyse the body of an inlineable fun. + -- See Note [Do not unbox class dictionaries]. } -- We use the se_env to tell us whether to @@ -1408,16 +1472,16 @@ instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env) , text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs - = AE { ae_strict_dicts = dmd_strict_dicts opts + = AE { ae_opts = opts , ae_sigs = emptySigEnv , ae_virgin = True , ae_fam_envs = fam_envs + , ae_inl_fun = NotInsideInlineableFun } emptySigEnv :: SigEnv @@ -1445,6 +1509,13 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } +-- | Sets 'ae_inl_fun' according to whether the given 'Id' has an inlineable +-- unfolding. See Note [Do not unbox class dictionaries]. +adjustInlFun :: Id -> AnalEnv -> AnalEnv +adjustInlFun id env + | isStableUnfolding (realIdUnfolding id) = env { ae_inl_fun = InsideInlineableFun } + | otherwise = env { ae_inl_fun = NotInsideInlineableFun } + findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs @@ -1472,9 +1543,9 @@ strictify dmd -- See Note [Making dictionaries strict] - | ae_strict_dicts env + | dmd_strict_dicts (ae_opts env) -- We never want to strictify a recursive let. At the moment - -- annotateBndr is only call for non-recursive lets; if that + -- findBndrDmd is never called for recursive lets; if that -- changes, we need a RecFlag parameter and another guard here. = strictifyDictDmd id_ty dmd | otherwise @@ -1522,7 +1593,7 @@ of a difference to stop a function from inlining. This is documented in #18421. -It's somewhat similar to Note [Do not unpack class dictionaries] although +It's somewhat similar to Note [Do not unbox class dictionaries] although here our problem is with the inliner, not the specializer. Note [Initialising strictness] diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -514,7 +514,7 @@ updateBindsM (liftIO . cprAnalProgram logger fam_envs) CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} - updateBinds (wwTopBinds dflags fam_envs us) + updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us) CoreDoSpecialising -> {-# SCC "Specialise" #-} specProgram guts @@ -1067,6 +1067,7 @@ dmdAnal logger dflags fam_envs rules binds = do let !opts = DmdAnalOpts { dmd_strict_dicts = gopt Opt_DictsStrict dflags + , dmd_unbox_width = dmdUnboxWidth dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -82,7 +82,6 @@ import GHC.Core.Utils ( exprType, exprIsHNF , exprOkForSpeculation , exprIsTopLevelBindable - , isExprLevPoly , collectMakeStaticArgs , mkLamTypes ) @@ -91,7 +90,9 @@ import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType - , mightBeUnliftedType, closeOverKindsDSet ) + , mightBeUnliftedType, closeOverKindsDSet + , typeHasFixedRuntimeRep + ) import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.DataCon ( dataConOrigResTy ) @@ -290,35 +291,35 @@ -> [LevelledBind] setLevels float_lams binds us - = initLvl us (do_them init_env binds) + = initLvl us (do_them binds) where - init_env = initialEnv float_lams + env = initialEnv float_lams binds - do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] - do_them _ [] = return [] - do_them env (b:bs) - = do { (lvld_bind, env') <- lvlTopBind env b - ; lvld_binds <- do_them env' bs + do_them :: [CoreBind] -> LvlM [LevelledBind] + do_them [] = return [] + do_them (b:bs) + = do { lvld_bind <- lvlTopBind env b + ; lvld_binds <- do_them bs ; return (lvld_bind : lvld_binds) } -lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) +lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind lvlTopBind env (NonRec bndr rhs) - = do { rhs' <- lvl_top env NonRecursive bndr rhs - ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] - ; return (NonRec bndr' rhs', env') } + = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs + ; return (NonRec bndr' rhs') } lvlTopBind env (Rec pairs) - = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL - (map fst pairs) - ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs - ; return (Rec (bndrs' `zip` rhss'), env') } + = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs + ; return (Rec prs') } -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr +lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr + -> LvlM (LevelledBndr, LevelledExpr) +-- NB: 'env' has all the top-level binders in scope, so +-- there is no need call substAndLvlBndrs here lvl_top env is_rec bndr rhs - = lvlRhs env is_rec - (isDeadEndId bndr) - Nothing -- Not a join point - (freeVars rhs) + = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr) + Nothing -- Not a join point + (freeVars rhs) + ; return (stayPut tOP_LEVEL bndr, rhs') } {- ************************************************************************ @@ -668,8 +669,9 @@ -- Only floating to the top level is allowed. || hasFreeJoin env fvs -- If there is a free join, don't float -- See Note [Free join points] - || isExprLevPoly expr - -- We can't let-bind representation-polymorphic expressions + || not (typeHasFixedRuntimeRep (exprType expr)) + -- We can't let-bind an expression if we don't know + -- how it will be represented at runtime. -- See Note [Representation polymorphism invariants] in GHC.Core || notWorthFloating expr abs_vars || not float_me @@ -1553,9 +1555,9 @@ {- Note [le_subst and le_env] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We clone let- and case-bound variables so that they are still distinct -when floated out; hence the le_subst/le_env. (see point 3 of the -module overview comment). We also use these envs when making a +We clone nested let- and case-bound variables so that they are still +distinct when floated out; hence the le_subst/le_env. (see point 3 of +the module overview comment). We also use these envs when making a variable polymorphic because we want to float it out past a big lambda. @@ -1582,14 +1584,21 @@ The domain of the le_lvl_env is the *post-cloned* Ids -} -initialEnv :: FloatOutSwitches -> LevelEnv -initialEnv float_lams - = LE { le_switches = float_lams - , le_ctxt_lvl = tOP_LEVEL +initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv +initialEnv float_lams binds + = LE { le_switches = float_lams + , le_ctxt_lvl = tOP_LEVEL , le_join_ceil = panic "initialEnv" - , le_lvl_env = emptyVarEnv - , le_subst = emptySubst - , le_env = emptyVarEnv } + , le_lvl_env = emptyVarEnv + , le_subst = mkEmptySubst in_scope_toplvl + , le_env = emptyVarEnv } + where + in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds + -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.Occuranal) and + -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise) + -- may both produce top-level bindings where an early binding refers + -- to a later one. So here we put all the top-level binders in scope before + -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294) addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -51,8 +51,7 @@ import GHC.Types.Id.Make ( seqId ) import GHC.Types.Id.Info import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) -import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd - , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv ) +import GHC.Types.Demand import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic @@ -435,9 +434,8 @@ ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs } -- NotTopLevel: simplNonRecX is only used for NotTopLevel things -- - -- isStrictId: use bndr' because in a representation-polymorphic - -- setting, the InId bndr might have a representation-polymorphic - -- type, which isStrictId doesn't expect + -- isStrictId: use bndr' because the InId bndr might not have + -- a fixed runtime representation, which isStrictId doesn't expect -- c.f. Note [Dark corner with representation polymorphism] -------------------------- @@ -950,12 +948,7 @@ info2 = info1 `setUnfoldingInfo` new_unf -- Demand info: Note [Setting the demand info] - -- We also have to nuke demand info if for some reason - -- eta-expansion *reduces* the arity of the binding to less - -- than that of the strictness sig. This can happen: see Note [Arity decrease]. info3 | isEvaldUnfolding new_unf - || (case dmdSigInfo info2 of - DmdSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) = zapDemandInfo info2 `orElse` info2 | otherwise = info2 @@ -974,31 +967,8 @@ info5 = zapCallArityInfo info4 -{- Note [Arity decrease] -~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking the arity of a binding should not decrease. But it *can* -legitimately happen because of RULES. Eg - f = g @Int -where g has arity 2, will have arity 2. But if there's a rewrite rule - g @Int --> h -where h has arity 1, then f's arity will decrease. Here's a real-life example, -which is in the output of Specialise: - - Rec { - $dm {Arity 2} = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm #-} - - dInt = MkD .... opInt ... - opInt {Arity 1} = $dm dInt - - $s$dm {Arity 0} = \x. op dInt } - -Here opInt has arity 1; but when we apply the rule its arity drops to 0. -That's why Specialise goes to a little trouble to pin the right arity -on specialised functions too. - -Note [Bottoming bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have let x = error "urk" in ...(case x of )... @@ -1572,7 +1542,7 @@ addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail }) | Just (m_co1, m_co2) <- pushCoValArg co - , levity_ok m_co1 + , fixed_rep m_co1 = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail ; case m_co1 of { @@ -1600,10 +1570,11 @@ -- See Note [Optimising reflexivity] | otherwise = return (CastIt co cont) - levity_ok :: MCoercionR -> Bool - levity_ok MRefl = True - levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co - -- Without this check, we get a lev-poly arg + fixed_rep :: MCoercionR -> Bool + fixed_rep MRefl = True + fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co + -- Without this check, we can get an argument which does not + -- have a fixed runtime representation. -- See Note [Representation polymorphism invariants] in GHC.Core -- test: typecheck/should_run/EtaExpandLevPoly @@ -1746,10 +1717,10 @@ ; return (floats1 `addFloats` floats2, expr') } {- Note [Dark corner with representation polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In `simplNonRecE`, the call to `isStrictId` will fail if the binder -has a representation-polymorphic type, of kind (TYPE r). So we are careful to -call `isStrictId` on the OutId, not the InId, in case we have +does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). +So we are careful to call `isStrictId` on the OutId, not the InId, in case we have ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell if x is lifted or unlifted from that. @@ -1765,7 +1736,7 @@ care here. Note [Avoiding exponential behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One way in which we can get exponential behaviour is if we simplify a big expression, and the re-simplify it -- and then this happens in a deeply-nested way. So we must be jolly careful about re-simplifying diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1806,7 +1806,7 @@ go_one env d (Var v) = extendVarEnv_C plusDmd env v d go_one env (_n :* cd) e -- NB: _n does not have to be strict | (Var _, args) <- collectArgs e - , Just ds <- viewProd (length args) cd + , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though... = go env ds args go_one env _ _ = env diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -13,13 +13,12 @@ import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core -import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.Type import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.FamInstEnv -import GHC.Core.SimpleOpt( SimpleOpts(..) ) +import GHC.Core.SimpleOpt import GHC.Types.Var import GHC.Types.Id @@ -37,6 +36,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Monad import GHC.Utils.Trace +import GHC.Unit.Types {- We take Core bindings whose binders have: @@ -66,14 +66,14 @@ \end{enumerate} -} -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram +wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds dflags fam_envs us top_binds +wwTopBinds this_mod dflags fam_envs us top_binds = initUs_ us $ do top_binds' <- mapM (wwBind ww_opts) top_binds return (concat top_binds') where - ww_opts = initWwOpts dflags fam_envs + ww_opts = initWwOpts this_mod dflags fam_envs {- ************************************************************************ @@ -390,9 +390,21 @@ in case z of A -> j 1 2 B -> j 2 3 -Note that we still want to give @j@ the CPR property, so that @f@ has it. So +Note that we still want to give `j` the CPR property, so that `f` has it. So CPR *analyse* join points as regular functions, but don't *transform* them. +We could retain the CPR /signature/ on the worker after W/W, but it would +become outright wrong if the Simplifier pushes a non-trivial continuation +into it. For example: + case (let $j x = (x,x) in ...) of alts + ==> + let $j x = case (x,x) of alts in case ... of alts +Before pushing the case in, `$j` has the CPR property, but not afterwards. + +So we simply zap the CPR signature for join pints as part of the W/W pass. +The signature served its purpose during CPR analysis in propagating the +CPR property of `$j`. + Doing W/W for returned products on a join point would be tricky anyway, as the worker could not be a join point because it would not be tail-called. However, doing the *argument* part of W/W still works for join points, since the wrapper @@ -529,7 +541,7 @@ = return [ (new_fn_id, rhs ) ] | is_fun && is_eta_exp - = splitFun ww_opts new_fn_id fn_info rhs + = splitFun ww_opts new_fn_id rhs -- See Note [Thunk splitting] | isNonRec is_rec, is_thunk @@ -541,11 +553,17 @@ where fn_info = idInfo fn_id (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info) + new_fn_id = zap_join_cpr $ zap_usage fn_id - new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) + zap_usage = zapIdUsedOnceInfo . zapIdUsageEnvInfo -- See Note [Zapping DmdEnv after Demand Analyzer] and -- See Note [Zapping Used Once info in WorkWrap] + zap_join_cpr id + | isJoinId id = id `setIdCprSig` topCprSig + | otherwise = id + -- See Note [Don't w/w join points for CPR] + -- is_eta_exp: see Note [Don't eta expand in w/w] is_eta_exp = length wrap_dmds == manifestArity rhs is_fun = notNull wrap_dmds || isJoinId fn_id @@ -690,17 +708,19 @@ --------------------- -splitFun :: WwOpts -> Id -> IdInfo -> CoreExpr -> UniqSM [(Id, CoreExpr)] -splitFun ww_opts fn_id fn_info rhs +splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] +splitFun ww_opts fn_id rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ - do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds use_cpr_info + do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr ; case mb_stuff of Nothing -> -- No useful wrapper; leave the binding alone return [(fn_id, rhs)] Just stuff - | Just stable_unf <- certainlyWillInline uf_opts fn_info + | let opt_wwd_rhs = simpleOptExpr (wo_simple_opts ww_opts) rhs + -- We need to stabilise the WW'd (and optimised) RHS below + , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs -- We could make a w/w split, but in fact the RHS is small -- See Note [Don't w/w inline small non-loop-breaker things] , let id_w_unf = fn_id `setIdUnfolding` stable_unf @@ -710,12 +730,11 @@ | otherwise -> do { work_uniq <- getUniqueM ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body - work_uniq div cpr stuff) } } + work_uniq div stuff) } } where uf_opts = so_uf_opts (wo_simple_opts ww_opts) + fn_info = idInfo fn_id (arg_vars, body) = collectBinders rhs - -- collectBinders was not enough for GHC.Event.IntTable.insertWith - -- last time I checked, where manifest lambdas were wrapped in casts (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) @@ -727,17 +746,11 @@ <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $ ct_cpr cpr_ty - -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, - -- see Note [Don't w/w join points for CPR]. - use_cpr_info | isJoinId fn_id = topCpr - | otherwise = cpr - - mkWWBindPair :: WwOpts -> Id -> IdInfo - -> [Var] -> CoreExpr -> Unique -> Divergence -> Cpr + -> [Var] -> CoreExpr -> Unique -> Divergence -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)] -mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div cpr +mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div (work_demands, join_arity, wrap_fn, work_fn) = [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it @@ -783,7 +796,7 @@ -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv - `setIdCprSig` mkCprSig work_arity work_cpr_info + `setIdCprSig` topCprSig `setIdDemandInfo` worker_demand @@ -814,13 +827,6 @@ fn_inline_spec = inl_inline fn_inl_prag fn_unfolding = realUnfoldingInfo fn_info - -- Even if we don't w/w join points for CPR, we might still do so for - -- strictness. In which case a join point worker keeps its original CPR - -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker - -- doesn't have the CPR property anymore. - work_cpr_info | isJoinId fn_id = cpr - | otherwise = topCpr - mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) = InlinePragma { inl_src = SourceText "{-# INLINE" @@ -971,8 +977,7 @@ splitThunk ww_opts is_rec x rhs = assert (not (isJoinId x)) $ do { let x' = localiseId x -- See comment above - ; (useful,_, wrap_fn, fn_arg) - <- mkWWstr_one ww_opts NotArgOfInlineableFun x' + ; (useful,_, wrap_fn, fn_arg) <- mkWWstr_one ww_opts x' ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ] ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive return res diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -10,8 +10,9 @@ module GHC.Core.Opt.WorkWrap.Utils ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs , DataConPatContext(..) - , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg - , findTypeShape, mkAbsentFiller, IsRecDataConResult(..), isRecDataCon + , UnboxingDecision(..), InsideInlineableFun(..), wantToUnboxArg + , findTypeShape, IsRecDataConResult(..), isRecDataCon, finaliseBoxity + , mkAbsentFiller , isWorkerSmallEnough ) where @@ -64,6 +65,7 @@ import Data.List ( unzip4 ) import GHC.Types.RepType +import GHC.Unit.Types {- ************************************************************************ @@ -141,17 +143,18 @@ , wo_cpr_anal :: !Bool , wo_fun_to_thunk :: !Bool , wo_max_worker_args :: !Int - , wo_output_file :: Maybe String + -- Used for absent argument error message + , wo_module :: !Module } -initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts -initWwOpts dflags fam_envs = MkWwOpts +initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts +initWwOpts this_mod dflags fam_envs = MkWwOpts { wo_fam_envs = fam_envs , wo_simple_opts = initSimpleOpts dflags , wo_cpr_anal = gopt Opt_CprAnal dflags , wo_fun_to_thunk = gopt Opt_FunToThunk dflags , wo_max_worker_args = maxWorkerArgs dflags - , wo_output_file = outputFile dflags + , wo_module = this_mod } type WwResult @@ -227,7 +230,7 @@ res_ty' = GHC.Core.Subst.substTy subst res_ty ; (useful1, work_args, wrap_fn_str, fn_args) - <- mkWWstr opts inlineable_flag cloned_arg_vars + <- mkWWstr opts cloned_arg_vars -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) @@ -263,9 +266,6 @@ = info `setOccInfo` noOccInfo mb_join_arity = isJoinId_maybe fun_id - inlineable_flag -- See Note [Do not unpack class dictionaries] - | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun - | otherwise = NotArgOfInlineableFun -- Note [Do not split void functions] only_one_void_argument @@ -560,60 +560,31 @@ -- The @[s]@ carries the bits of information with which we can continue -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'. --- | A specialised Bool for an argument to 'wantToUnboxArg'. --- See Note [Do not unpack class dictionaries]. -data ArgOfInlineableFun - = NotArgOfInlineableFun -- ^ Definitely not in an inlineable fun. - | MaybeArgOfInlineableFun -- ^ We might be in an inlineable fun, so we won't - -- unbox dictionary args. - deriving Eq - --- | Unboxing strategy for strict arguments. -wantToUnboxArg :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand +-- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns +-- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' +-- to unbox. +wantToUnboxArg + :: FamInstEnvs + -> Type -- ^ Type of the argument + -> Demand -- ^ How the arg was used + -> UnboxingDecision Demand -- See Note [Which types are unboxed?] -wantToUnboxArg fam_envs inlineable_flag ty dmd - | isAbsDmd dmd +wantToUnboxArg fam_envs ty (n :* sd) + | isAbs n = DropAbsent - | isStrUsedDmd dmd - , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty + | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dc <- tyConSingleAlgDataCon_maybe tc , let arity = dataConRepArity dc - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd arity - -- See Note [Do not unpack class dictionaries] - , inlineable_flag == NotArgOfInlineableFun || not (isClassPred ty) - -- See Note [mkWWstr and unsafeCoerce] - , cs `lengthIs` arity - -- See Note [Add demands for strict constructors] - , let cs' = addDataConStrictness dc cs - = Unbox (DataConPatContext dc tc_args co) cs' + , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity Analysis] + -- NB: No strictness or evaluatedness checks here. That is done by + -- 'finaliseBoxity'! + = Unbox (DataConPatContext dc tc_args co) ds | otherwise = StopUnboxing - where - split_prod_dmd_arity dmd arity - -- For seqDmd, it should behave like , for some - -- suitable arity - | isSeqDmd dmd = Just (replicate arity absDmd) - | _ :* Prod ds <- dmd = Just ds - | otherwise = Nothing -addDataConStrictness :: DataCon -> [Demand] -> [Demand] --- See Note [Add demands for strict constructors] -addDataConStrictness con ds - | Nothing <- dataConWrapId_maybe con - -- DataCon worker=wrapper. Implies no strict fields, so nothing to do - = ds -addDataConStrictness con ds - = zipWithEqual "addDataConStrictness" add ds strs - where - strs = dataConRepStrictness con - add dmd str | isMarkedStrict str = strictifyDmd dmd - | otherwise = dmd - - -- | Unboxing strategy for constructed results. wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr -- See Note [Which types are unboxed?] @@ -686,35 +657,8 @@ constraints, type classes etc. So it can be GADT. These evidence arguments are simply value arguments, and should not get in the way. -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The argument is unpacked in a case if it has a product type and has a -strict *and* used demand put on it. I.e., arguments, with demands such -as the following ones: - - - - -will be unpacked, but - - or - -will not, because the pieces aren't used. This is quite important otherwise -we end up unpacking massive tuples passed to the bottoming function. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - -Does 'main' print "error 1" or "error no"? We don't really want 'f' -to unbox its second argument. This actually happened in GHC's onwn -source code, in Packages.applyPackageFlag, which ended up un-boxing -the enormous DynFlags tuple, and being strict in the -as-yet-un-filled-in unitState files. - -Note [Do not unpack class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Do not unbox class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have f :: Ord a => [a] -> Int -> a {-# INLINABLE f #-} @@ -727,12 +671,19 @@ fw :: (a->a->Bool) -> [a] -> Int# -> a and the type-class specialiser can't specialise that. An example is #6056. -But in any other situation a dictionary is just an ordinary value, -and can be unpacked. So we track the INLINABLE pragma, and switch -off the unpacking in mkWWstr_one (see the isClassPred test). +But in any other situation, a dictionary is just an ordinary value, +and can be unpacked. So we track the INLINABLE pragma, and discard the boxity +flag in finaliseBoxity (see the isClassPred test). Historical note: #14955 describes how I got this fix wrong the first time. +Note that the simplicity of this fix implies that INLINE functions (such as +wrapper functions after the WW run) will never say that they unbox class +dictionaries. That's not ideal, but not worth losing sleep over, as INLINE +functions will have been inlined by the time we run demand analysis so we'll +see the unboxing around the worker in client modules. I got aware of the issue +in T5075 by the change in boxity of loop between demand analysis runs. + Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ By using unsafeCoerce, it is possible to make the number of demands fail to @@ -740,14 +691,14 @@ If so, the worker/wrapper split doesn't work right and we get a Core Lint bug. The fix here is simply to decline to do w/w if that happens. -Note [Add demands for strict constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Unboxing evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this program (due to Roman): data X a = X !a foo :: X Int -> Int -> Int - foo (X a) n = go 0 + foo x@(X a) n = go 0 where go i | i < n = a + go (i+1) | otherwise = 0 @@ -756,12 +707,12 @@ $wfoo :: Int# -> Int# -> Int# -with the first argument unboxed, so that it is not eval'd each time -around the 'go' loop (which would otherwise happen, since 'foo' is not -strict in 'a'). It is sound for the wrapper to pass an unboxed arg -because X is strict, so its argument must be evaluated. And if we -*don't* pass an unboxed argument, we can't even repair it by adding a -`seq` thus: +with the first argument unboxed, so that it is not eval'd each time around the +'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It +is sound for the wrapper to pass an unboxed arg because X is strict +(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument +must be evaluated. And if we *don't* pass an unboxed argument, we can't even +repair it by adding a `seq` thus: foo (X a) n = a `seq` go 0 @@ -769,34 +720,38 @@ So here's what we do -* We leave the demand-analysis alone. The demand on 'a' in the - definition of 'foo' is ; the strictness info is Lazy - because foo's body may or may not evaluate 'a'; but the usage info - says that 'a' is unpacked and its content is used. +* Since this has nothing to do with how 'foo' uses 'a', we leave demand analysis + alone, but account for the additional evaluatedness when annotating the binder + in 'annotateLamIdBndr' via 'finaliseBoxity', which will retain the Unboxed boxity + on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning it's used + lazily but unboxed nonetheless. This seems to contradict + Note [No lazy, Unboxed demands in demand signature], but we know that 'a' is + evaluated and thus can be unboxed. -* During worker/wrapper, if we unpack a strict constructor (as we do - for 'foo'), we use 'addDataConStrictness' to bump up the strictness on - the strict arguments of the data constructor. +* When 'finaliseBoxity' decides to unbox a record, it will zip the field demands + together with the respective 'StrictnessMark'. In case of 'x', it will pair + up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for + the strict field. -* That in turn means that, if the usage info supports doing so - (i.e. splitProdDmd_maybe returns Just), we will unpack that argument - -- even though the original demand (e.g. on 'a') was lazy. +* Said 'StrictnessMark' is passed to the recursive invocation of + 'finaliseBoxity' when deciding whether to unbox 'a'. 'a' was used lazily, but + since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. -* What does "bump up the strictness" mean? Just add a head-strict - demand to the strictness! Even for a demand like we can - safely turn it into ; remember case (1) of - Note [Worker/wrapper for Strictness and Absence]. +* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will + /not/ look at the strictness bits of the demand, only at Boxity flags. As such, + it will happily unbox 'a' despite the lazy demand on it. -The net effect is that the w/w transformation is more aggressive about -unpacking the strict arguments of a data constructor, when that -eagerness is supported by the usage info. +The net effect is that boxity analysis and the w/w transformation are more +aggressive about unboxing the strict arguments of a data constructor than when +looking at strictness info exclusively. It is very much like (Nested) CPR, which +needs its nested fields to be evaluated in order for it to unbox nestedly. There is the usual danger of reboxing, which as usual we ignore. But if X is monomorphic, and has an UNPACK pragma, then this optimisation is even more important. We don't want the wrapper to rebox an unboxed argument, and pass an Int to $wfoo! -This works in nested situations like +This works in nested situations like T10482 data family Bar a data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) @@ -861,6 +816,68 @@ that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. +Note [No nested Unboxed inside Boxed in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider +``` +f p@(x,y) + | even (x+y) = [] + | otherwise = [p] +``` +Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)` +on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper +can't unbox the pair components without unboxing the pair! So we better say +`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info. +That happens in 'finaliseBoxity'. + +Note [No lazy, Unboxed demands in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T19407: + + data Huge = Huge Bool () ... () -- think: DynFlags + data T = T { h :: Huge, n :: Int } + f t@(T h _) = g h t + g (H b _ ... _) t = if b then 1 else n t + +The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better +not put that demand in `g`'s demand signature, because worker/wrapper will not +in general unbox a lazy-and-unboxed demand like `L!P(..)`. +(The exception are known-to-be-evaluated arguments like strict fields, +see Note [Unboxing evaluated arguments].) + +The program above is an example where spreading misinformed boxity through the +signature is particularly egregious. If we give `g` that signature, then `f` +puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and +we get + + f (T (H b _ ... _) n) = $wf b n + $wf b n = $wg b (T (H b x ... x) n) + $wg = ... + +Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in +'finaliseBoxity', modulo Note [Unboxing evaluated arguments]. + +Note [Finalising boxity for demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker/wrapper pass must strictly adhere to the boxity decisions encoded +in the demand signature, because that is the information that demand analysis +propagates throughout the program. Failing to implement the strategy laid out +in the signature can result in reboxing in unexpected places. Hence, we must +completely anticipate unboxing decisions during demand analysis and reflect +these decicions in demand annotations. That is the job of 'finaliseBoxity', +which is defined here and called from demand analysis. + +Here is a list of different Notes it has to take care of: + + * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in + general, but still allow Note [Unboxing evaluated arguments] + * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` + * Implement fixes for corner cases Note [Do not unbox class dictionaries] + and Note [mkWWstr and unsafeCoerce] + +Then, in worker/wrapper blindly trusts the boxity info in the demand signature +and will not look at strictness info *at all*, in 'wantToUnboxArg'. + Note [non-algebraic or open body type warning] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a few cases where the W/W transformation is told that something @@ -892,7 +909,6 @@ -} mkWWstr :: WwOpts - -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* -> UniqSM (Bool, -- Is this useful @@ -903,10 +919,10 @@ [CoreExpr]) -- Reboxed args for the call to the -- original RHS. Corresponds one-to-one -- with the wrapper arg vars -mkWWstr opts inlineable_flag args +mkWWstr opts args = go args where - go_one arg = mkWWstr_one opts inlineable_flag arg + go_one arg = mkWWstr_one opts arg go [] = return (False, [], nop_fn, []) go (arg : args) = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg @@ -923,12 +939,9 @@ -- * wrap_arg assumes work_args are in scope, and builds a ConApp that -- reconstructs the RHS of wrap_var that we pass to the original RHS -- See Note [Worker/wrapper for Strictness and Absence] -mkWWstr_one :: WwOpts - -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] - -> Var - -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr) -mkWWstr_one opts inlineable_flag arg = - case wantToUnboxArg fam_envs inlineable_flag arg_ty arg_dmd of +mkWWstr_one :: WwOpts -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr) +mkWWstr_one opts arg = + case wantToUnboxArg fam_envs arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent @@ -938,7 +951,7 @@ -- (that's what mkAbsentFiller does) -> return (True, [], nop_fn, absent_filler) - Unbox dcpc cs -> unbox_one_arg opts arg cs dcpc + Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc _ -> do_nothing -- Other cases, like StopUnboxing @@ -953,17 +966,17 @@ -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr) -unbox_one_arg opts arg_var cs +unbox_one_arg opts arg_var ds DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args - arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs + arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids') - ; (_, worker_args, wrap_fn, wrap_args) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids') + ; (_, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co ; return (True, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- Don't pass the arg, rebox instead @@ -1003,48 +1016,49 @@ -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - file_msg = case wo_output_file opts of - Nothing -> empty - Just f -> text "In output file " <+> quotes (text f) + file_msg = text "In module" <+> quotes (ppr $ wo_module opts) {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The worker/wrapper transformation, mkWWstr_one, takes into account -several possibilities to decide if the function is worthy for -splitting: +The worker/wrapper transformation, mkWWstr_one, takes concrete action +based on the 'UnboxingDescision' returned by 'wantToUnboxArg'. +The latter takes into account several possibilities to decide if the +function is worthy for splitting: 1. If an argument is absent, it would be silly to pass it to - the worker. Hence the isAbsDmd case. This case must come - first because a demand like or is possible. - E.g. comes from a function like + the worker. Hence the DropAbsent case. This case must come + first because the bottom demand B is also strict. + E.g. B comes from a function like f x = error "urk" - and can come from Note [Add demands for strict constructors] + and the absent demand A can come from Note [Unboxing evaluated arguments] -2. If the argument is evaluated strictly, and we can split the - product demand (splitProdDmd_maybe), then unbox it and w/w its - pieces. For example +2. If the argument is evaluated strictly (or known to be eval'd), + we can take a view into the product demand ('viewProd'). In accordance + with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'. + 'mkWWstr_one' then follows suit it and recurses into the fields of the + product demand. For example - f :: (Int, Int) -> Int - f p = (case p of (a,b) -> a) + 1 - is split to - f :: (Int, Int) -> Int - f p = case p of (a,b) -> $wf a + f :: (Int, Int) -> Int + f p = (case p of (a,b) -> a) + 1 + is split to + f :: (Int, Int) -> Int + f p = case p of (a,b) -> $wf a - $wf :: Int -> Int - $wf a = a + 1 + $wf :: Int -> Int + $wf a = a + 1 - and - g :: Bool -> (Int, Int) -> Int - g c p = case p of (a,b) -> - if c then a else b - is split to - g c p = case p of (a,b) -> $gw c a b - $gw c a b = if c then a else b + and + g :: Bool -> (Int, Int) -> Int + g c p = case p of (a,b) -> + if c then a else b + is split to + g c p = case p of (a,b) -> $gw c a b + $gw c a b = if c then a else b -2a But do /not/ split if the components are not used; that is, the - usage is just 'Used' rather than 'UProd'. In this case - splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing - a massive tuple which is barely used. Example: +2a But do /not/ split if Boxity Analysis said "Boxed". + In this case, 'wantToUnboxArg' returns 'StopUnboxing'. + Otherwise we risk decomposing and reboxing a massive + tuple which is barely used. Example: f :: ((Int,Int) -> String) -> (Int,Int) -> a f g pr = error (g pr) @@ -1055,10 +1069,11 @@ Imagine that it had millions of fields. This actually happened in GHC itself where the tuple was DynFlags -3. A plain 'seqDmd', which is head-strict with usage UHead, can't - be split by splitProdDmd_maybe. But we want it to behave just - like U(AAAA) for suitable number of absent demands. So we have - a special case for it, with arity coming from the data constructor. +3. In all other cases (e.g., lazy, used demand and not eval'd), + 'finaliseBoxity' will have cleared the Boxity flag to 'Boxed' + (see Note [Finalising boxity for demand signature]) and + 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one' + stops unboxing. Note [Worker/wrapper for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1162,7 +1177,7 @@ Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'. So we rather look out for a necessary condition for strict fields: - Note [Add demands for strict constructors] makes it so that the demand on + Note [Unboxing evaluated arguments] makes it so that the demand on 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees we never fill in an error-thunk for an absent strict field. @@ -1333,6 +1348,8 @@ go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult go_arg_ty fuel rec_tc ty + --- | pprTrace "arg_ty" (ppr ty) False = undefined + | Just (_, _arg_ty, _res_ty) <- splitFunTy_maybe ty -- = go_arg_ty fuel rec_tc _arg_ty <||> go_arg_ty fuel rec_tc _res_ty -- Plausible, but unnecessary for CPR. @@ -1382,7 +1399,7 @@ -- we expanded this TyCon once already, no need to test it multiple times Just rec_tc' - | Just (_tvs, rhs, _co) <- unwrapNewTyConEtad_maybe tc + | Just (_tvs, rhs, _co) <- unwrapNewTyCon_maybe tc -- See Note [Detecting recursive data constructors], points (2) and (3) -> go_arg_ty fuel rec_tc' rhs @@ -1392,6 +1409,56 @@ | let dcs = expectJust "isRecDataCon:go_tc_app" $ tyConDataCons_maybe tc -> combineIRDCRs (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs) -- See Note [Detecting recursive data constructors], point (4) + +-- | A specialised Bool for an argument to 'finaliseBoxity'. +-- See Note [Do not unbox class dictionaries]. +data InsideInlineableFun + = NotInsideInlineableFun -- ^ Not in an inlineable fun. + | InsideInlineableFun -- ^ We are in an inlineable fun, so we won't + -- unbox dictionary args. + deriving Eq + +-- | This function makes sure that the demand only says 'Unboxed' where +-- worker/wrapper should actually unbox and trims any boxity beyond that. +-- Called for every demand annotation during DmdAnal. +-- +-- > data T a = T !a +-- > f :: (T (Int,Int), Int) -> () +-- > f p = ... -- demand on p: 1!P(L!P(L!P(L), L!P(L)), L!P(L)) +-- +-- 'finaliseBoxity' will trim the demand on 'p' to 1!P(L!P(LP(L), LP(L)), LP(L)). +-- This is done when annotating lambdas and thunk bindings. +-- See Note [Finalising boxity for demand signature] +finaliseBoxity + :: FamInstEnvs + -> InsideInlineableFun -- ^ See the haddocks on 'InsideInlineableFun' + -> Type -- ^ Type of the argument + -> Demand -- ^ How the arg was used + -> Demand +finaliseBoxity env in_inl_fun ty dmd = go NotMarkedStrict ty dmd + where + go mark ty dmd@(n :* _) = + case wantToUnboxArg env ty dmd of + DropAbsent -> dmd + Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} ds + -- See Note [No lazy, Unboxed demands in demand signature] + -- See Note [Unboxing evaluated arguments] + | isStrict n || isMarkedStrict mark + -- See Note [Do not unbox class dictionaries] + , in_inl_fun == NotInsideInlineableFun || not (isClassPred ty) + -- See Note [mkWWstr and unsafeCoerce] + , ds `lengthIs` dataConRepArity dc + , let arg_tys = dubiousDataConInstArgTys dc tc_args + -> -- pprTrace "finaliseBoxity:Unbox" (ppr ty $$ ppr dmd $$ ppr ds) $ + n :* (mkProd Unboxed $! zip_go_with_marks dc arg_tys ds) + -- See Note [No nested Unboxed inside Boxed in demand signature] + _ -> trimBoxity dmd + + -- See Note [Unboxing evaluated arguments] + zip_go_with_marks dc arg_tys ds = case dataConWrapId_maybe dc of + Nothing -> strictZipWith (go NotMarkedStrict) arg_tys ds + -- Shortcut when DataCon worker=wrapper + Just _ -> strictZipWith3 go (dataConRepStrictness dc) arg_tys ds {- ************************************************************************ diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | This is the driver for the 'ghc --backpack' mode, which @@ -38,6 +39,8 @@ import GHC.Parser.Lexer import GHC.Parser.Annotation +import GHC.Rename.Names + import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad import GHC.Iface.Recomp @@ -45,7 +48,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceError -import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.Unique.FM import GHC.Types.Unique.DFM @@ -91,8 +93,6 @@ -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () doBackpack [src_filename] = do - logger <- getLogger - -- Apply options from file to dflags dflags0 <- getDynFlags let dflags1 = dflags0 @@ -100,6 +100,9 @@ src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts modifySession (hscSetFlags dflags) + logger <- getLogger -- Get the logger after having set the session flags, + -- so that logger options are correctly set. + -- Not doing so caused #20396. -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns @@ -121,14 +124,14 @@ innerBkpM $ do let (cid, insts) = computeUnitId lunit if null insts - then if cid == Indefinite (UnitId (fsLit "main")) + then if cid == UnitId (fsLit "main") then compileExe lunit else compileUnit cid [] else typecheckUnit cid insts doBackpack _ = throwGhcException (CmdLineError "--backpack can only process a single file") -computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)]) +computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)]) computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) where cid = hsComponentId (unLoc (hsunitName unit)) @@ -154,7 +157,7 @@ -- | Create a temporary Session to do some sort of type checking or -- compilation. -withBkpSession :: IndefUnitId +withBkpSession :: UnitId -> [(ModuleName, Module)] -> [(Unit, ModRenaming)] -> SessionType -- what kind of session are we doing @@ -162,7 +165,7 @@ -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags - let cid_fs = unitFS (indefUnit cid) + let cid_fs = unitFS cid is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) cid_str = unpackFS cid_fs @@ -192,7 +195,7 @@ -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no -- sense (we're not instantiating anything) - , homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid) + , homeUnitInstanceOf_ = if null insts then Nothing else Just cid , homeUnitId_ = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances @@ -244,21 +247,21 @@ withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = - withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this + withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this -getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) +getSource :: UnitId -> BkpM (LHsUnit HsComponentId) getSource cid = do bkp_env <- getBkpEnv case Map.lookup cid (bkp_table bkp_env) of Nothing -> pprPanic "missing needed dependency" (ppr cid) Just lunit -> return lunit -typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () typecheckUnit cid insts = do lunit <- getSource cid buildUnit TcSession cid insts lunit -compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () +compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () compileUnit cid insts = do -- Let everyone know we're building this unit msgUnitId (mkVirtUnit cid insts) @@ -286,7 +289,7 @@ convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) get_dep _ = [] -buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () buildUnit session cid insts lunit = do -- NB: include signature dependencies ONLY when typechecking. -- If we're compiling, it's not necessary to recursively @@ -322,7 +325,7 @@ mod_graph <- hsunitModuleGraph (unLoc lunit) msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph + (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags @@ -341,7 +344,7 @@ obj_files = concatMap getOfiles linkables state = hsc_units hsc_env - let compat_fs = unitIdFS (indefUnit cid) + let compat_fs = unitIdFS cid compat_pn = PackageName compat_fs unit_id = homeUnitId (hsc_home_unit hsc_env) @@ -411,7 +414,7 @@ withBkpExeSession deps_w_rns $ do mod_graph <- hsunitModuleGraph (unLoc lunit) msg <- mkBackpackMsg - ok <- load' LoadAllTargets (Just msg) mod_graph + (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -- | Register a new virtual unit database containing a single unit @@ -474,7 +477,7 @@ -- | The filename of the bkp file we're compiling bkp_filename :: FilePath, -- | Table of source units which we know how to compile - bkp_table :: Map IndefUnitId (LHsUnit HsComponentId), + bkp_table :: Map UnitId (LHsUnit HsComponentId), -- | When a package we are compiling includes another package -- which has not been compiled, we bump the level and compile -- that. @@ -630,7 +633,7 @@ -- to use this for anything unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (Indefinite (UnitId fs))) + = (pn, HsComponentId pn (UnitId fs)) bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId bkpPackageNameMap units = listToUFM (map unitDefines units) @@ -756,8 +759,8 @@ let fopts = initFinderOpts dflags let PackageName pn_fs = pn - location <- liftIO $ mkHomeModLocation2 fopts mod_name - (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" + let location = mkHomeModLocation2 fopts mod_name + (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" env <- getBkpEnv src_hash <- liftIO $ getFileHash (bkp_filename env) @@ -780,13 +783,13 @@ ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp, ms_srcimps = [], - ms_textual_imps = extra_sig_imports, + ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports, ms_ghc_prim_import = False, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { hsmodAnn = noAnn, hsmodLayout = NoLayoutInfo, - hsmodName = Just (L loc mod_name), + hsmodName = Just (L (noAnnSrcSpan loc) mod_name), hsmodExports = Nothing, hsmodImports = [], hsmodDecls = [], @@ -847,7 +850,7 @@ -- To add insult to injury, we don't even actually use -- these filenames to figure out where the hi files go. -- A travesty! - location0 <- liftIO $ mkHomeModLocation2 fopts modname + let location0 = mkHomeModLocation2 fopts modname (unpackFS unit_fs moduleNameSlashes modname) (case hsc_src of @@ -873,8 +876,10 @@ implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports modname loc implicit_prelude imps - convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname let normal_imports = map convImport (implicit_imports ++ ordinary_imps) @@ -902,8 +907,8 @@ -- We have to do something special here: -- due to merging, requirements may end up with -- extra imports - ++ extra_sig_imports - ++ ((,) Nothing . noLoc <$> implicit_sigs), + ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports) + ++ ((,) NoPkgQual . noLoc <$> implicit_sigs), -- This is our hack to get the parse tree to the right spot ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, @@ -923,7 +928,7 @@ -- | Create a new, externally provided hashed unit id from -- a hash. -newUnitId :: IndefUnitId -> Maybe FastString -> UnitId +newUnitId :: UnitId -> Maybe FastString -> UnitId newUnitId uid mhash = case mhash of - Nothing -> indefUnit uid - Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash) + Nothing -> uid + Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash) diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -11,6 +11,7 @@ import GHC.Unit.Types (Module) import GHC.CmmToAsm.Config import GHC.Utils.Outputable +import GHC.CmmToAsm.BlockLayout -- | Initialize the native code generator configuration from the DynFlags initNCGConfig :: DynFlags -> Module -> NCGConfig @@ -67,4 +68,8 @@ , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags , ncgComputeUnwinding = debugLevel dflags > 0 + , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) + -- Disable when -finfo-table-map is on (#20428) + && backendMaintainsCfg (targetPlatform dflags) + -- Enable if the platform maintains the CFG } diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/Finder.hs @@ -0,0 +1,29 @@ +module GHC.Driver.Config.Finder ( + FinderOpts(..), + initFinderOpts + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Unit.Finder.Types + + +-- | Create a new 'FinderOpts' from DynFlags. +initFinderOpts :: DynFlags -> FinderOpts +initFinderOpts flags = FinderOpts + { finder_importPaths = importPaths flags + , finder_lookupHomeInterfaces = isOneShot (ghcMode flags) + , finder_bypassHiFileCheck = MkDepend == (ghcMode flags) + , finder_ways = ways flags + , finder_enableSuggestions = gopt Opt_HelpfulErrors flags + , finder_hieDir = hieDir flags + , finder_hieSuf = hieSuf flags + , finder_hiDir = hiDir flags + , finder_hiSuf = hiSuf_ flags + , finder_dynHiSuf = dynHiSuf_ flags + , finder_objectDir = objectDir flags + , finder_objectSuf = objectSuf_ flags + , finder_dynObjectSuf = dynObjectSuf_ flags + , finder_stubDir = stubDir flags + } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -239,6 +239,7 @@ import GHC.Driver.Env.KnotVars import GHC.Types.Name.Set (NonCaffySet) import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) +import Data.List.NonEmpty (NonEmpty ((:|))) {- ********************************************************************** @@ -411,6 +412,17 @@ Nothing -> liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + + let diag_opts = initDiagOpts dflags + when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do + case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of + Nothing -> pure () + Just chars@((eloc,chr,_) :| _) -> + let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr) + in logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts span $ + GhcPsMessage $ PsWarnBidirectionalFormatChars chars + let parseMod | HsigFile == ms_hsc_src mod_summary = parseSignature | otherwise = parseModule @@ -469,9 +481,34 @@ hsc_env <- getHscEnv withPlugins hsc_env applyPluginAction res +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) +checkBidirectionFormatChars start_loc sb + | containsBidirectionalFormatChar sb = Just $ go start_loc sb + | otherwise = Nothing + where + go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String) + go loc sb + | atEnd sb = panic "checkBidirectionFormatChars: no char found" + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb + | otherwise -> go (advancePsLoc loc chr) sb + go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)] + go1 loc sb + | atEnd sb = [] + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) : go1 (advancePsLoc loc chr) sb + | otherwise -> go1 (advancePsLoc loc chr) sb + + -- ----------------------------------------------------------------------------- -- | If the renamed source has been kept, extract it. Dump it if requested. + + extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result @@ -733,8 +770,8 @@ -- or not. checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable) checkObjects dflags mb_old_linkable summary = do - dt_state <- dynamicTooState dflags let + dt_enabled = gopt Opt_BuildDynamicToo dflags this_mod = ms_mod summary mb_obj_date = ms_obj_date summary mb_dyn_obj_date = ms_dyn_obj_date summary @@ -743,12 +780,12 @@ -- dynamic-too *also* produces the dyn_o_file, so have to check -- that's there, and if it's not, regenerate both .o and -- .dyn_o - checkDynamicObj k = case dt_state of - DT_OK -> case (>=) <$> mb_dyn_obj_date <*> mb_if_date of + checkDynamicObj k = if dt_enabled + then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of Just True -> k _ -> return (RecompBecause MissingDynObjectFile, Nothing) -- Not in dynamic-too mode - _ -> k + else k checkDynamicObj $ case (,) <$> mb_obj_date <*> mb_if_date of @@ -962,18 +999,8 @@ Interpreter -> False _ -> True - -- mod_location only contains the base name, so we rebuild the - -- correct file extension from the dynflags. - baseName = ml_hi_file mod_location - buildIfName suffix is_dynamic - | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags - = name - | otherwise - = let with_hi = replaceExtension baseName suffix - in addBootSuffix_maybe (mi_boot iface) with_hi - write_iface dflags' iface = - let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags') + let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location profile = targetProfile dflags' in {-# SCC "writeIface" #-} @@ -982,7 +1009,7 @@ (const ()) (writeIface logger profile iface_name iface) - when (write_interface || force_write_interface) $ do + if (write_interface || force_write_interface) then do -- FIXME: with -dynamic-too, "no_change" is only meaningful for the -- non-dynamic interface, not for the dynamic one. We should have another @@ -999,7 +1026,7 @@ -- let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) - dt <- dynamicTooState dflags + let dt = dynamicTooState dflags when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ hang (text "Writing interface(s):") 2 $ vcat @@ -1013,7 +1040,6 @@ write_iface dflags iface case dt of DT_Dont -> return () - DT_Failed -> return () DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" DT_OK -> write_iface (setDynamicNow dflags) iface else case dt of @@ -1021,7 +1047,6 @@ DT_OK | not no_change -> write_iface dflags iface -- FIXME: see no_change' comment above DT_Dyn -> write_iface dflags iface - DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface _ -> return () when (gopt Opt_WriteHie dflags) $ do @@ -1039,6 +1064,9 @@ let hie_file = ml_hie_file mod_location whenM (doesFileExist hie_file) $ GHC.SysTools.touch logger dflags "Touching hie file" hie_file + else + -- See Note [Strictness in ModIface] + forceModIface iface -------------------------------------------------------------- -- NoRecomp handlers @@ -1714,6 +1742,8 @@ no_loc = ModLocation{ ml_hs_file = Just filename, ml_hi_file = panic "hscCompileCmmFile: no hi file", ml_obj_file = panic "hscCompileCmmFile: no obj file", + ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file", + ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file", ml_hie_file = panic "hscCompileCmmFile: no hie file"} -------------------- Stuff for new code gen --------------------- @@ -1945,6 +1975,8 @@ let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", + ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file", + ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file", ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv @@ -2155,6 +2187,8 @@ ; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file", ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } ; let ictxt = hsc_IC hsc_env diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -27,7 +27,7 @@ -- ----------------------------------------------------------------------------- module GHC.Driver.Make ( depanal, depanalE, depanalPartial, - load, load', LoadHowMuch(..), + load, loadWithCache, load', LoadHowMuch(..), instantiationNodes, downsweep, @@ -87,7 +87,7 @@ import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Exception ( evaluate, throwIO, SomeAsyncException ) +import GHC.Utils.Exception ( throwIO, SomeAsyncException ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -108,6 +108,7 @@ import GHC.Types.Unique.Set import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Finder @@ -149,6 +150,7 @@ import Control.Concurrent.STM import Control.Monad.Trans.Maybe import GHC.Runtime.Loader +import GHC.Rename.Names -- ----------------------------------------------------------------------------- @@ -346,11 +348,14 @@ -- returns together with the errors an empty ModuleGraph. -- After processing this empty ModuleGraph, the errors of depanalE are thrown. -- All other errors are reported using the 'defaultWarnErrLogger'. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do + +load :: GhcMonad f => LoadHowMuch -> f SuccessFlag +load how_much = fst <$> loadWithCache [] how_much + +loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo]) +loadWithCache cache how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 - success <- load' how_much (Just batchMsg) mod_graph + success <- load' cache how_much (Just batchMsg) mod_graph if isEmptyMessages errs then pure success else throwErrors (fmap GhcDriverMessage errs) @@ -468,7 +473,7 @@ -- hs-boot files which are **not** part of cycles. collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan] collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes - collapseAcyclic (CyclicSCC nodes : _) = [UnresolvedCycle nodes] + collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes collapseAcyclic [] = [] topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing @@ -483,13 +488,12 @@ -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally -- produced by calling 'depanal'. -load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' how_much mHscMessage mod_graph = do +load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo]) +load' cache how_much mHscMessage mod_graph = do modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession - let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let interp = hscInterp hsc_env @@ -519,7 +523,7 @@ | otherwise = do liftIO $ errorMsg logger (text "no such module:" <+> quotes (ppr m)) - return Failed + return (Failed, []) checkHowMuch how_much $ do @@ -545,15 +549,14 @@ let -- prune the HPT so everything is not retained when doing an -- upsweep. - pruned_hpt = pruneHomePackageTable hpt1 + !pruned_cache = pruneCache cache (flattenSCCs (filterToposortToModules mg2_with_srcimps)) - _ <- liftIO $ evaluate pruned_hpt -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env + -- write an empty HPT to allow the old HPT to be GC'd. + setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env -- Unload everything liftIO $ unload interp hsc_env @@ -568,11 +571,13 @@ Just n -> return n setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env - (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ - liftIO $ upsweep n_jobs hsc_env mHscMessage pruned_hpt direct_deps build_plan + hsc_env <- getSession + (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $ + liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan setSession hsc_env1 - case upsweep_ok of + fmap (, new_cache) $ case upsweep_ok of Failed -> loadFinish upsweep_ok Succeeded + Succeeded -> do -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -594,7 +599,7 @@ -- called Main, or (b) the user said -no-hs-main, indicating -- that main() is going to come from somewhere else. -- - let ofile = outputFile dflags + let ofile = outputFile_ dflags let no_hs_main = gopt Opt_NoHsMain dflags let main_mod = mainModIs hsc_env @@ -696,11 +701,11 @@ ml_hs_file (ms_location ms) name = fmap dropExtension mainModuleSrcPath - name_exe = do + !name_exe = do -- we must add the .exe extension unconditionally here, otherwise -- when name has an extension of its own, the .exe extension will -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 - name' <- if platformOS platform == OSMinGW32 + !name' <- if platformOS platform == OSMinGW32 then fmap (<.> "exe") name else name mainModuleSrcPath' <- mainModuleSrcPath @@ -729,19 +734,20 @@ -- space at the end of the upsweep, because the topmost ModDetails of the -- old HPT holds on to the entire type environment from the previous -- compilation. -pruneHomePackageTable :: HomePackageTable +-- Note [GHC Heap Invariants] +pruneCache :: [HomeModInfo] -> [ModSummary] - -> HomePackageTable -pruneHomePackageTable hpt summ - = mapHpt prune hpt + -> [HomeModInfo] +pruneCache hpt summ + = strictMap prune hpt where prune hmi = hmi'{ hm_details = emptyModDetails } where modl = moduleName (mi_module (hm_iface hmi)) - hmi' | mi_src_hash (hm_iface hmi) /= ms_hs_hash ms + hmi' | Just ms <- lookupUFM ms_map modl + , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms = hmi{ hm_linkable = Nothing } | otherwise = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] @@ -920,11 +926,14 @@ withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem) -- | Environment used when compiling a module -data MakeEnv = MakeEnv { hsc_env :: HscEnv -- The basic HscEnv which will be augmented for each module - , old_hpt :: HomePackageTable -- A cache of old interface files - , compile_sem :: AbstractSem - , lqq_var :: TVar LogQueueQueue - , env_messager :: Maybe Messager +data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module + , compile_sem :: !AbstractSem + -- Modify the environment for module k, with the supplied logger modification function. + -- For -j1, this wrapper doesn't do anything + -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output + -- into the log queue. + , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a + , env_messager :: !(Maybe Messager) } type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a @@ -933,12 +942,13 @@ -- get its direct dependencies from. This might not be the corresponding build action -- if the module participates in a loop. This step also labels each node with a number for the output. -- See Note [Upsweep] for a high-level description. -interpretBuildPlan :: (NodeKey -> [NodeKey]) +interpretBuildPlan :: (M.Map ModuleNameWithIsBoot HomeModInfo) + -> (NodeKey -> [NodeKey]) -> [BuildPlan] -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle , [MakeAction] -- Actions we need to run in order to build everything , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end. -interpretBuildPlan deps_map plan = do +interpretBuildPlan old_hpt deps_map plan = do hpt_var <- newMVar emptyHomePackageTable ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var) return (mcycle, plans, collect_results (buildDep build_map)) @@ -986,10 +996,11 @@ case mod of InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu ModuleNode ms -> do - hmi <- executeCompileNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms) + let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt + hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms) -- This global MVar is incrementally modified in order to avoid having to -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hpt_var (return . addHomeModInfoToHpt hmi) + liftIO $ modifyMVar_ hpt_var (\hpt -> return $! addHomeModInfoToHpt hmi hpt) return (Just hmi) res_var <- liftIO newEmptyMVar @@ -1008,8 +1019,8 @@ hpt_var <- gets hpt_var res_var <- liftIO newEmptyMVar let loop_action = do - hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules) - liftIO $ modifyMVar_ hpt_var (\hpt -> return $ foldl' (flip addHomeModInfoToHpt) hpt hmis) + !hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules) + liftIO $ modifyMVar_ hpt_var (\hpt -> return $! foldl' (flip addHomeModInfoToHpt) hpt hmis) return hmis @@ -1029,13 +1040,13 @@ :: Int -- ^ The number of workers we wish to run in parallel -> HscEnv -- ^ The base HscEnv, which is augmented for each module -> Maybe Messager - -> HomePackageTable + -> M.Map ModuleNameWithIsBoot HomeModInfo -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey -> [BuildPlan] - -> IO (SuccessFlag, HscEnv) + -> IO (SuccessFlag, HscEnv, [HomeModInfo]) upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do - (cycle, pipelines, collect_result) <- interpretBuildPlan direct_deps build_plan - runPipelines n_jobs hsc_env old_hpt mHscMessage pipelines + (cycle, pipelines, collect_result) <- interpretBuildPlan old_hpt direct_deps build_plan + runPipelines n_jobs hsc_env mHscMessage pipelines res <- collect_result let completed = [m | Just (Just m) <- res] @@ -1047,11 +1058,14 @@ Just mss -> do let logger = hsc_logger hsc_env liftIO $ fatalErrorMsg logger (cyclicModuleErr mss) - return (Failed, hsc_env) + return (Failed, hsc_env, completed) Nothing -> do let success_flag = successIf (all isJust res) - return (success_flag, hsc_env') + return (success_flag, hsc_env', completed) +toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo +toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis]) + upsweep_inst :: HscEnv -> Maybe Messager -> Int -- index of module @@ -1069,34 +1083,14 @@ -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv -> Maybe Messager - -> HomePackageTable + -> Maybe HomeModInfo -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo -upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods = do - let old_hmi = lookupHpt old_hpt (ms_mod_name summary) - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary == IsBoot -> Just iface - | mi_boot iface == NotBoot -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - +upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do hmi <- compileOne' mHscMessage hsc_env summary - mod_index nmods mb_old_iface (old_hmi >>= hm_linkable) + mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable) -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I @@ -1254,8 +1248,6 @@ Following this fix, GHC can compile itself with --make -O2. -} --- NB: sometimes mods has duplicates; this is harmless because --- any duplicates get clobbered in addListToHpt and never get forced. typecheckLoop :: HscEnv -> [HomeModInfo] -> IO [(ModuleName, HomeModInfo)] typecheckLoop hsc_env hmis = do debugTraceMsg logger 2 $ @@ -1264,6 +1256,8 @@ let new_hpt = addListToHpt old_hpt new_mods let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env -- Crucial, crucial: initIfaceLoad clears the if_rec_types field. + -- See [KnotVars invariants] + -- Note [GHC Heap Invariants] mds <- initIfaceLoad new_hsc_env $ mapM (typecheckIface . hm_iface) hmis let new_mods = [ (mn,hmi{ hm_details = details }) @@ -1273,7 +1267,10 @@ where logger = hsc_logger hsc_env - old_hpt = hsc_HPT hsc_env + to_delete = (map (moduleName . mi_module . hm_iface) hmis) + -- Filter out old modules before tying the knot, otherwise we can end + -- up with a thunk which keeps reference to the old HomeModInfo. + !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete -- --------------------------------------------------------------------------- -- @@ -1447,9 +1444,11 @@ -- | Efficiently construct a map from a NodeKey to its list of transitive dependencies mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey]) -mkDepsMap nodes nk = - let (mg, lookup_node) = moduleGraphNodes False nodes - in map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk)) +mkDepsMap nodes = + -- Important that we force this before returning a lambda so we can share the module graph + -- for each node + let !(mg, lookup_node) = moduleGraphNodes False nodes + in \nk -> map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk)) -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can @@ -1660,27 +1659,26 @@ tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean tmpfs dynLife [dyn_tn] - return tn + return (tn, dyn_tn) -- We don't want to create .o or .hi files unless we have been asked -- to by the user. But we need them, so we patch their locations in -- the ModSummary with temporary files. -- - (hi_file, o_file) <- + ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- -- If ``-fwrite-interface` is specified, then the .o and .hi files -- are written into `-odir` and `-hidir` respectively. #16670 if gopt Opt_WriteInterface dflags - then return (ml_hi_file ms_location, ml_obj_file ms_location) + then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location) + , (ml_obj_file ms_location, ml_dyn_obj_file ms_location)) else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) let ms' = ms { ms_location = - ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} - , ms_hspp_opts = updOptLevel 0 $ - setOutputFile (Just o_file) $ - setDynOutputFile (Just $ dynamicOutputFile dflags o_file) $ - setOutputHi (Just hi_file) $ - setDynOutputHi (Just $ dynamicOutputHi dflags hi_file) $ - dflags {backend = bcknd} + ms_location { ml_hi_file = hi_file + , ml_obj_file = o_file + , ml_dyn_hi_file = dyn_hi_file + , ml_dyn_obj_file = dyn_o_file } + , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd} } pure (ExtendedModSummary ms' bkp_deps) | otherwise = return (ExtendedModSummary ms bkp_deps) @@ -1797,7 +1795,7 @@ let fopts = initFinderOpts (hsc_dflags hsc_env) -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation fopts pi_mod_name src_fn + let location = mkHomeModLocation fopts pi_mod_name src_fn -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path @@ -1912,7 +1910,7 @@ | otherwise = find_it where dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + fopts = initFinderOpts dflags home_unit = hsc_home_unit hsc_env fc = hsc_FC hsc_env units = hsc_units hsc_env @@ -1924,7 +1922,7 @@ old_summary location find_it = do - found <- findImportedModule fc fopts units home_unit wanted_mod Nothing + found <- findImportedModule fc fopts units home_unit wanted_mod NoPkgQual case found of Found location mod | isJust (ml_hs_file location) -> @@ -2003,9 +2001,8 @@ makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps - let dflags = hsc_dflags hsc_env obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) - dyn_obj_timestamp <- modificationTimeIfExists (dynamicOutputFile dflags (ml_obj_file nms_location)) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) @@ -2025,8 +2022,8 @@ , ms_srcimps = pi_srcimps , ms_ghc_prim_import = pi_ghc_prim_import , ms_textual_imps = - extra_sig_imports ++ - ((,) Nothing . noLoc <$> implicit_sigs) ++ + ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++ + ((,) NoPkgQual . noLoc <$> implicit_sigs) ++ pi_theimps , ms_hs_hash = nms_src_hash , ms_iface_date = hi_timestamp @@ -2040,8 +2037,8 @@ data PreprocessedImports = PreprocessedImports { pi_local_dflags :: DynFlags - , pi_srcimps :: [(Maybe FastString, Located ModuleName)] - , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_srcimps :: [(PkgQual, Located ModuleName)] + , pi_theimps :: [(PkgQual, Located ModuleName)] , pi_ghc_prim_import :: Bool , pi_hspp_fn :: FilePath , pi_hspp_buf :: StringBuffer @@ -2062,12 +2059,16 @@ (pi_local_dflags, pi_hspp_fn) <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn - (pi_srcimps, pi_theimps, pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name) + (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name) <- ExceptT $ do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + let rn_imps = fmap (first rn_pkg_qual) + let pi_srcimps = rn_imps pi_srcimps' + let pi_theimps = rn_imps pi_theimps' return PreprocessedImports {..} @@ -2229,9 +2230,8 @@ _ -> errorMsg lcl_logger (text (show exc)) return Nothing -withParLog :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a -withParLog k cont = do - MakeEnv{lqq_var, hsc_env} <- ask +withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b +withParLog lqq_var k cont = do let init_log = liftIO $ do -- Make a new log queue lq <- newLogQueue k @@ -2239,9 +2239,13 @@ atomically $ initLogQueue lqq_var lq return lq finish_log lq = liftIO (finishLogQueue lq) - MC.bracket init_log finish_log $ \lq -> do - -- Modify the logger to use the log queue - let lcl_logger = pushLogHook (const (parLogAction lq)) (hsc_logger hsc_env) + MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq))) + +withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a +withLoggerHsc k cont = do + MakeEnv{withLogger, hsc_env} <- ask + withLogger k $ \modifyLogger -> do + let lcl_logger = modifyLogger (hsc_logger hsc_env) hsc_env' = hsc_env { hsc_logger = lcl_logger } -- Run continuation with modified logger cont hsc_env' @@ -2254,7 +2258,7 @@ -> InstantiatedUnit -> RunMakeM () executeInstantiationNode k n wait_deps iu = do - withParLog k $ \hsc_env -> do + withLoggerHsc k $ \hsc_env -> do -- Wait for the dependencies of this node deps <- wait_deps -- Output of the logger is mediated by a central worker to @@ -2268,11 +2272,12 @@ executeCompileNode :: Int -> Int + -> Maybe HomeModInfo -> RunMakeM HomePackageTable -> Maybe (ModuleEnv (IORef TypeEnv)) -> ModSummary -> RunMakeM HomeModInfo -executeCompileNode k n wait_deps mknot_var mod = do +executeCompileNode k n !old_hmi wait_deps mknot_var mod = do MakeEnv{..} <- ask let mk_mod = case ms_hsc_src mod of HsigFile -> @@ -2284,7 +2289,7 @@ _ -> return emptyModuleEnv knot_var <- liftIO $ maybe mk_mod return mknot_var deps <- wait_deps - withParLog k $ \hsc_env -> do + withLoggerHsc k $ \hsc_env -> do let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas lcl_dynflags = ms_hspp_opts mod let lcl_hsc_env = @@ -2295,7 +2300,7 @@ -- Compile the module, locking with a semphore to avoid too many modules -- being compiled at the same time leading to high memory usage. lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do - res <- upsweep_mod lcl_hsc_env env_messager old_hpt mod k n + res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags return res) @@ -2360,16 +2365,34 @@ self_tid <- CC.myThreadId CC.labelThread self_tid thread_name + +runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () +runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do + liftIO $ label_self "main --make thread" + + plugins_hsc_env <- initializePlugins orig_hsc_env Nothing + case n_job of + 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines + _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + +runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () +runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = + let env = MakeEnv { hsc_env = plugin_hsc_env + , withLogger = \_ k -> k id + , compile_sem = AbstractSem (return ()) (return ()) + , env_messager = mHscMessager + } + in runAllPipelines 1 env all_pipelines + + -- | Build and run a pipeline -runPipelines :: Int -- ^ How many capabilities to use +runParPipelines :: Int -- ^ How many capabilities to use -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module - -> HomePackageTable -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap) -> Maybe Messager -- ^ Optional custom messager to use to report progress -> [MakeAction] -- ^ The build plan for all the module nodes -> IO () -runPipelines n_jobs orig_hsc_env old_hpt mHscMessager all_pipelines = do +runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do - liftIO $ label_self "main --make thread" -- A variable which we write to when an error has happened and we have to tell the -- logging thread to gracefully shut down. @@ -2378,13 +2401,12 @@ -- will add it's LogQueue into this queue. log_queue_queue_var <- newTVarIO newLogQueueQueue -- Thread which coordinates the printing of logs - wait_log_thread <- logThread (hsc_logger orig_hsc_env) stopped_var log_queue_queue_var + wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var - plugins_hsc_env <- initializePlugins orig_hsc_env Nothing -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. - thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger orig_hsc_env) - let thread_safe_hsc_env = plugins_hsc_env { hsc_logger = thread_safe_logger } + thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) + let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } let updNumCapabilities = liftIO $ do n_capabilities <- getNumCapabilities @@ -2401,16 +2423,11 @@ atomically $ writeTVar stopped_var True wait_log_thread - abstract_sem <- - case n_jobs of - 1 -> return $ AbstractSem (return ()) (return ()) - _ -> do - compile_sem <- newQSem n_jobs - return $ AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) + compile_sem <- newQSem n_jobs + let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) -- Reset the number of capabilities once the upsweep ends. let env = MakeEnv { hsc_env = thread_safe_hsc_env - , old_hpt = old_hpt - , lqq_var = log_queue_queue_var + , withLogger = withParLog log_queue_queue_var , compile_sem = abstract_sem , env_messager = mHscMessager } @@ -2466,3 +2483,31 @@ waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar + +{- Note [GHC Heap Invariants] + +This note is a general place to explain some of the heap invariants which should +hold for a program compiled with --make mode. These invariants are all things +which can be checked easily using ghc-debug. + +1. No HomeModInfo are reachable via the EPS. + Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains + a reference to the entire HscEnv, if we are not careful the HscEnv will + contain the HomePackageTable at the time the interface was loaded and + it will never be released. + Where? dontLeakTheHPT in GHC.Iface.Load + +2. No KnotVars are live at the end of upsweep (#20491) + Why? KnotVars contains an old stale reference to the TypeEnv for modules + which participate in a loop. At the end of a loop all the KnotVars references + should be removed by the call to typecheckLoop. + Where? typecheckLoop in GHC.Driver.Make. + +3. Immediately after a reload, no ModDetails are live. + Why? During the upsweep all old ModDetails are replaced with a new ModDetails + generated from a ModIface. If we don't clear the ModDetails before the + reload takes place then memory usage during the reload is twice as much + as it should be as we retain a copy of the ModDetails for too long. + Where? pruneCache in GHC.Driver.Make + +-} diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -30,8 +30,8 @@ import GHC.Utils.Panic.Plain import GHC.Types.SourceError import GHC.Types.SrcLoc +import GHC.Types.PkgQual import Data.List (partition) -import GHC.Data.FastString import GHC.Utils.TmpFs import GHC.Iface.Load (cannotFindModule) @@ -284,7 +284,7 @@ findDependency :: HscEnv -> SrcSpan - -> Maybe FastString -- package qualifier, if any + -> PkgQual -- package qualifier, if any -> ModuleName -- Imported module -> IsBootInterface -- Source import -> Bool -- Record dependency on package modules diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -239,12 +239,12 @@ plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary)) let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput - status <- hscRecompStatus mHscMessage plugin_hsc_env summary + status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods) - let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, summary, status) + let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline -- See Note [ModDetails and --make mode] - details <- initModDetails plugin_hsc_env summary iface + details <- initModDetails plugin_hsc_env upd_summary iface return $! HomeModInfo iface details linkable where lcl_dflags = ms_hspp_opts summary @@ -303,6 +303,7 @@ | otherwise = (backend dflags, dflags2) dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } + upd_summary = summary { ms_hspp_opts = dflags } hsc_env = hscSetFlags dflags hsc_env0 -- --------------------------------------------------------------------------- @@ -432,7 +433,7 @@ let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile dflags) + exe_file = exeFileName platform staticLink (outputFile_ dflags) linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps @@ -469,7 +470,7 @@ -- linking (unless the -fforce-recomp flag was given). let platform = ue_platform unit_env unit_state = ue_units unit_env - exe_file = exeFileName platform staticLink (outputFile dflags) + exe_file = exeFileName platform staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -530,11 +531,13 @@ dflags = hsc_dflags hsc_env mb_o_file = outputFile dflags ghc_link = ghcLink dflags -- Set by -c or -no-link - + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True -- When linking, the -o argument refers to the linker's output. -- otherwise, we use it as the name for the pipeline's output. output - | NoBackend <- backend dflags = NoOutputFile + | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent -- -o foo applies to linker | isJust mb_o_file = SpecificFile @@ -715,67 +718,10 @@ let hsc_env' = hscSetFlags dflags hsc_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour) - res <- hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) - checkDynamicToo pipe_env hsc_env pp_fn src_flavour res - -- Once the pipeline has finished, check to see if -dynamic-too failed and - -- rerun again if it failed but just the `--dynamic` way. - -checkDynamicToo :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> (ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable) -checkDynamicToo pipe_env hsc_env pp_fn src_flavour res = do - liftIO (dynamicTooState (hsc_dflags hsc_env)) >>= \case - DT_Dont -> return res - DT_Dyn -> return res - DT_OK -> return res - -- If we are compiling a Haskell module with -dynamic-too, we - -- first try the "fast path": that is we compile the non-dynamic - -- version and at the same time we check that interfaces depended - -- on exist both for the non-dynamic AND the dynamic way. We also - -- check that they have the same hash. - -- If they don't, dynamicTooState is set to DT_Failed. - -- See GHC.Iface.Load.checkBuildDynamicToo - -- If they do, in the end we produce both the non-dynamic and - -- dynamic outputs. - -- - -- If this "fast path" failed, we execute the whole pipeline - -- again, this time for the dynamic way *only*. To do that we - -- just set the dynamicNow bit from the start to ensure that the - -- dynamic DynFlags fields are used and we disable -dynamic-too - -- (its state is already set to DT_Failed so it wouldn't do much - -- anyway). - DT_Failed - -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) - | OSMinGW32 <- platformOS (targetPlatform dflags) -> return res - | otherwise -> do - liftIO (debugTraceMsg logger 4 - (text "Running the full pipeline again for -dynamic-too")) - hsc_env' <- liftIO (resetHscEnv hsc_env) - fullPipeline pipe_env hsc_env' pp_fn src_flavour - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - --- | Enable dynamic-too, reset EPS -resetHscEnv :: HscEnv -> IO HscEnv -resetHscEnv hsc_env = do - let dflags0 = flip gopt_unset Opt_BuildDynamicToo - $ setDynamicNow - $ (hsc_dflags hsc_env) - hsc_env' <- newHscEnv dflags0 - (dbs,unit_state,home_unit,mconstants) <- initUnits (hsc_logger hsc_env) dflags0 Nothing - dflags1 <- updatePlatformConstants dflags0 mconstants - unit_env0 <- initUnitEnv (ghcNameVersion dflags1) (targetPlatform dflags1) - let unit_env = unit_env0 - { ue_home_unit = Just home_unit - , ue_units = unit_state - , ue_unit_dbs = Just dbs - } - let hsc_env'' = hscSetFlags dflags1 $ hsc_env' - { hsc_unit_env = unit_env - } - return hsc_env'' + hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) -- | Everything after preprocess -hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable) +hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do case hsc_recomp_status of HscUpToDate iface mb_linkable -> return (iface, mb_linkable) @@ -795,11 +741,9 @@ -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing _ -> do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result - liftIO (dynamicTooState (hsc_dflags hsc_env)) >>= \case - DT_OK -> do + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result - _ -> return () return res hscGenBackendPipeline :: P m @@ -811,11 +755,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) - dflags = hsc_dflags hsc_env - -- MP: The ModLocation is recalculated here to get the right paths when - -- -dynamic-too is enabled. `ModLocation` should be extended with a field for - -- the location of the `dyn_o` file to avoid this recalculation. - location <- liftIO (getLocation pipe_env dflags src_flavour mod_name) + let location = ms_location mod_sum (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file final_linkable <- diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -81,6 +81,9 @@ import GHC.Utils.Panic import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars +import GHC.Driver.Config.Finder +import GHC.Rename.Names +import Data.Bifunctor (first) newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -494,7 +497,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - o_file = ml_obj_file location -- The real object file + o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file next_phase = hscPostBackendPhase src_flavour (backend dflags) case result of HscUpdate iface -> @@ -635,25 +638,27 @@ -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do - buf <- hGetStringBuffer input_fn - let imp_prelude = xopt LangExt.ImplicitPrelude dflags - popts = initParserOpts dflags - eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) - case eimps of - Left errs -> throwErrors (GhcPsMessage <$> errs) - Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return - (Just buf, mod_name, imps, src_imps, ghc_prim_imp) + buf <- hGetStringBuffer input_fn + let imp_prelude = xopt LangExt.ImplicitPrelude dflags + popts = initParserOpts dflags + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + rn_imps = fmap (first rn_pkg_qual) + eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors (GhcPsMessage <$> errs) + Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return + (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp) -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking -- (If we're linking then the -o applies to the linked thing, not to -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above - location <- getLocation pipe_env dflags src_flavour mod_name + location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name let o_file = ml_obj_file location -- The real object file hi_file = ml_hi_file location hie_file = ml_hie_file location - dyn_o_file = dynamicOutputFile dflags o_file + dyn_o_file = ml_dyn_obj_file location src_hash <- getFileHash (basename <.> suff) hi_date <- modificationTimeIfExists hi_file @@ -702,6 +707,52 @@ return (plugin_hsc_env, mod_summary, status) +-- | Calculate the ModLocation from the provided DynFlags. This function is only used +-- in one-shot mode and therefore takes into account the effect of -o/-ohi flags +-- (which do nothing in --make mode) +mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation +mkOneShotModLocation pipe_env dflags src_flavour mod_name = do + let PipeEnv{ src_basename=basename, + src_suffix=suff } = pipe_env + let location1 = mkHomeModLocation2 fopts mod_name basename suff + + -- Boot-ify it if necessary + let location2 + | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + let dynohi = dynOutputHi dflags + location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn } + | otherwise = location3 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile_ dflags + expl_dyn_o_file = dynOutputFile_ dflags + location5 | Just ofile <- expl_o_file + , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file + , isNoLink (ghcLink dflags) + = location4 { ml_obj_file = ofile + , ml_dyn_obj_file = dyn_ofile } + | Just dyn_ofile <- expl_dyn_o_file + = location4 { ml_dyn_obj_file = dyn_ofile } + | otherwise = location4 + return location5 + where + fopts = initFinderOpts dflags + runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage) runHscTcPhase = hscTypecheckAndGetWarnings @@ -728,7 +779,11 @@ ] ) return output_fn -phaseOutputFilenameNew :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> IO FilePath +phaseOutputFilenameNew :: Phase -- ^ The next phase + -> PipeEnv + -> HscEnv + -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file + -> IO FilePath phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env let dflags = hsc_dflags hsc_env @@ -764,16 +819,37 @@ -> Maybe ModLocation -> IO FilePath getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location + -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation + -- will have been modified to point to the accurate locations + | StopLn <- next_phase, Just loc <- maybe_location = + return $ if dynamicNow dflags then ml_dyn_obj_file loc + else ml_obj_file loc + -- 2. If output style is persistant then | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile <- output = case outputFile dflags of - Just f -> return f - Nothing -> - panic "SpecificFile: No filename" + -- 3. Specific file is only set when outputFile is set by -o + -- If we are in dynamic mode but -dyno is not set then write to the same path as + -- -o with a .dyn_* extension. This case is not triggered for object files which + -- are always handled by the ModLocation. + | is_last_phase, SpecificFile <- output = + return $ + if dynamicNow dflags + then case dynOutputFile_ dflags of + Nothing -> let ofile = getOutputFile_ dflags + new_ext = case takeExtension ofile of + "" -> "dyn" + ext -> "dyn_" ++ tail ext + in replaceExtension ofile new_ext + Just fn -> fn + else getOutputFile_ dflags | keep_this_output = persistent_fn | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule suffix where + getOutputFile_ dflags = case outputFile_ dflags of + Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags)) + Just fn -> fn + hcsuf = hcSuf dflags odir = objectDir dflags osuf = objectSuf dflags @@ -808,7 +884,6 @@ persistent = basename <.> suffix odir_persistent - | Just loc <- maybe_location = ml_obj_file loc | Just d <- odir = (d persistent) | otherwise = persistent diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -181,7 +181,7 @@ where go WpHole = id go (w1 `WpCompose` w2) = go w1 . go w2 - go (WpFun _ w2 (Scaled m exp_arg) _) = liftPRType $ \t -> + go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t -> let act_res = funResultTy t exp_res = hsWrapperType w2 act_res in mkFunctionType m exp_arg exp_res diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -648,7 +648,7 @@ (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2) It looks like we can write this in Haskell directly, but we can't: -the reprsentation polymorphism checks defeat us. Note that `x` is a +the representation polymorphism checks defeat us. Note that `x` is a representation-polymorphic variable. So we must wire it in with a compulsory unfolding, like other representation-polymorphic primops. @@ -755,10 +755,13 @@ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding' rhs + `setArityInfo` arity ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] $ mkVisFunTyMany openAlphaTy openBetaTy + + arity = 1 id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) } diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -27,13 +27,11 @@ -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) import GHC.Tc.Utils.TcType -import GHC.Core.Type( splitPiTy ) import GHC.Core.Multiplicity -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs @@ -75,25 +73,6 @@ the_choice_id = assocMaybe prs choiceAName the_loop_id = assocMaybe prs loopAName - -- used as an argument in, e.g., do_premap - ; check_lev_poly 3 the_arr_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 5 the_compose_id - - -- used as an argument in, e.g., dsCmdStmt/BodyStmt - ; check_lev_poly 4 the_first_id - - -- the result of the_app_id is used as an argument in, e.g., - -- dsCmd/HsCmdArrApp/HsHigherOrderApp - ; check_lev_poly 2 the_app_id - - -- used as an argument in, e.g., HsCmdIf - ; check_lev_poly 5 the_choice_id - - -- used as an argument in, e.g., RecStmt - ; check_lev_poly 4 the_loop_id - ; return (meth_binds, DsCmdEnv { arr_id = Var (unmaybe the_arr_id arrAName), compose_id = Var (unmaybe the_compose_id composeAName), @@ -112,20 +91,6 @@ unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) unmaybe (Just id) _ = id - -- returns the result type of a pi-type (that is, a forall or a function) - -- Note that this result type may be ill-scoped. - res_type :: Type -> Type - res_type ty = res_ty - where - (_, res_ty) = splitPiTy ty - - check_lev_poly :: Int -- arity - -> Maybe Id -> DsM () - check_lev_poly _ Nothing = return () - check_lev_poly arity (Just id) - = dsNoLevPoly (nTimes arity res_type (idType id)) (LevityCheckMkCmdEnv id) - - -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] @@ -319,9 +284,9 @@ let env_ty = mkBigCoreVarTupTy env_ids let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr - fail_expr <- mkFailExpr ProcExpr env_stk_ty + fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty var <- selectSimpleMatchVarL Many pat - match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr + match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) @@ -367,7 +332,7 @@ let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExprNoLP arrow + core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg stack_id <- newSysLocalDs Many stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg @@ -423,7 +388,7 @@ (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd stack_id <- newSysLocalDs Many stack_ty - arg_id <- newSysLocalDsNoLP Many arg_ty + arg_id <- newSysLocalDs Many arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -628,11 +593,7 @@ -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty - (L loc stmts)) - env_ids = do - putSrcSpanDsA loc $ - dsNoLevPoly stmts_ty (LevityCheckDoCmd do_block) +dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -702,8 +663,7 @@ DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty (LevityCheckDesugaringCmd cmd) - ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } + = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) -- Feed back the list of local variables actually used a command, -- for use as the input tuple of the generated arrow. @@ -744,7 +704,7 @@ (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys + param_ids <- mapM (newSysLocalDs Many) pat_tys stack_id' <- newSysLocalDs Many stack_ty' -- the expression is built from the inside out, so the actions @@ -755,9 +715,9 @@ in_ty = envStackType env_ids stack_ty in_ty' = envStackType env_ids' stack_ty' - fail_expr <- mkFailExpr LambdaExpr in_ty' + fail_expr <- mkFailExpr (ArrowMatchCtxt KappaExpr) in_ty' -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr + match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr fail_expr -- match the parameters against the top of the old stack (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code @@ -790,8 +750,7 @@ -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDsA loc $ dsNoLevPoly res_ty (LevityCheckInCmd body) +dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids env_var <- newSysLocalDs Many env_ty @@ -859,7 +818,6 @@ out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty - dsNoLevPoly c_ty LevityCheckCmdStmt snd_fn <- mkSndExpr c_ty out_ty return (do_premap ids in_ty before_c_ty out_ty core_mux $ do_compose ids before_c_ty after_c_ty out_ty diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -1118,16 +1118,13 @@ ; return (w1 . w2) } -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc) - = do { x <- newSysLocalDsNoLP w t1 +dsHsWrapper (WpFun c1 c2 (Scaled w t1)) + = do { x <- newSysLocalDs w t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a arg = w1 (Var x) - ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg (LevityCheckWpFun doc) - ; if ok - then return (\e -> (Lam x (w2 (app e arg)))) - else return id } -- this return is irrelevant + ; return (\e -> (Lam x (w2 (app e arg)))) } dsHsWrapper (WpCast co) = assert (coercionRole co == Representational) $ return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -13,7 +13,7 @@ -} module GHC.HsToCore.Expr - ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds + ( dsExpr, dsLExpr, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr ) where @@ -30,7 +30,6 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.HsToCore.Errors.Types -import GHC.Hs.Syn.Type ( hsExprType, hsWrapperType ) import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env @@ -241,18 +240,6 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e --- | Variant of 'dsLExpr' that ensures that the result is not --- representation- polymorphic. This should be used when the resulting --- expression will be an argument to some other function. --- See Note [Representation polymorphism checking] in "GHC.HsToCore.Monad" --- See Note [Representation polymorphism invariants] in "GHC.Core" -dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (L loc e) - = putSrcSpanDsA loc $ - do { e' <- dsExpr e - ; dsNoLevPolyExpr e' (LevityCheckHsExpr e) - ; return e' } - dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar _ (L _ id)) = dsHsVar id dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id @@ -279,7 +266,7 @@ = case ext_expr_tc of ExpansionExpr (HsExpanded _ b) -> dsExpr b WrapExpr {} -> dsHsWrapped e - ConLikeTc {} -> dsHsWrapped e + ConLikeTc con tvs tys -> dsConLike con tvs tys -- Hpc Support HsTick tickish e -> do e' <- dsLExpr e @@ -320,10 +307,8 @@ dsExpr e@(HsApp _ fun arg) = do { fun' <- dsLExpr fun - -- See Note [Desugaring representation-polymorphic applications] - -- in GHC.HsToCore.Utils - ; dsWhenNoErrs (hsExprType e) (dsLExprNoLP arg) - (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } + ; arg' <- dsLExpr arg + ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' } dsExpr e@(HsAppType {}) = dsHsWrapped e @@ -345,32 +330,25 @@ converting to core it must become a CO. -} -dsExpr e@(ExplicitTuple _ tup_args boxity) +dsExpr (ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (Missing (Scaled mult ty)) -- For every missing expression, we need -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP mult ty + = do { lam_var <- newSysLocalDs mult ty ; return (lam_var : lam_vars, Var lam_var : args) } go (lam_vars, args) (Present _ expr) -- Expressions that are present don't generate -- lambdas, just arguments. - = do { core_expr <- dsLExprNoLP expr + = do { core_expr <- dsLExpr expr ; return (lam_vars, core_expr : args) } - -- See Note [Desugaring representation-polymorphic applications] - -- in GHC.HsToCore.Utils - ; dsWhenNoErrs (hsExprType e) (foldM go ([], []) (reverse tup_args)) + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) -- The reverse is because foldM goes left-to-right - (\(lam_vars, args) -> - mkCoreLams lam_vars $ - mkCoreTupBoxity boxity args) } + ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) } -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -dsExpr e@(ExplicitSum types alt arity expr) - -- See Note [Desugaring representation-polymorphic applications] - -- in GHC.HsToCore.Utils - = dsWhenNoErrs (hsExprType e) (dsLExprNoLP expr) - (mkCoreUbxSum arity alt types) +dsExpr (ExplicitSum types alt arity expr) + = mkCoreUbxSum arity alt types <$> dsLExpr expr dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -441,7 +419,7 @@ -} dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExprNoLP expr + expr_ds <- dsLExpr expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -495,8 +473,8 @@ mk_arg (arg_ty, fl) = case findField (rec_flds rbinds) (flSelector fl) of - (rhs:rhss) -> assert (null rhss ) - dsLExprNoLP rhs + (rhs:rhss) -> assert (null rhss) + dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty @@ -808,23 +786,7 @@ ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - -- We need to compute the type of the desugared expression without - -- actually performing the desugaring, which could be problematic - -- in the presence of representation polymorphism. - -- See Note [Desugaring representation-polymorphic applications] - -- in GHC.HsToCore.Utils - expr_type = hsWrapperType res_wrap - (applyTypeToArgs (ppr fun) (exprType fun) wrapped_args) - ; dsWhenNoErrs expr_type - (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ]) - (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } - -- Use mkCoreApps instead of mkApps: - -- unboxed types are possible with RebindableSyntax (#19883) - -- This won't be evaluated if there are any - -- representation-polymorphic arguments. - - where - mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr + ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] @@ -897,7 +859,7 @@ -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprNoLP xs + ; xs' <- mapM dsLExpr xs ; if xs' `lengthExceeds` maxBuildLength -- Don't generate builds if the list is very long. || null xs' @@ -913,25 +875,25 @@ dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExprNoLP from + = App <$> dsExpr expr <*> dsLExpr from dsArithSeq expr (FromTo from to) = do fam_envs <- dsGetFamInstEnvs dflags <- getDynFlags warnAboutEmptyEnumerations fam_envs dflags from Nothing to expr' <- dsExpr expr - from' <- dsLExprNoLP from - to' <- dsLExprNoLP to + from' <- dsLExpr from + to' <- dsLExpr to return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsArithSeq expr (FromThenTo from thn to) = do fam_envs <- dsGetFamInstEnvs dflags <- getDynFlags warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to expr' <- dsExpr expr - from' <- dsLExprNoLP from - thn' <- dsLExprNoLP thn - to' <- dsLExprNoLP to + from' <- dsLExpr from + thn' <- dsLExpr thn + to' <- dsLExpr to return $ mkApps expr' [from', thn', to'] {- @@ -1057,8 +1019,7 @@ -- NB: withDict is always instantiated by a wrapper, so we need -- only check for it in dsHsUnwrapped dsHsVar var - = do { checkLevPolyFunction var var (idType var) - ; return (varToCoreExpr var) } -- See Note [Desugaring vars] + = return (varToCoreExpr var) -- See Note [Desugaring vars] dsHsConLike :: ConLike -> DsM CoreExpr dsHsConLike (RealDataCon dc) @@ -1131,112 +1092,13 @@ {- ************************************************************************ * * - Representation polymorphism checks + dsHsWrapped and ds_withDict * * ************************************************************************ - -Note [Checking for representation-polymorphic functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have representation-polymorphic function arguments. See -Note [Representation polymorphism invariants] in GHC.Core. That is -checked by dsLExprNoLP. - -But what about - const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b) - -Since `unsafeCoerce#` has no binding, it has a compulsory unfolding. -But that compulsory unfolding is a representation-polymorphic lambda, which -is no good. So we want to reject this. On the other hand - const True (unsafeCoerce# @LiftedRep @UnliftedRep) -is absolutely fine. - -We have to collect all the type-instantiation and *then* check. That -is what dsHsWrapped does. Because we might have an HsVar without a -wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021 -triggers this case. - -Note that if `f :: forall r (a :: TYPE r). blah`, then - const True f -is absolutely fine. Here `f` is a function, represented by a -pointer, and we can pass it to `const` (or anything else). (See -#12708 for an example.) It's only the Id.hasNoBinding functions -that are a problem. See checkLevPolyFunction. - -Interestingly, this approach does not look to see whether the Id in -question will be eta expanded. The logic is this: - * Either the Id in question is saturated or not. - * If it is, then it surely can't have representation-polymorphic arguments. - If its wrapped type contains representation-polymorphic arguments, reject. - * If it's not, then it can't be eta expanded with representation-polymorphic - argument. If its wrapped type contains representation-polymorphic arguments, - reject. -So, either way, we're good to reject. - -Note [Nasty wrinkle in representation-polymorphic function check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A nasty wrinkle came up in T13244 - type family Rep x - type instance Rep Int = IntRep - - type Unboxed x :: TYPE (Rep x) - type instance Unboxed Int = Int# - - box :: Unboxed Int -> Int - box = I# - -Here the function I# is wrapped in a /cast/, thus - box = I# |> (co :: (Int# -> Int) ~ (Unboxed Int -> Int)) -If we look only at final type of the expression, - namely: Unboxed Int -> Int, -the kind of the argument type is TYPE (Rep Int), and that needs -type-family reduction to determine the runtime representation. - -So we split the wrapper into the instantiating part (which is what -we really want) and everything else; see splitWrapper. This is -very disgusting. - -But it also improves the error message in an example like T13233_elab: - obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep) - (a :: TYPE rep1) (b :: TYPE rep2). - a -> b -> (# a, b #)) -> () - obscure _ = () - - quux = obscure (#,#) - -Around the (#,#) we'll get some type /abstractions/ wrapping some type -/instantiations/. In the representation polymorphism error message, -we really only want to report the instantiations. -Hence passing (mkHsWrap w_inner e) to checkLevPolyArgs. - - -Note [Checking representation-polymorphic data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Similarly, generated by a newtype data constructor, we might get this: - (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4 - -which we want to accept. See Note [Typechecking data constructors] in -GHC.Tc.Gen.Head. - -Because we want to accept this, we switch off Lint's -representation polymorphism checks when Lint checks the output of the -desugarer; see the lf_check_levity_poly flag in -GHC.Core.Lint.lintCoreBindings. - -We can get this situation both for representation-polymorphic -newtype constructors (T18481), and for representation-polymorphic -algebraic data types, e.g (T18481a) - type T :: TYPE (BoxedRep r) -> TYPE (BoxedRep r) - data T a = MkT Int - - f :: T Bool - f = MkT @Lifted @Bool 42 -} ------------------------------ dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr --- Looks for a function 'f' wrapped in type applications (HsAppType) --- or wrappers (HsWrap), and checks that any hasNoBinding function --- is not representation-polymorphic, *after* instantiation with those wrappers dsHsWrapped orig_hs_expr = go idHsWrapper orig_hs_expr where @@ -1247,31 +1109,18 @@ go wrap (HsAppType ty (L _ hs_e) _) = go (wrap <.> WpTyApp ty) hs_e - go wrap e@(XExpr (ConLikeTc con tvs tys)) - = do { let (w_outer, w_inner) = splitWrapper wrap - ; w_outer' <- dsHsWrapper w_outer - ; w_inner' <- dsHsWrapper w_inner - ; ds_con <- dsConLike con tvs tys - ; let inst_e = w_inner' ds_con - inst_ty = exprType inst_e - ; checkLevPolyArgs (mkHsWrap w_inner e) inst_ty - ; return (w_outer' inst_e) } - - go wrap e@(HsVar _ (L _ var)) + go wrap (HsVar _ (L _ var)) | var `hasKey` withDictKey = do { wrap' <- dsHsWrapper wrap ; ds_withDict (exprType (wrap' (varToCoreExpr var))) } | otherwise - = do { let (w_outer, w_inner) = splitWrapper wrap - ; w_outer' <- dsHsWrapper w_outer - ; w_inner' <- dsHsWrapper w_inner - ; let inst_e = w_inner' (varToCoreExpr var) - inst_ty = exprType inst_e - ; checkLevPolyFunction (mkHsWrap w_inner e) var inst_ty + = do { wrap' <- dsHsWrapper wrap + ; let expr = wrap' (varToCoreExpr var) + ty = exprType expr ; dflags <- getDynFlags - ; warnAboutIdentities dflags var inst_ty - ; return (w_outer' inst_e) } + ; warnAboutIdentities dflags var ty + ; return expr } go wrap hs_e = do { wrap' <- dsHsWrapper wrap @@ -1279,32 +1128,6 @@ do { e <- dsExpr hs_e ; return (wrap' e) } } -splitWrapper :: HsWrapper -> (HsWrapper, HsWrapper) --- Split a wrapper w into (outer_wrap <.> inner_wrap), where --- inner_wrap does instantiation (type and evidence application) --- and outer_wrap is everything else, such as a final cast --- See Note [Nasty wrinkle in representation-polymorphic function check] -splitWrapper wrap - = go WpHole wrap - where - go :: HsWrapper -> HsWrapper -> (HsWrapper, HsWrapper) - -- If (go w1 w2) = (w3,w4) then - -- - w1 <.> w2 = w3 <.> w4 - -- - w4 does instantiation only ("instantiator" below) - -- 'go' mainly dispatches on w2, using w1 as a work-list - -- onto which it pushes stuff in w2 to come back to later - go WpHole WpHole = (WpHole,WpHole) - go w WpHole = splitWrapper w - go w1 (w2 `WpCompose` w3) = go (w1 <.> w2) w3 - - go w1 w2 | instantiator w2 = liftSnd (<.> w2) (splitWrapper w1) - | otherwise = (w1 <.> w2, WpHole) - - instantiator (WpTyApp {}) = True - instantiator (WpEvApp {}) = True - instantiator _ = False - - -- See Note [withDict] ds_withDict :: Type -> DsM CoreExpr ds_withDict wrapped_ty @@ -1456,30 +1279,3 @@ error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold is set up. -} - --- | Takes a (pretty-printed) expression, a function, and its --- instantiated type. If the function is a hasNoBinding op, and the --- type has representation-polymorphic arguments, issue an error. --- Note [Checking for representation-polymorphic functions] -checkLevPolyFunction :: Outputable e => e -> Id -> Type -> DsM () -checkLevPolyFunction orig_hs_expr var ty - | hasNoBinding var - = checkLevPolyArgs orig_hs_expr ty - | otherwise - = return () - -checkLevPolyArgs :: Outputable e => e -> Type -> DsM () --- Check that there are no representation-polymorphic arguments in --- the supplied type --- E.g. Given (forall a. t1 -> t2 -> blah), ensure that t1,t2 --- are not representation-polymorhic --- --- Pass orig_hs_expr, so that the user can see entire thing --- Note [Checking for representation-polymorphic functions] -checkLevPolyArgs orig_hs_expr ty - | let (binders, _) = splitPiTys ty - arg_tys = mapMaybe binderRelevantType_maybe binders - bad_tys = filter isTypeLevPoly arg_tys - , not (null bad_tys) - = diagnosticDs $ DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys - | otherwise = return () diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot --- a/compiler/GHC/HsToCore/Expr.hs-boot +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -5,6 +5,6 @@ import GHC.Hs.Extension ( GhcTc) dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -13,10 +13,9 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) import GHC.Hs -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Hs.Syn.Type import GHC.Core import GHC.Core.Make @@ -139,8 +138,6 @@ , Var unzip_fn' , inner_list_expr' ] - dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) (LevityCheckInFunUse using) - -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! @@ -240,7 +237,7 @@ deBindComp pat inner_list_expr quals list deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExprNoLP list1 + core_list1 <- dsLExpr list1 deBindComp pat core_list1 quals core_list2 deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list @@ -328,7 +325,7 @@ dfListComp c_id n_id (LastStmt _ body _ _ : quals) = assert (null quals) $ - do { core_body <- dsLExprNoLP body + do { core_body <- dsLExpr body ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard @@ -549,7 +546,7 @@ ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDsNoLP Many n_tup_ty' + ; n_tup_var' <- newSysLocalDs Many n_tup_ty' ; tup_n_var' <- newSysLocalDs Many tup_n_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -750,7 +750,7 @@ ; locn <- getSrcSpanDs ; new_vars <- case matches of - [] -> newSysLocalsDsNoLP arg_tys + [] -> newSysLocalsDs arg_tys (m:_) -> selectMatchVars (zipWithEqual "matchWrapper" (\a b -> (scaledMult a, unLoc b)) @@ -1117,7 +1117,7 @@ -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2' wrap (WpCast co) (WpCast co') = co `eqCoercion` co' wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 wrap (WpTyApp t) (WpTyApp t') = eqType t t' diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -245,10 +245,11 @@ ----------------- selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys con = case con of - (RecCon {}) -> newSysLocalsDsNoLP arg_tys - (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps) - (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2]) +selectConMatchVars arg_tys con + = case con of + RecCon {} -> newSysLocalsDs arg_tys + PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps) + InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2]) where zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -19,8 +19,8 @@ foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, Applicative(..),(<$>), - duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, - newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, + duplicateLocalDs, newSysLocalDs, + newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, mkPrintUnqualifiedDs, @@ -42,15 +42,11 @@ -- Warnings and errors DsWarning, diagnosticDs, errDsCoreExpr, failWithDs, failDs, discardWarningsDs, - askNoErrsDs, -- Data types DsMatchContext(..), EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, - -- Representation polymorphism - dsNoLevPoly, dsNoLevPolyExpr, - -- Trace injection pprRuntimeTrace ) where @@ -71,7 +67,7 @@ import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make ( unitExpr ) -import GHC.Core.Utils ( exprType, isExprLevPoly ) +import GHC.Core.Utils ( exprType ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon @@ -80,9 +76,7 @@ import GHC.IfaceToCore -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType ( checkForLevPolyX ) import GHC.Builtin.Names @@ -371,56 +365,11 @@ functions are defined with it. The difference in name-strings makes it easier to read debugging output. -Note [Representation polymorphism checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the "Levity Polymorphism" paper (PLDI '17), -representation polymorphism is forbidden in precisely two places: -in the type of a bound term-level argument, and in the type of an argument -to a function. -Note that the paper doesn't distinguish levity polymorphism, such as - \(v::Levity). \(a::TYPE (BoxedRep v)). \(x::a). expr -from the more general representation polymorphism, as the BoxedRep -constructor of RuntimeRep didn't exist at the time. - -The paper explains the restrictions more fully, but briefly: -expressions in these contexts need to be stored in registers, and it's -hard (read: impossible) to store something that's representation-polymorphic. - -We cannot check for bad representation polymorphism conveniently -in the type checker, because we can't tell, a priori, which -representation metavariables will be solved. -At one point, I (Richard) thought we could check in the zonker, but it's hard -to know where precisely are the abstracted variables and the arguments. So -we check in the desugarer, the only place where we can see the Core code and -still report respectable syntax to the user. This covers the vast majority -of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends. - -Representation polymorphism is also prohibited in the types of binders, and the -desugarer checks for this in GHC-generated Ids. (The zonker handles -the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. -The newSysLocalDs variant is used in the vast majority of cases where -the binder is obviously not representation-polymorphic, omitting the check. -It would be nice to ASSERT that there is no representation polymorphism here, -but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though: -Core Lint will catch an error here. - -However, the desugarer is the wrong place for certain checks. In particular, -the desugarer can't report a sensible error message if an HsWrapper is malformed. -After all, GHC itself produced the HsWrapper. So we store some message text -in the appropriate HsWrappers (e.g. WpFun) that we can print out in the -desugarer. - -There are a few more checks in places where Core is generated outside the -desugarer. For example, in datatype and class declarations, where -representation polymorphism is checked for during validity checking. -It would be nice to have one central place for all this, but that doesn't -seem possible while still reporting nice error messages. - -} -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Mult -> Type -> DsM Id -newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) +newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local @@ -431,27 +380,13 @@ newPredVarDs = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id -newSysLocalDsNoLP = mk_local (fsLit "ds") - --- this variant should be used when the caller can be sure that the variable type --- is not representation-polymorphic. It is necessary when the type --- is knot-tied because of the fixM used in GHC.HsToCore.Arrows. --- See Note [Representation polymorphism checking] +newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail") - -- the fail variable is used only in a situation where we can tell that - -- representation polymorphism is impossible. -newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id] -newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t) +newSysLocalsDs :: [Scaled Type] -> DsM [Id] newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) -mk_local :: FastString -> Mult -> Type -> DsM Id -mk_local fs w ty = do { dsNoLevPoly ty LevityCheckInVarType -- could improve the msg with another - -- parameter indicating context - ; mkSysLocalOrCoVarM fs w ty } - {- We can also reach out and either set/grab location information from the @SrcSpan@ being carried around. @@ -508,36 +443,6 @@ failDs :: DsM a failDs = failM --- (askNoErrsDs m) runs m --- If m fails, --- then (askNoErrsDs m) fails --- If m succeeds with result r, --- then (askNoErrsDs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- Regardless of success or failure, --- propagate any errors/warnings generated by m --- --- c.f. GHC.Tc.Utils.Monad.askNoErrs -askNoErrsDs :: DsM a -> DsM (a, Bool) -askNoErrsDs thing_inside - = do { errs_var <- newMutVar emptyMessages - ; env <- getGblEnv - ; mb_res <- tryM $ -- Be careful to catch exceptions - -- so that we propagate errors correctly - -- (#13642) - setGblEnv (env { ds_msgs = errs_var }) $ - thing_inside - - -- Propagate errors - ; msgs <- readMutVar errs_var - ; updMutVar (ds_msgs env) (unionMessages msgs) - - -- And return - ; case mb_res of - Left _ -> failM - Right res -> do { let errs_found = errorsFound msgs - ; return (res, not errs_found) } } - mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv @@ -602,20 +507,6 @@ ; writeTcRef (ds_msgs env) old_msgs ; return result } - --- | Fail with an error message if the type is representation-polymorphic. -dsNoLevPoly :: Type -> LevityCheckProvenance -> DsM () --- See Note [Representation polymorphism checking] -dsNoLevPoly ty provenance = - checkForLevPolyX (\ty -> diagnosticDs . DsLevityPolyInType ty) provenance ty - --- | Check an expression for representation polymorphism, failing if it is --- representation-polymorphic. -dsNoLevPolyExpr :: CoreExpr -> LevityExprProvenance -> DsM () --- See Note [Representation polymorphism checking] -dsNoLevPolyExpr e provenance - | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance) - | otherwise = return () -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Utility module for the pattern-match coverage checker. @@ -87,7 +88,7 @@ exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing @@ -95,6 +96,12 @@ -- Don't warn about incomplete patterns in list comprehensions, pattern guards -- etc. They are often *supposed* to be incomplete exhaustiveWarningFlag (StmtCtxt {}) = Nothing + +arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag +arrowMatchContextExhaustiveWarningFlag = \ case + ProcExpr -> Just Opt_WarnIncompleteUniPatterns + ArrowCaseAlt -> Just Opt_WarnIncompletePatterns + KappaExpr -> Just Opt_WarnIncompleteUniPatterns -- | Check whether any part of pattern match checking is enabled for this -- 'HsMatchContext' (does not matter whether it is the redundancy check or the diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -30,7 +30,7 @@ wrapBind, wrapBinds, mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - mkFailExpr, dsWhenNoErrs, + mkFailExpr, seqVar, @@ -132,10 +132,10 @@ selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name -selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) -selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat) -selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) +selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -- -- Remark: when the pattern is a variable (or @@ -144,7 +144,7 @@ -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var)) -selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat) +selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -739,7 +739,7 @@ | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP Many pat_ty + ; val_var <- newSysLocalDs Many pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } @@ -981,69 +981,6 @@ mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx <+> text "at" <+> ppr (getLocA pat) - -{- Note [Desugaring representation-polymorphic applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To desugar a function application - -> HsApp _ f e :: HsExpr GhcTc - -into Core, we need to know whether the argument e is lifted or unlifted, -in order to respect the let/app invariant. - (See Note [Core let/app invariant] in GHC.Core) - -This causes a problem when e is representation-polymorphic, as we aren't able -to determine whether to build a Core application - -> f_desugared e_desugared - -or a strict binding: - -> case e_desugared of { x -> f_desugared x } - -See GHC.Core.Make.mkValApp, which will call isUnliftedType, which panics -on a representation-polymorphic type. - -These representation-polymorphic applications are disallowed in source Haskell, -but we might want to continue desugaring as much as possible instead of -aborting as soon as we see such a problematic function application. - -When desugaring an expression which might have problems (such as disallowed -representation polymorphism as above), we check for errors first, and then: - - - if no problems were detected, desugar normally, - - if errors were found, we want to avoid desugaring, so we instead return - a runtime error Core expression which has the right type. - -This is what the function dsWhenNoErrs achieves: - -> dsWhenNoErrs result_ty thing_inside mk_expr - -We run thing_inside to check for errors. If there are no errors, we apply -mk_expr to desugar; otherwise, we construct a runtime error at type result_ty. - -Note that result_ty is only used when there is an error, and isn't inspected -otherwise; this means it's OK to pass something that can be a bit expensive -to compute. - -See #12709 for an example of why this machinery is necessary. -See also #14765 and #18149 for why it is important to return an expression -that has the proper type in case of an error. --} - --- | Runs the thing_inside. If there are no errors, use the provided --- function to construct a Core expression, and return it. --- Otherwise, return a runtime error, of the given type. --- This is useful for doing a bunch of representation polymorphism checks --- and then avoiding making a Core App. --- See Note [Desugaring representation-polymorphic applications] -dsWhenNoErrs :: Type -> DsM a -> (a -> CoreExpr) -> DsM CoreExpr -dsWhenNoErrs result_ty thing_inside mk_expr - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; if no_errs - then return $ mk_expr result - else mkErrorAppDs rUNTIME_ERROR_ID result_ty - (text "dsWhenNoErrs found errors") } {- ********************************************************************* * * diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -396,8 +396,7 @@ getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan - , Data (HsLocalBinds (GhcPass p))) +grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs) @@ -589,8 +588,8 @@ instance (ToHie a) => ToHie (Maybe a) where toHie = maybe (pure []) toHie -instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span _) mname)) = do +instance ToHie (IEContext (LocatedA ModuleName)) where + toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do org <- ask pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] where details = mempty{identInfo = S.singleton (IEThing c)} @@ -681,7 +680,7 @@ (WpLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs) (WpCompose a b) -> concatM $ [toHie (L osp a), toHie (L osp b)] - (WpFun a b _ _) -> concatM $ + (WpFun a b _) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpEvLam a) -> toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp)) @@ -781,8 +780,8 @@ HieRn :: HiePassEv 'Renamed HieTc :: HiePassEv 'Typechecked -class ( IsPass p - , HiePass (NoGhcTcPass p) +class ( HiePass (NoGhcTcPass p) + , NoGhcTcPass p ~ 'Renamed , ModifyState (IdGhcP p) , Data (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) @@ -800,10 +799,6 @@ , Data (HsTupArg (GhcPass p)) , Data (IPBind (GhcPass p)) , ToHie (Context (Located (IdGhcP p))) - , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) - , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) - , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) - , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) , Anno (IdGhcP p) ~ SrcSpanAnnN ) => HiePass p where @@ -830,8 +825,6 @@ , Data (Match (GhcPass p) (LocatedA (body (GhcPass p)))) , Data (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) , Data (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))) - - , IsPass p ) instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where @@ -920,17 +913,13 @@ , AnnoBody p body , ToHie (LocatedA (body (GhcPass p))) ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where - toHie (L span m ) = concatM $ node : case m of + toHie (L span m ) = concatM $ makeNodeA m span : case m of Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> [ toHie mctx , let rhsScope = mkScope $ grhss_span grhss in toHie $ patScopes Nothing rhsScope NoScope pats , toHie grhss ] - where - node = case hiePass @p of - HieTc -> makeNodeA m span - HieRn -> makeNodeA m span instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name' @@ -1035,8 +1024,8 @@ ] ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] where - contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a) - -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a) + -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args) where argscope = foldr combineScopes NoScope $ map mkLScopeA args contextify (InfixCon a b) = InfixCon a' b' @@ -1071,15 +1060,11 @@ , HiePass p , AnnoBody p body ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where - toHie (L span g) = concatM $ node : case g of + toHie (L span g) = concatM $ makeNode g span : case g of GRHS _ guards body -> [ toHie $ listScopes (mkLScopeA body) guards , toHie body ] - where - node = case hiePass @p of - HieRn -> makeNode g span - HieTc -> makeNode g span instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of @@ -1207,7 +1192,7 @@ HsGetField {} -> [] HsProjection {} -> [] XExpr x - | GhcTc <- ghcPass @p + | HieTc <- hiePass @p -> case x of WrapExpr (HsWrap w a) -> [ toHie $ L mspan a @@ -1349,34 +1334,23 @@ , toHie expr ] -instance ToHie (RFContext (Located (FieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> - [ toHie $ C (RecField c rhs) (L nspan name) - ] - -instance ToHie (RFContext (Located (FieldOcc GhcTc))) where +instance HiePass p => ToHie (RFContext (Located (FieldOcc (GhcPass p)))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous name _ -> - [ toHie $ C (RecField c rhs) $ L nspan name - ] - Ambiguous _name _ -> - [ ] + FieldOcc fld _ -> + case hiePass @p of + HieRn -> [toHie $ C (RecField c rhs) (L nspan fld)] + HieTc -> [toHie $ C (RecField c rhs) (L nspan fld)] -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where +instance HiePass p => ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - Ambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] + Unambiguous fld _ -> + case hiePass @p of + HieRn -> [toHie $ C (RecField c rhs) $ L nspan fld] + HieTc -> [toHie $ C (RecField c rhs) $ L nspan fld] + Ambiguous fld _ -> + case hiePass @p of + HieRn -> [] + HieTc -> [ toHie $ C (RecField c rhs) (L nspan fld) ] instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM @@ -1914,12 +1888,11 @@ ] HsSpliced _ _ _ -> [] - XSplice x -> case ghcPass @p of + XSplice x -> case hiePass @p of #if __GLASGOW_HASKELL__ < 811 - GhcPs -> noExtCon x - GhcRn -> noExtCon x + HieRn -> noExtCon x #endif - GhcTc -> case x of + HieTc -> case x of HsSplicedT _ -> [] instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -155,6 +155,7 @@ -- | Roughly isomorphic to the original core 'Type'. newtype HieTypeFix = Roll (HieType (HieTypeFix)) + deriving Eq instance Binary (HieType TypeIndex) where put_ bh (HTyVarTy n) = do diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} -- | Loading interface files module GHC.Iface.Load ( @@ -47,7 +48,6 @@ import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.Session -import GHC.Driver.Backend import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -98,6 +98,7 @@ import GHC.Types.Unique.DSet import GHC.Types.SrcLoc import GHC.Types.TyThing +import GHC.Types.PkgQual import GHC.Unit.External import GHC.Unit.Module @@ -111,7 +112,6 @@ import GHC.Unit.Env ( ue_hpt ) import GHC.Data.Maybe -import GHC.Data.FastString import Control.Monad import Data.Map ( toList ) @@ -295,7 +295,7 @@ loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any + -> PkgQual -- "package", if any -> RnM ModIface loadSrcInterface doc mod want_boot maybe_pkg @@ -308,7 +308,7 @@ loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? - -> Maybe FastString -- "package", if any + -> PkgQual -- "package", if any -> RnM (MaybeErr SDoc ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg @@ -629,37 +629,51 @@ home-package modules however, so it's safe for the HPT to be empty. -} +-- Note [GHC Heap Invariants] dontLeakTheHPT :: IfL a -> IfL a dontLeakTheHPT thing_inside = do + env <- getTopEnv let + inOneShot = + isOneShot (ghcMode (hsc_dflags env)) + cleanGblEnv gbl_env + | inOneShot = gbl_env + | otherwise = gbl_env { if_rec_types = emptyKnotVars } cleanTopEnv hsc_env = + let + !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env) + | otherwise = Nothing -- wrinkle: when we're typechecking in --backpack mode, the -- instantiation of a signature might reside in the HPT, so -- this case breaks the assumption that EPS interfaces only - -- refer to other EPS interfaces. We can detect when we're in - -- typechecking-only mode by using backend==NoBackend, and - -- in that case we don't empty the HPT. (admittedly this is - -- a bit of a hack, better suggestions welcome). A number of - -- tests in testsuite/tests/backpack break without this + -- refer to other EPS interfaces. + -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it + -- contains any hole modules. + -- Quite a few tests in testsuite/tests/backpack break without this -- tweak. old_unit_env = hsc_unit_env hsc_env + keepFor20509 hmi + | isHoleModule (mi_semantic_module (hm_iface hmi)) = True + | otherwise = False !unit_env - | NoBackend <- backend (hsc_dflags hsc_env) = old_unit_env - | otherwise - = old_unit_env - { ue_hpt = emptyHomePackageTable + { ue_hpt = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_hpt old_unit_env + else emptyHomePackageTable } in hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" , hsc_IC = panic "cleanTopEnv: hsc_IC" + , hsc_type_env_vars = case maybe_type_vars of + Just vars -> vars + Nothing -> panic "cleanTopEnv: hsc_type_env_vars" , hsc_unit_env = unit_env } - updTopEnv cleanTopEnv $ do + updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do !_ <- getTopEnv -- force the updTopEnv + !_ <- getGblEnv thing_inside @@ -887,23 +901,24 @@ -- Look for the file mb_found <- liftIO (findExactModule fc fopts unit_state home_unit mod) case mb_found of - InstalledFound loc mod -> do - -- Found file, so read it - let file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do -- See Note [Home module load error] if isHomeInstalledModule home_unit mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do - r <- read_file logger name_cache unit_state dflags wanted_mod file_path + r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of Failed _ - -> return () - Succeeded (iface,fp) - -> load_dynamic_too_maybe logger name_cache unit_state - dflags wanted_mod - hi_boot_file iface fp - return r + -> return r + Succeeded (iface,_fp) + -> do + r2 <- load_dynamic_too_maybe logger name_cache unit_state + (setDynamicNow dflags) wanted_mod + iface loc + case r2 of + Failed sdoc -> return (Failed sdoc) + Succeeded {} -> return r err -> do trace_if logger (text "...not found") return $ Failed $ cannotFindInterface @@ -915,30 +930,32 @@ err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO () -load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod is_boot iface file_path +load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. - | not (moduleIsDefinite (mi_module iface)) = return () - | otherwise = dynamicTooState dflags >>= \case - DT_Dont -> return () - DT_Failed -> return () - DT_Dyn -> load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path - DT_OK -> load_dynamic_too logger name_cache unit_state (setDynamicNow dflags) wanted_mod is_boot iface file_path + | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) + | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc + | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO () -load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path = do - let dynFilePath = addBootSuffix_maybe is_boot - $ replaceExtension file_path (hiSuf dflags) - read_file logger name_cache unit_state dflags wanted_mod dynFilePath >>= \case +load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do + read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) - -> return () + -> return (Succeeded ()) | otherwise -> - do trace_if logger (text "Dynamic hash doesn't match") - setDynamicTooFailed dflags + do return $ (Failed $ dynamicHashMismatchError wanted_mod loc) Failed err -> - do trace_if logger (text "Failed to load dynamic interface file:" $$ err) - setDynamicTooFailed dflags + do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) + + +dynamicHashMismatchError :: Module -> ModLocation -> SDoc +dynamicHashMismatchError wanted_mod loc = + vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) + , text "Normal interface file from" <+> text (ml_hi_file loc) + , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) + , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] + read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -152,6 +152,8 @@ | MissingBytecode | MissingObjectFile | MissingDynObjectFile + | MissingDynHiFile + | MismatchedDynHiFile deriving (Eq) instance Outputable RecompReason where @@ -180,6 +182,8 @@ MissingBytecode -> text "Missing bytecode" MissingObjectFile -> text "Missing object file" MissingDynObjectFile -> text "Missing dynamic object file" + MissingDynHiFile -> text "Missing dynamic interface file" + MismatchedDynHiFile -> text "Mismatched dynamic interface file" recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False @@ -227,12 +231,11 @@ trace_if logger (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) return maybe_iface - Nothing -> loadIface + Nothing -> loadIface dflags (msHiFilePath mod_summary) - loadIface = do - let iface_path = msHiFilePath mod_summary + loadIface read_dflags iface_path = do let ncu = hsc_NC hsc_env - read_result <- readIface dflags ncu (ms_mod mod_summary) iface_path + read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) @@ -241,7 +244,24 @@ Succeeded iface -> do trace_if logger (text "Read the interface file" <+> text iface_path) return $ Just iface + check_dyn_hi :: ModIface + -> IfG (RecompileRequired, Maybe a) + -> IfG (RecompileRequired, Maybe a) + check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do + res <- recomp_check + case fst res of + UpToDate -> do + maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary) + case maybe_dyn_iface of + Nothing -> return (RecompBecause MissingDynHiFile, Nothing) + Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface) + /= mi_iface_hash (mi_final_exts normal_iface) + -> return (RecompBecause MismatchedDynHiFile, Nothing) + Just {} -> return res + _ -> return res + check_dyn_hi _ recomp_check = recomp_check + src_changed | gopt Opt_ForceRecomp dflags = True | otherwise = False @@ -273,7 +293,7 @@ -- should check versions because some packages -- might have changed or gone away. Just iface -> - checkVersions hsc_env mod_summary iface + check_dyn_hi iface $ checkVersions hsc_env mod_summary iface -- | Check if a module is still the same 'version'. -- @@ -531,8 +551,9 @@ home_unit = hsc_home_unit hsc_env units = hsc_units hsc_env prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (dep_direct_pkgs (mi_deps iface)) - bkpk_units = map (("Signature",) . indefUnit . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) + prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) + bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) @@ -1540,10 +1561,17 @@ -- Kind of a heinous hack. initIfaceLoad hsc_env . withException ctx $ withoutDynamicNow - -- For some unknown reason, we need to reset the - -- dynamicNow bit, otherwise only dynamic - -- interfaces are looked up and some tests fail - -- (e.g. T16219). + -- If you try and load interfaces when dynamic-too + -- enabled then it attempts to load the dyn_hi and hi + -- interface files. Backpack doesn't really care about + -- dynamic object files as it isn't doing any code + -- generation so -dynamic-too is turned off. + -- Some tests fail without doing this (such as T16219), + -- but they fail because dyn_hi files are not found for + -- one of the dependencies (because they are deliberately turned off) + -- Why is this check turned off here? That is unclear but + -- just one of the many horrible hacks in the backpack + -- implementation. $ loadInterface (text "lookupVers2") mod ImportBySystem return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ)) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -238,7 +238,7 @@ -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) isAbstractIfaceDecl :: IfaceDecl -> Bool -isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon {} } = True isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True isAbstractIfaceDecl _ = False @@ -1035,11 +1035,17 @@ tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon tc_tybinders if_cons = case if_cons of - IfAbstractTyCon -> return AbstractTyCon - IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; mkNewTyConRhs tycon_name tycon data_con } + IfAbstractTyCon + -> return AbstractTyCon + IfDataTyCon cons + -> do { data_cons <- mapM tc_con_decl cons + ; return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind $ tyConResKind tycon) + data_cons } + IfNewTyCon con + -> do { data_con <- tc_con_decl con + ; mkNewTyConRhs tycon_name tycon data_con } where univ_tvs :: [TyVar] univ_tvs = binderVars tc_tybinders @@ -1661,7 +1667,7 @@ tcPrag info (HsDmdSig str) = return (info `setDmdSigInfo` str) tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) - tcPrag info HsLevity = return (info `setNeverLevPoly` ty) + tcPrag info HsLevity = return (info `setNeverRepPoly` ty) tcPrag info (HsLFInfo lf_info) = do lf_info <- tcLFInfo lf_info return (info `setLFInfo` lf_info) @@ -1909,13 +1915,15 @@ tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule --- Unlike CoAxioms, which arise form user 'type instance' declarations, --- there are a fixed set of CoAxiomRules, --- currently enumerated in typeNatCoAxiomRules +-- Unlike CoAxioms, which arise from user 'type instance' declarations, +-- there are a fixed set of CoAxiomRules: +-- - axioms for type-level literals (Nat and Symbol), +-- enumerated in typeNatCoAxiomRules tcIfaceCoAxiomRule n - = case lookupUFM typeNatCoAxiomRules n of - Just ax -> return ax - _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) + | Just ax <- lookupUFM typeNatCoAxiomRules n + = return ax + | otherwise + = pprPanic "tcIfaceCoAxiomRule" (ppr n) tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -44,7 +44,7 @@ = dflags0 verbFlags = getVerbFlags dflags - o_file = outputFile dflags + o_file = outputFile_ dflags pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -615,7 +615,7 @@ -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) - | objectSuf dflags == normalObjectSuffix && not (null targetFullWays) + | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays) = failNonStd dflags srcspan | otherwise = return (Just (hostWayTag ++ "o")) @@ -628,28 +628,42 @@ normalObjectSuffix :: String normalObjectSuffix = phaseInputExt StopLn +data Way' = Normal | Prof | Dyn + failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> compWay <+> - text "objects when GHC is built" <+> ghciWay $$ + text "Cannot load" <+> pprWay' compWay <+> + text "objects when GHC is built" <+> pprWay' ghciWay $$ text "To fix this, either:" $$ text " (1) Use -fexternal-interpreter, or" $$ - text " (2) Build the program twice: once" <+> - ghciWay <> text ", and then" $$ - text " with" <+> compWay <+> - text "using -osuf to set a different object file suffix." + buildTwiceMsg where compWay - | ways dflags `hasWay` WayDyn = text "-dynamic" - | ways dflags `hasWay` WayProf = text "-prof" - | otherwise = text "normal" + | ways dflags `hasWay` WayDyn = Dyn + | ways dflags `hasWay` WayProf = Prof + | otherwise = Normal ghciWay - | hostIsDynamic = text "with -dynamic" - | hostIsProfiled = text "with -prof" - | otherwise = text "the normal way" + | hostIsDynamic = Dyn + | hostIsProfiled = Prof + | otherwise = Normal + buildTwiceMsg = case (ghciWay, compWay) of + (Normal, Dyn) -> dynamicTooMsg + (Dyn, Normal) -> dynamicTooMsg + _ -> + text " (2) Build the program twice: once" <+> + pprWay' ghciWay <> text ", and then" $$ + text " " <> pprWay' compWay <+> + text "using -osuf to set a different object file suffix." + dynamicTooMsg = text " (2) Use -dynamic-too," <+> + text "and use -osuf and -dynosuf to set object file suffixes as needed." + pprWay' :: Way' -> SDoc + pprWay' way = text $ case way of + Normal -> "the normal way" + Prof -> "with -prof" + Dyn -> "with -dynamic" getLinkDeps :: HscEnv -> HomePackageTable -> LoaderState - -> Maybe FilePath -- replace object suffices? + -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -73,7 +73,7 @@ unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName platform staticLink (outputFile dflags) + output_fn = exeFileName platform staticLink (outputFile_ dflags) -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their @@ -277,7 +277,7 @@ let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs - output_fn = exeFileName platform True (outputFile dflags) + output_fn = exeFileName platform True (outputFile_ dflags) full_output_fn <- if isAbsolute output_fn then return output_fn diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -15,6 +15,7 @@ , module GHC.Types.Var , module GHC.Types.Id , module GHC.Types.Id.Info + , module GHC.Types.PkgQual , module GHC.Core.Opt.Monad , module GHC.Core , module GHC.Types.Literal @@ -29,6 +30,7 @@ , module GHC.Driver.Ppr , module GHC.Unit.State , module GHC.Unit.Module + , module GHC.Unit.Home , module GHC.Core.Type , module GHC.Core.TyCon , module GHC.Core.Coercion @@ -66,6 +68,7 @@ -- Variable naming import GHC.Types.TyThing +import GHC.Types.PkgQual import GHC.Types.SourceError import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) @@ -92,6 +95,7 @@ import GHC.Driver.Session import GHC.Unit.State +import GHC.Unit.Home import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModSummary diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -1220,13 +1220,16 @@ emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Empty list of alternatives in" <+> pp_ctxt) + hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt) 2 (text "Use EmptyCase to allow this") where - pp_ctxt = case ctxt of - CaseAlt -> text "case expression" - LambdaExpr -> text "\\case expression" - _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt + pp_ctxt :: HsMatchContext GhcRn -> SDoc + pp_ctxt c = case c of + CaseAlt -> text "case expression" + LambdaExpr -> text "\\case expression" + ArrowMatchCtxt ArrowCaseAlt -> text "case expression" + ArrowMatchCtxt KappaExpr -> text "kappa abstraction" + _ -> text "(unexpected)" <+> pprMatchContextNoun c {- ************************************************************************ diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -102,6 +102,8 @@ import Control.Arrow ( first ) import Data.Function import GHC.Types.FieldLabel +import GHC.Data.Bag +import GHC.Types.PkgQual {- ********************************************************* @@ -1568,7 +1570,7 @@ warnIfDeprecated :: GlobalRdrElt -> RnM () warnIfDeprecated gre@(GRE { gre_imp = iss }) - | (imp_spec : _) <- iss + | Just imp_spec <- headMaybe iss = do { dflags <- getDynFlags ; this_mod <- getModule ; when (wopt Opt_WarnWarningsDeprecations dflags && @@ -1689,7 +1691,7 @@ -- -fimplicit-import-qualified is used with a module that exports the same -- field name multiple times (see -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). - toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] } + toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is } is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } , is_item = ImpAll } -- If -fimplicit-import-qualified succeeded, the name must be qualified. @@ -1713,7 +1715,7 @@ , is_ghci , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] - = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing + = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual ; case res of Succeeded iface -> return [ gname diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -55,6 +55,7 @@ import GHC.Types.FieldLabel import GHC.Types.Fixity +import GHC.Types.Hint (suggestExtension) import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set @@ -553,7 +554,7 @@ rnExpr (HsProc x pat body) = newArrowScope $ - rnPat ProcExpr pat $ \ pat' -> do + rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do { (body',fvBody) <- rnCmdTop body ; return (HsProc x pat' body', fvBody) } @@ -798,7 +799,7 @@ ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } rnCmd (HsCmdLam _ matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches ; return (HsCmdLam noExtField matches', fvMatch) } rnCmd (HsCmdPar x lpar e rpar) @@ -807,12 +808,12 @@ rnCmd (HsCmdCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr - ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches ; return (HsCmdCase noExtField new_expr new_matches , e_fvs `plusFV` ms_fvs) } rnCmd (HsCmdLamCase x matches) - = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches ; return (HsCmdLamCase x new_matches, ms_fvs) } rnCmd (HsCmdIf _ _ p b1 b2) @@ -2361,6 +2362,8 @@ text "Empty statement group in parallel comprehension" emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ text "Empty statement group preceding 'group' or 'then'" +emptyErr ctxt@(HsDoStmt _) = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $ + text "Empty" <+> pprStmtContext ctxt emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ text "Empty" <+> pprStmtContext ctxt diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -25,6 +26,7 @@ findImportUsage, getMinimalImports, printMinimalImports, + renamePkgQual, renameRawPkgQual, ImportDeclUsage ) where @@ -73,12 +75,14 @@ import GHC.Types.HpcInfo import GHC.Types.Unique.FM import GHC.Types.Error +import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Unit.Env import GHC.Data.Maybe import GHC.Data.FastString @@ -95,6 +99,7 @@ import System.FilePath (()) import System.IO +import GHC.Data.Bag {- ************************************************************************ @@ -303,13 +308,15 @@ -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name - , ideclPkgQual = mb_pkg + , ideclPkgQual = raw_pkg_qual , ideclSource = want_boot, ideclSafe = mod_safe , ideclQualified = qual_style, ideclImplicit = implicit , ideclAs = as_mod, ideclHiding = imp_details }), import_reason) = setSrcSpanA loc $ do - when (isJust mb_pkg) $ do + case raw_pkg_qual of + NoRawPkgQual -> pure () + RawPkgQual _ -> do pkg_imports <- xoptM LangExt.PackageImports when (not pkg_imports) $ addErr packageImportErr @@ -320,6 +327,9 @@ let imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> import_reason + unit_env <- hsc_unit_env <$> getTopEnv + let pkg_qual = renameRawPkgQual unit_env raw_pkg_qual + -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid @@ -333,13 +343,13 @@ -- extend Provenance to support a local definition in a qualified location. -- For now, we don't support it, but see #10336 when (imp_mod_name == moduleName this_mod && - (case mb_pkg of -- If we have import "" M, then we should - -- check that "" is "this" (which is magic) - -- or the name of this_mod's package. Yurgh! - -- c.f. GHC.findModule, and #9997 - Nothing -> True - Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" || - fsToUnit pkg_fs == moduleUnit this_mod)) + (case pkg_qual of -- If we have import "" M, then we should + -- check that "" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and #9997 + NoPkgQual -> True + ThisPkg _ -> True + OtherPkg _ -> False)) (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ (text "A module cannot import itself:" <+> ppr imp_mod_name)) @@ -357,7 +367,7 @@ addDiagnostic msg - iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) + iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual -- Compiler sanity check: if the import didn't say -- {-# SOURCE #-} we should not get a hi-boot file @@ -426,13 +436,45 @@ -- Complain about -Wcompat-unqualified-imports violations. warnUnqualifiedImport decl iface - let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe' - , ideclHiding = new_imp_details - , ideclName = ideclName decl - , ideclAs = ideclAs decl }) + let new_imp_decl = ImportDecl + { ideclExt = noExtField + , ideclSourceSrc = ideclSourceSrc decl + , ideclName = ideclName decl + , ideclPkgQual = pkg_qual + , ideclSource = ideclSource decl + , ideclSafe = mod_safe' + , ideclQualified = ideclQualified decl + , ideclImplicit = ideclImplicit decl + , ideclAs = ideclAs decl + , ideclHiding = new_imp_details + } - return (new_imp_decl, gbl_env, imports, mi_hpc iface) + return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) + +-- | Rename raw package imports +renameRawPkgQual :: UnitEnv -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env = \case + NoRawPkgQual -> NoPkgQual + RawPkgQual p -> renamePkgQual unit_env (Just (sl_fs p)) + +-- | Rename raw package imports +renamePkgQual :: UnitEnv -> Maybe FastString -> PkgQual +renamePkgQual unit_env mb_pkg = case mb_pkg of + Nothing -> NoPkgQual + Just pkg_fs + | Just uid <- homeUnitId <$> ue_home_unit unit_env + , pkg_fs == fsLit "this" || pkg_fs == unitFS uid + -> ThisPkg uid + + | Just uid <- lookupPackageName (ue_units unit_env) (PackageName pkg_fs) + -> OtherPkg uid + + | otherwise + -> OtherPkg (UnitId pkg_fs) + -- not really correct as pkg_fs is unlikely to be a valid unit-id but + -- we will report the failure later... + -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit @@ -564,7 +606,7 @@ addDiagnosticAt loc msg where mod = mi_module iface - loc = getLoc $ ideclName decl + loc = getLocA $ ideclName decl is_qual = isImportDeclQualified (ideclQualified decl) has_import_list = @@ -652,7 +694,7 @@ -- See Note [GlobalRdrEnv shadowing] inBracket = isBrackStage stage - lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } + lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs } -- See Note [GlobalRdrEnv shadowing] lcl_env2 | inBracket = lcl_env_TH @@ -660,7 +702,7 @@ -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_names + rdr_env1 | want_shadowing = shadowNames rdr_env new_occs | otherwise = rdr_env lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs @@ -677,7 +719,7 @@ ; return (gbl_env', lcl_env3) } where new_names = concatMap availGreNames avails - new_occs = map occName new_names + new_occs = occSetToEnv (mkOccSet (map occName new_names)) -- If there is a fixity decl for the gre, add it to the fixity env extend_fix_env fix_env gre @@ -1769,7 +1811,7 @@ RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map UnhelpfulLoc _ -> imp_map where - best_imp_spec = bestImport imp_specs + best_imp_spec = bestImport (bagToList imp_specs) add _ gres = gre : gres warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) @@ -1870,8 +1912,8 @@ | otherwise = do { let ImportDecl { ideclName = L _ mod_name , ideclSource = is_boot - , ideclPkgQual = mb_pkg } = decl - ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) + , ideclPkgQual = pkg_qual } = decl + ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual ; let used_avails = gresToAvailInfo used_gres lies = map (L l) (concatMap (to_ie iface) used_avails) ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) } diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -50,6 +50,7 @@ import Data.List (sortBy, partition, nub) import Data.Function ( on ) +import GHC.Data.Bag {- ************************************************************************ @@ -263,7 +264,7 @@ unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) | lcl = [ Left (greDefinitionSrcSpan gre) ] | otherwise = [ Right ispec - | i <- is, let ispec = is_decl i + | i <- bagToList is, let ispec = is_decl i , not (is_qual ispec) ] @@ -272,7 +273,7 @@ -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) - | i <- is, let ispec = is_decl i, is_qual ispec ] + | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor @@ -422,7 +423,7 @@ Nothing -> [] Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] | otherwise = [ (is_as ispec, Right ispec) - | i <- is, let ispec = is_decl i ] + | i <- bagToList is, let ispec = is_decl i ] isGreOk :: LookingFor -> GlobalRdrElt -> Bool isGreOk (LF what_look where_look) gre = what_ok && where_ok diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -65,6 +65,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Bag {- ********************************************************* @@ -566,7 +567,7 @@ pp_qual name | lcl = ppr (nameModule name) - | imp : _ <- iss -- This 'imp' is the one that + | Just imp <- headMaybe iss -- This 'imp' is the one that -- pprNameProvenance chooses , ImpDeclSpec { is_as = mod } <- is_decl imp = ppr mod diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -81,7 +81,6 @@ import GHC.Tc.Types.Origin import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) -import GHC.Builtin.Types ( isCTupleTyConName ) import GHC.Data.Maybe import GHC.Data.FastString @@ -107,6 +106,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Types.TyThing +import GHC.Types.BreakInfo import GHC.Unit import GHC.Unit.Module.Graph @@ -233,7 +233,7 @@ evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env - bindings = (ic_tythings ic, ic_rn_gbl_env ic) + bindings = (ic_tythings ic, ic_gre_cache ic) size = ghciHistSize idflags' @@ -310,7 +310,9 @@ emptyHistory size = nilBL size handleRunStatus :: GhcMonad m - => SingleStep -> String -> ([TyThing],GlobalRdrEnv) -> [Id] + => SingleStep -> String + -> ResumeBindings + -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> BoundedList History -> m ExecResult @@ -418,9 +420,9 @@ -- unbind the temporary locals by restoring the TypeEnv from -- before the breakpoint, and drop this Resume from the -- InteractiveContext. - let (resume_tmp_te,resume_rdr_env) = resumeBindings r + let (resume_tmp_te,resume_gre_cache) = resumeBindings r ic' = ic { ic_tythings = resume_tmp_te, - ic_rn_gbl_env = resume_rdr_env, + ic_gre_cache = resume_gre_cache, ic_resume = rs } setSession hsc_env{ hsc_IC = ic' } @@ -773,7 +775,7 @@ -- -- (setContext imports) sets the ic_imports field (which in turn -- determines what is in scope at the prompt) to 'imports', and --- constructs the ic_rn_glb_env environment to reflect it. +-- updates the icReaderEnv environment to reflect it. -- -- We retain in scope all the things defined at the prompt, and kept -- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) @@ -788,10 +790,10 @@ liftIO $ throwGhcExceptionIO (formatError dflags mod err) Right all_env -> do { ; let old_ic = hsc_IC hsc_env - !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic + !final_gre_cache = ic_gre_cache old_ic `replaceImportEnv` all_env ; setSession - hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}}} + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_gre_cache = final_gre_cache }}}} where formatError dflags mod err = ProgramError . showSDoc dflags $ text "Cannot add module" <+> ppr mod <+> @@ -856,7 +858,7 @@ case mb_stuff of Nothing -> return Nothing Just (thing, fixity, cls_insts, fam_insts, docs) -> do - let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + let rdr_env = icReaderEnv (hsc_IC hsc_env) -- Filter the instances based on whether the constituent names of their -- instance heads are all in scope. @@ -865,7 +867,7 @@ return (Just (thing, fixity, cls_insts', fam_insts', docs)) where plausible rdr_env names - -- Dfun involving only names that are in ic_rn_glb_env + -- Dfun involving only names that are in icReaderEnv = allInfo || nameSetAll ok names where -- A name is ok if it's in the rdr_env, @@ -873,15 +875,14 @@ ok n | n == name = True -- The one we looked for in the first place! | pretendNameIsInScope n = True - | isBuiltInSyntax n = True - | isCTupleTyConName n = True + -- See Note [pretendNameIsInScope] in GHC.Builtin.Names | isExternalName n = isJust (lookupGRE_Name rdr_env n) | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> - return (map greMangledName (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)))) -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated. @@ -889,7 +890,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do let ic = hsc_IC hsc_env - gbl_rdrenv = ic_rn_gbl_env ic + gbl_rdrenv = icReaderEnv ic gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv -- Exclude internally generated names; see e.g. #11328 return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -140,10 +140,7 @@ let iserv_prog = libexec "ghc-iserv" ghcWithInterpreter <- getBooleanSetting "Use interpreter" - ghcWithSMP <- getBooleanSetting "Support SMP" - ghcRTSWays <- getSetting "RTS ways" useLibFFI <- getBooleanSetting "Use LibFFI" - ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" return $ Settings { sGhcNameVersion = GhcNameVersion @@ -207,10 +204,7 @@ , sPlatformMisc = PlatformMisc { platformMisc_targetPlatformString = targetPlatformString , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_ghcWithSMP = ghcWithSMP - , platformMisc_ghcRTSWays = ghcRTSWays , platformMisc_libFFI = useLibFFI - , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw , platformMisc_llvmTarget = llvmTarget } diff --git a/compiler/GHC/StgToCmm/Foreign.hs-boot b/compiler/GHC/StgToCmm/Foreign.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/GHC/StgToCmm/Foreign.hs-boot @@ -0,0 +1,6 @@ +module GHC.StgToCmm.Foreign where + +import GHC.Cmm +import GHC.StgToCmm.Monad + +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -109,9 +109,10 @@ import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure -import GHC.StgToCmm.Utils -import GHC.StgToCmm.Monad +import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) import GHC.StgToCmm.Lit ( newStringCLit ) +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils import GHC.Stg.Syntax import GHC.Cmm.Expr @@ -339,30 +340,46 @@ already_registered <- tickyAllocdIsOn when (not already_registered) $ registerTickyCtr ctr_lbl +-- | Register a ticky counter. +-- +-- It's important that this does not race with other entries of the same +-- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also +-- need to make sure that this is reasonably efficient. Consequently, we first +-- perform a normal load of the counter's "registered" flag to check whether +-- registration is necessary. If so, then we do a compare-and-swap to lock the +-- counter for registration and use an atomic-exchange to add the counter to the list. +-- +-- @ +-- if ( f_ct.registeredp == 0 ) { +-- if (cas(f_ct.registeredp, 0, 1) == 0) { +-- old_head = xchg(ticky_entry_ctrs, f_ct); +-- f_ct.link = old_head; +-- } +-- } +-- @ registerTickyCtr :: CLabel -> FCode () --- Register a ticky counter --- if ( ! f_ct.registeredp ) { --- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ --- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ --- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do platform <- getPlatform - let - constants = platformConstants platform - -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq (wordWidth platform)) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform), - zeroExpr platform] - register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))) - (CmmLoad ticky_entry_ctrs (bWord platform)) - , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , mkStore (CmmLit (cmmLabelOffB ctr_lbl - (pc_OFFSET_StgEntCounter_registeredp constants))) - (mkIntExpr platform 1) ] - ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) - emit =<< mkCmmIfThen test (catAGraphs register_stmts) + let constants = platformConstants platform + word_width = wordWidth platform + registeredp = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_registeredp constants)) + + register_stmts <- getCode $ do + old_head <- newTemp (bWord platform) + let ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) + link = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants)) + emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl] + emitStore link (CmmReg $ CmmLocal old_head) + + cas_test <- getCode $ do + old <- newTemp (bWord platform) + emitPrimCall [old] (MO_Cmpxchg word_width) + [registeredp, zeroExpr platform, mkIntExpr platform 1] + let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform) + emit =<< mkCmmIfThen locked register_stmts + + let test = cmmEqWord platform (CmmLoad registeredp (bWord platform)) (zeroExpr platform) + emit =<< mkCmmIfThen test cas_test tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -276,8 +276,7 @@ -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { platform <- getPlatform - ; uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType platform e) + ; reg <- newTemp (cmmExprType platform e) ; emitAssign (CmmLocal reg) e ; return reg } diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -22,7 +22,6 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin -import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) @@ -47,7 +46,6 @@ import GHC.Utils.Error import GHC.Core.DataCon import GHC.Data.Maybe -import GHC.Types.Hint import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet @@ -513,7 +511,7 @@ , text "via_tvs" <+> ppr via_tvs ] (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (nonUnaryErr deriv_pred) + failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred) let [cls_arg_kind] = cls_arg_kinds mb_deriv_strat = fmap unLoc mb_lderiv_strat if (className cls == typeableClassName) @@ -658,8 +656,8 @@ mb_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust mb_match) - (derivingViaKindErr cls inst_ty_kind - via_ty via_kind) + (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just kind_subst = mb_match ki_subst_range = getTCvSubstRangeFVs kind_subst @@ -739,11 +737,7 @@ pure (tvs, SupplyContext theta, cls, inst_tys) warnUselessTypeable :: TcM () -warnUselessTypeable - = do { addDiagnosticTc $ TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingTypeable) noHints $ - text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } +warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance @@ -779,7 +773,8 @@ -- Check that the result really is well-kinded ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) + (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep) ; let -- Returns a singleton-element list if using ViaStrategy and an -- empty list otherwise. Useful for free-variable calculations. @@ -824,7 +819,8 @@ via_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust via_match) - (derivingViaKindErr cls inst_ty_kind via_ty via_kind) + (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just via_subst = via_match pure $ propagate_subst via_subst tkvs' cls_tys' @@ -845,7 +841,8 @@ ; let final_tc_app = mkTyConApp tc final_tc_args final_cls_args = final_cls_tys ++ [final_tc_app] ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys final_tc_app) + (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNoEtaReduce final_tc_app) -- Check that -- (a) The args to drop are all type variables; eg reject: -- data instance T a Int = .... deriving( Monad ) @@ -1154,9 +1151,7 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do is_boot <- tcIsHsBootOrSig - when is_boot $ - bale_out (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") + when is_boot $ bale_out DerivErrBootFileFound runReaderT mk_eqn deriv_env where deriv_env = DerivEnv { denv_overlap_mode = overlap_mode @@ -1166,7 +1161,8 @@ , denv_ctxt = deriv_ctxt , denv_strat = deriv_strat } - bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg + bale_out = + failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving mk_eqn :: DerivM EarlyDerivSpec mk_eqn = do @@ -1188,7 +1184,7 @@ (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty unless (isNewTyCon (dit_rep_tc dit)) $ - derivingThingFailWith False gndNonNewtypeErr + derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData mkNewTypeEqn True dit Nothing -> mk_eqn_no_strategy @@ -1200,7 +1196,7 @@ -- property is important. expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) expectNonNullaryClsArgs inst_tys = - maybe (derivingThingFailWith False derivingNullaryErr) pure $ + maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $ snocView inst_tys -- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application @@ -1217,9 +1213,7 @@ expectAlgTyConApp cls_tys inst_ty = do fam_envs <- lift tcGetFamInstEnvs case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of - Nothing -> derivingThingFailWith False $ - text "The last argument of the instance must be a" - <+> text "data or newtype application" + Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp Just dit -> do expectNonDataFamTyCon dit pure dit @@ -1234,8 +1228,8 @@ , dit_rep_tc = rep_tc }) = -- If it's still a data family, the lookup failed; i.e no instance exists when (isDataFamilyTyCon rep_tc) $ - derivingThingFailWith False $ - text "No family instance for" <+> quotes (pprTypeApp tc tc_args) + derivingThingFailWith NoGeneralizedNewtypeDeriving $ + DerivErrNoFamilyInstance tc tc_args mk_deriv_inst_tys_maybe :: FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys @@ -1362,20 +1356,31 @@ = do DerivEnv { denv_cls = cls , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fn = gen_fn } - StockClassError msg -> derivingThingFailWith False msg - _ -> derivingThingFailWith False (nonStdErr cls) + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveAnyClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable isDeriveAnyClassEnabled) + -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass + -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's + -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it. + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled) mk_eqn_anyclass :: DerivM EarlyDerivSpec mk_eqn_anyclass = do dflags <- getDynFlags - case canDeriveAnyClass dflags of - IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass - NotValid msg -> derivingThingFailWith False msg + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + case xopt LangExt.DeriveAnyClass dflags of + True -> mk_eqn_from_mechanism DerivSpecAnyClass + False -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotDeriveable isDeriveAnyClassEnabled) mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class -> Type -- The newtype's representation type @@ -1432,24 +1437,24 @@ DerivEnv { denv_cls = cls , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) -- See Note [Deriving instances for classes themselves] - let dac_error msg + let dac_error | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" + = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled | otherwise - = nonStdErr cls $$ msg + = DerivErrNotStockDeriveable isDeriveAnyClassEnabled case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of - NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) - StockClassError msg -> derivingThingFailWith False msg - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass {- ************************************************************************ @@ -1482,11 +1487,7 @@ let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - bale_out = derivingThingFailWith newtype_deriving - - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" - <+> text "newtype-deriving extension" + bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving) -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) @@ -1555,9 +1556,6 @@ -- And the [a] must not mention 'b'. That's all handled -- by nt_eta_rity. - cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - massert (cls_tys `lengthIs` (classArity cls - 1)) if newtype_strat then @@ -1569,8 +1567,7 @@ -- See Note [Determining whether newtype-deriving is appropriate] if eta_ok && newtype_deriving then mk_eqn_newtype dit rep_inst_ty - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) + else bale_out (DerivErrCannotEtaReduceEnough eta_ok) else if might_be_newtype_derivable && ((newtype_deriving && not deriveAnyClass) @@ -1578,7 +1575,7 @@ then mk_eqn_newtype dit rep_inst_ty else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tycon rep_tycon of - StockClassError msg + StockClassError why -- There's a particular corner case where -- -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are @@ -1592,18 +1589,18 @@ -> mk_eqn_newtype dit rep_inst_ty -- Otherwise, throw an error for a stock class | might_be_newtype_derivable && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) + -> bale_out why | otherwise - -> bale_out msg + -> bale_out why -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg + NonDerivableClass -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err + | newtype_deriving -> bale_out (DerivErrCannotEtaReduceEnough eta_ok) -- Try newtype deriving! -- Here we suggest GeneralizedNewtypeDeriving even in cases -- where it may not be applicable. See #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) + | otherwise -> bale_out DerivErrNewtypeNonDeriveableClass -- DeriveAnyClass CanDeriveAnyClass -> do @@ -1613,16 +1610,7 @@ -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ lift $ addDiagnosticTc - $ TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingDefaults) noHints - $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - , text "Use DerivingStrategies to pick" - <+> text "a different strategy" - ] + $ TcRnDerivingDefaults cls mk_eqn_from_mechanism DerivSpecAnyClass -- CanDeriveStock CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ @@ -1931,7 +1919,7 @@ lift $ addUsedDataCons rdr_env rep_tc unless (not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc + bale_out $ DerivErrDataConsNotAllInScope tc -- Ensure that a class's associated type variables are suitable for -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is @@ -1970,24 +1958,12 @@ last_cls_tv = assert (notNull cls_tyvars ) last cls_tyvars - cant_derive_err - = vcat [ ppUnless no_adfs adfs_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - adfs_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - unless ats_look_sensible $ bale_out cant_derive_err + unless ats_look_sensible $ + bale_out (DerivErrHasAssociatedDatatypes + (hasAssociatedDataFamInsts (not no_adfs)) + (associatedTyLastVarInKind at_last_cls_tv_in_kinds) + (associatedTyNotParamOverLastTyVar at_without_last_cls_tv) + ) doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan -> DerivSpecMechanism -> TcM () @@ -2004,39 +1980,28 @@ ; case wildcard of Nothing -> pure () Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (partial_sig_msg [pts_suggestion]) - diagnosticTc wpartial_sigs (partial_sig_msg noHints) + let suggParSigs = suggestPartialTypeSignatures xpartial_sigs + let dia = TcRnPartialTypeSignatures suggParSigs theta + checkTc xpartial_sigs dia + diagnosticTc wpartial_sigs dia -- Check for Generic instances that are derived with an exotic -- deriving strategy like DAC -- See Note [Deriving strategies] ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err + do { failIfTc (safeLanguageOn dflags) + (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrSafeHaskellGenericInst) ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } } where exotic_mechanism = not $ isDerivSpecStock mechanism - partial_sig_msg :: [GhcHint] -> TcRnMessage - partial_sig_msg hints = TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialTypeSignatures) hints $ - text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - - pts_suggestion :: GhcHint - pts_suggestion - = UnknownHint (text "To use the inferred type, enable PartialTypeSignatures") - - gen_inst_err :: TcRnMessage - gen_inst_err = TcRnUnknownMessage - $ mkPlainError noHints $ - text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - -derivingThingFailWith :: Bool -- If True, add a snippet about how not even - -- GeneralizedNewtypeDeriving would make this - -- declaration work. This only kicks in when - -- an explicit deriving strategy is not given. - -> SDoc -- The error message +derivingThingFailWith :: UsingGeneralizedNewtypeDeriving + -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about + -- how not even GeneralizedNewtypeDeriving would make this + -- declaration work. This only kicks in when + -- an explicit deriving strategy is not given. + -> DeriveInstanceErrReason -- The reason the derivation failed -> DerivM a derivingThingFailWith newtype_deriving msg = do err <- derivingThingErrM newtype_deriving msg @@ -2067,7 +2032,7 @@ tyfam_insts <- -- canDeriveAnyClass should ensure that this code can't be reached -- unless -XDeriveAnyClass is enabled. - assertPpr (isValid (canDeriveAnyClass dflags)) + assertPpr (xopt LangExt.DeriveAnyClass dflags) (ppr "genDerivStuff: bad derived class" <+> ppr clas) $ mapM (tcATDefault loc mini_subst emptyNameSet) (classATItems clas) @@ -2218,100 +2183,26 @@ ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> TcRnMessage -nonUnaryErr ct = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: SDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> TcRnMessage -derivingKindErr tc cls cls_tys cls_kind enough_args - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> TcRnMessage -derivingViaKindErr cls cls_kind via_ty via_kind - = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ - hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> TcRnMessage -derivingEtaErr cls cls_tys inst_ty - = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ - sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> TcRnMessage -derivingThingErr newtype_deriving cls cls_args mb_strat why - = derivingThingErr' newtype_deriving cls cls_args mb_strat - (maybe empty derivStrategyName mb_strat) why - -derivingThingErrM :: Bool -> SDoc -> DerivM TcRnMessage +derivingThingErrM :: UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> DerivM TcRnMessage derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask - pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM TcRnMessage +derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask - pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat - (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> TcRnMessage -derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why where - strat_used = isJust mb_strat - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") - 2 (text "so you cannot derive an instance for it") + newtype_deriving :: UsingGeneralizedNewtypeDeriving + newtype_deriving + = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving + else NoGeneralizedNewtypeDeriving standaloneCtxt :: LHsSigWcType GhcRn -> SDoc standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -807,12 +807,15 @@ where data_cons = getPossibleDataCons tycon tycon_args + foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR + foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns eqns = map foldr_eqn data_cons foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldr con + foldr_match_ctxt = mkPrefixFunRhs foldr_name foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR @@ -826,6 +829,7 @@ = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldMap con + foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -- Given a list of NullM results, produce Nothing if any of -- them is NotNull, and otherwise produce a list of Maybes @@ -881,7 +885,7 @@ -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) + match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs) where -- g1 v1 (g2 v2 (.. z)) mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs @@ -911,7 +915,7 @@ -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) + match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs) where -- mappend v1 (mappend v2 ..) mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs @@ -1042,6 +1046,7 @@ = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_trav con + traverse_match_ctxt = mkPrefixFunRhs traverse_name -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. @@ -1072,7 +1077,7 @@ -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con = mkSimpleConMatch2 CaseAlt $ + match_for_con = mkSimpleConMatch2 traverse_match_ctxt $ \con xs -> return (mkApCon con xs) where -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -27,6 +27,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor +import GHC.Tc.Errors.Types import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) @@ -47,7 +48,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session -import GHC.Utils.Error( Validity(..), andValid ) +import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env @@ -146,7 +147,7 @@ -} -canDoGenerics :: TyCon -> Validity +canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken @@ -158,14 +159,14 @@ = mergeErrors ( -- Check (b) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) + then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name) else IsValid) -- See comment below : (map bad_con (tyConDataCons tc))) where -- The tc can be a representation tycon. When we want to display it to the -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of + tc_name = case tyConFamInst_maybe tc of Just (ptc, _) -> ptc _ -> tc @@ -175,12 +176,12 @@ -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) + bad_con :: DataCon -> Validity' DeriveGenericsErrReason + bad_con dc = if any bad_arg_type (map scaledThing $ dataConOrigArgTys dc) + then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc + else if not (isVanillaDataCon dc) + then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc + else IsValid -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) @@ -194,19 +195,20 @@ allowedUnliftedTy :: Type -> Bool allowedUnliftedTy = isJust . unboxedRepRDRs -mergeErrors :: [Validity] -> Validity +mergeErrors :: [Validity' a] -> Validity' [a] mergeErrors [] = IsValid mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') + IsValid -> NotValid [s] + NotValid s' -> NotValid (s : s') mergeErrors (IsValid : t) = mergeErrors t + -- NotValid s' -> NotValid (s <> text ", and" $$ s') -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type + , _ccdg1_errors :: Validity' DeriveGenericsErrReason -- errors generated by this type } {- @@ -241,15 +243,14 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not. -canDoGenerics1 :: TyCon -> Validity +canDoGenerics1 :: TyCon -> Validity' [DeriveGenericsErrReason] canDoGenerics1 rep_tc = canDoGenerics rep_tc `andValid` additionalChecks where additionalChecks -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" + | null (tyConTyVars rep_tc) = NotValid [ + DerivErrGenericsMustHaveSomeTypeParams rep_tc] | otherwise = mergeErrors $ concatMap check_con data_cons @@ -258,15 +259,12 @@ j@(NotValid {}) -> [j] IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity + check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) + | otherwise = NotValid $ DerivErrGenericsMustNotHaveExistentials con - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s + bmzero = CCDG1 False IsValid + bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con) bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) -- check (e) from Note [Requirements for deriving Generic and Rep] @@ -279,29 +277,24 @@ -- (component_0,component_1,...,component_n) , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg + then bmbad con else foldr bmplus bmzero components -- (dom -> rng), where the head of ty is not a tuple tycon , ft_fun = \dom rng -> -- cf #8516 if _ccdg1_hasParam dom - then bmbad con wrong_arg + then bmbad con else bmplus dom rng -- (ty arg), where head of ty is neither (->) nor a tuple constructor and -- the parameter of interest does not occur in ty , ft_ty_app = \_ _ arg -> arg - , ft_bad_app = bmbad con wrong_arg + , ft_bad_app = bmbad con , ft_forall = \_ body -> body -- polytypes are handled elsewhere } where caseVar = CCDG1 True IsValid - - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" {- ************************************************************************ diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -17,7 +17,6 @@ PredOrigin(..), ThetaOrigin(..), mkPredOrigin, mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, checkOriginativeSideConditions, hasStockDeriving, - canDeriveAnyClass, std_class_via_coercible, non_coercible_class, newDerivClsInst, extendLocalInstEnv ) where @@ -45,13 +44,13 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics +import GHC.Tc.Errors.Types import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var.Set @@ -432,9 +431,9 @@ = CanDeriveStock -- Stock class, can derive (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) - | StockClassError SDoc -- Stock class, but can't do it + | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass + | NonDerivableClass -- Cannot derive with either stock or anyclass -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a @@ -561,8 +560,7 @@ stock class to be able to be derived successfully. A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. +is willing to support it. -} hasStockDeriving @@ -702,15 +700,16 @@ -- e.g. deriving( Eq s ) -- ...if not, try falling back on DeriveAnyClass. - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- Neither anyclass nor stock work + | xopt LangExt.DeriveAnyClass dflags + = CanDeriveAnyClass -- DeriveAnyClass should work | otherwise - = CanDeriveAnyClass -- DeriveAnyClass should work + = NonDerivableClass -- Neither anyclass nor stock work -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" +classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason +classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys) + -- Side conditions (whether the datatype must have at least one constructor, -- required language extensions, etc.) for using GHC's stock deriving -- mechanism on certain classes (as opposed to classes that require @@ -756,15 +755,6 @@ cond_vanilla = cond_stdOK deriv_ctxt True -- Vanilla data constructors but allow no data cons or polytype arguments -canDeriveAnyClass :: DynFlags -> Validity --- IsValid: we can (try to) derive it via an empty instance declaration --- NotValid s: we can't, reason s -canDeriveAnyClass dflags - | not (xopt LangExt.DeriveAnyClass dflags) - = NotValid (text "Try enabling DeriveAnyClass") - | otherwise - = IsValid -- OK! - type Condition = DynFlags @@ -774,17 +764,10 @@ -> TyCon -- ^ For data families, this is the representation 'TyCon'. -- Otherwise, this is the same as the other 'TyCon' argument. - -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is - -- possible. Otherwise, it's @'NotValid' err@, where @err@ - -- explains what went wrong. - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc rep_tc - = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail + -> Validity' DeriveInstanceErrReason + -- ^ 'IsValid' if deriving an instance for this 'TyCon' is + -- possible. Otherwise, it's @'NotValid' err@, where @err@ + -- explains what went wrong. andCond :: Condition -> Condition -> Condition andCond c1 c2 dflags tc rep_tc @@ -821,15 +804,14 @@ cond_stdOK deriv_ctxt permissive dflags tc rep_tc = valid_ADT `andValid` valid_misc where - valid_ADT, valid_misc :: Validity + valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason valid_ADT | isAlgTyCon tc || isDataFamilyTyCon tc = IsValid | otherwise -- Complain about functions, primitive types, and other tycons that -- stock deriving can't handle. - = NotValid $ text "The last argument of the instance must be a" - <+> text "data or newtype application" + = NotValid DerivErrLastArgMustBeApp valid_misc = case deriv_ctxt of @@ -841,53 +823,63 @@ | null data_cons -- 1. , not permissive -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` - NotValid (no_cons_why rep_tc $$ empty_data_suggestion) + NotValid (no_cons_why rep_tc) | not (null con_whys) - -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) + -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys | otherwise -> IsValid - empty_data_suggestion = - text "Use EmptyDataDeriving to enable deriving for empty data types" - possible_fix_suggestion wildcard + has_wildcard wildcard = case wildcard of - Just _ -> - text "Possible fix: fill in the wildcard constraint yourself" - Nothing -> - text "Possible fix: use a standalone deriving declaration instead" + Just _ -> YesHasWildcard + Nothing -> NoHasWildcard data_cons = tyConDataCons rep_tc con_whys = getInvalids (map check_con data_cons) - check_con :: DataCon -> Validity + check_con :: DataCon -> Validity' DeriveInstanceBadConstructor check_con con | not (null eq_spec) -- 2. - = bad "is a GADT" + = bad DerivErrBadConIsGADT | not (null ex_tvs) -- 3. - = bad "has existential type variables in its type" + = bad DerivErrBadConHasExistentials | not (null theta) -- 4. - = bad "has constraints in its type" + = bad DerivErrBadConHasConstraints | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5. - = bad "has a higher-rank type" + = bad DerivErrBadConHasHigherRankType | otherwise = IsValid where (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) + bad mkErr = NotValid $ mkErr con -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" +no_cons_why :: TyCon -> DeriveInstanceErrReason +no_cons_why = DerivErrNoConstructors cond_RepresentableOk :: Condition -cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc +cond_RepresentableOk _ _ rep_tc = + case canDoGenerics rep_tc of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs cond_Representable1Ok :: Condition -cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc +cond_Representable1Ok _ _ rep_tc = + case canDoGenerics1 rep_tc of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond` (cond_isProduct `andCond` cond_args cls) + where + orCond :: Condition -> Condition -> Condition + orCond c1 c2 dflags tc rep_tc + = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y + -- Both fail + cond_args :: Class -> Condition -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types -- by generating specialised code. For others (eg 'Data') we don't. @@ -896,8 +888,7 @@ cond_args cls _ _ rep_tc = case bad_args of [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) + (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty where bad_args = [ arg_ty | con <- tyConDataCons rep_tc , Scaled _ arg_ty <- dataConOrigArgTys con @@ -919,20 +910,14 @@ cond_isEnumeration :: Condition cond_isEnumeration _ _ rep_tc | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in GHC.Core.TyCon + | otherwise = NotValid $ DerivErrMustBeEnumType rep_tc cond_isProduct :: Condition cond_isProduct _ _ rep_tc - | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" + | Just _ <- tyConSingleDataCon_maybe rep_tc + = IsValid + | otherwise + = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class @@ -943,12 +928,10 @@ -- (e) no "stupid context" on data type cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") + = NotValid $ DerivErrMustHaveSomeParameters rep_tc | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta | otherwise = allValid (map check_con data_cons) @@ -962,7 +945,7 @@ data_cons = tyConDataCons rep_tc check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - check_universal :: DataCon -> Validity + check_universal :: DataCon -> Validity' DeriveInstanceErrReason check_universal con | allowExQuantifiedLastTyVar = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] @@ -972,31 +955,26 @@ , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) = IsValid -- See Note [Check that the type variable is truly universal] | otherwise - = NotValid (badCon con existential) + = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con] - ft_check :: DataCon -> FFoldType Validity + ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason) ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) + , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con] , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) + else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con] , ft_tup = \_ xs -> allValid xs , ft_ty_app = \_ _ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) + , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con] , ft_forall = \_ x -> x } - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" checkFlag :: LangExt.Extension -> Condition checkFlag flag dflags _ _ | xopt flag dflags = IsValid | otherwise = NotValid why where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of + why = DerivErrLangExtRequired the_flag + the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1020,9 +998,6 @@ = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey , genClassKey, gen1ClassKey, typeableClassKey , traversableClassKey, liftClassKey ]) - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg ------------------------------------------------------------------ diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -46,19 +46,21 @@ import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Builtin.Names ( typeableClassName ) +import GHC.Builtin.Names ( typeableClassName, pretendNameIsInScope ) import qualified GHC.LanguageExtensions as LangExt import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys, flattenTys ) +import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon + , pprWithTYPE ) +import GHC.Core.Unify ( tcMatchTys ) import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.Class @@ -75,12 +77,14 @@ import GHC.Data.Bag import GHC.Data.FastString import GHC.Utils.Trace (pprTraceUserWarning) -import GHC.Data.List.SetOps ( equivClasses ) +import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) +import Data.Functor ( (<&>) ) +import Data.Function ( on ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) -- import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -564,7 +568,10 @@ -- says to suppress ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; massertPpr (null leftovers) (ppr leftovers) + ; massertPpr (null leftovers) + (text "The following unsolved Wanted constraints \ + \have not been reported to the user:" + $$ ppr leftovers) -- All the Derived ones have been filtered out of simples -- by the constraint solver. This is ok; we don't want @@ -606,6 +613,7 @@ -- report2: we suppress these if there are insolubles elsewhere in the tree report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] -- also checks to make sure the constraint isn't HoleBlockerReason @@ -615,7 +623,7 @@ unblocked checker ct pred = checker ct pred -- rigid_nom_eq, rigid_nom_tv_eq, - is_dict, is_equality, is_ip, is_irred :: Ct -> Pred -> Bool + is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool is_given_eq ct pred | EqPred {} <- pred = arisesFromGivens ct @@ -652,6 +660,12 @@ is_ip _ (ClassPred cls _) = isIPClass cls is_ip _ _ = False + is_FRR ct (SpecialPred ConcretePrimPred _) + | FixedRuntimeRepOrigin {} <- ctOrigin ct + = True + is_FRR _ _ + = False + is_irred _ (IrredPred {}) = True is_irred _ _ = False @@ -928,9 +942,10 @@ -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool -nonDeferrableOrigin NonLinearPatternOrigin = True -nonDeferrableOrigin (UsageEnvironmentOf _) = True -nonDeferrableOrigin _ = False +nonDeferrableOrigin NonLinearPatternOrigin = True +nonDeferrableOrigin (UsageEnvironmentOf {}) = True +nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True +nonDeferrableOrigin _ = False maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () maybeReportError ctxt ct report @@ -1428,6 +1443,53 @@ where (ct1:_) = cts +---------------- + +-- | Create a user-facing error message for unsolved @'Concrete#' ki@ +-- Wanted constraints arising from representation-polymorphism checks. +-- +-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. +mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkFRRErr ctxt cts + = do { -- Zonking/tidying. + ; origs <- + -- Zonk/tidy the 'CtOrigin's. + zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) + <&> + -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. + (nubOrdBy (nonDetCmpType `on` frr_type) . snd) + + -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), + -- with the corresponding types: + -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... + ; let tys = map frr_type origs + kis = map typeKind tys + + -- Assemble the error message: pair up each origin with the corresponding type, e.g. + -- • FixedRuntimeRep origin msg 1 ... + -- a :: TYPE r1 + -- • FixedRuntimeRep origin msg 2 ... + -- b :: TYPE r2 + + combine_origin_ty_ki :: CtOrigin -> Type -> Kind -> SDoc + combine_origin_ty_ki orig ty ki = + -- Add bullet points if there is more than one error. + (if length tys > 1 then (bullet <+>) else id) $ + vcat [pprArising orig <> colon + ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE ki] + + msg :: SDoc + msg = vcat $ zipWith3 combine_origin_ty_ki origs tys kis + + ; return $ important msg } + where + + frr_type :: CtOrigin -> Type + frr_type (FixedRuntimeRepOrigin ty _) = ty + frr_type orig + = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" + (text "origin =" <+> ppr orig) + {- Note [Constraints include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2396,7 +2458,7 @@ ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM Report mkDictErr ctxt cts = assert (not (null cts)) $ do { inst_envs <- tcGetInstEnvs @@ -2420,8 +2482,7 @@ && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) lookup_cls_inst inst_envs ct - -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) + = (ct, lookupInstEnv True inst_envs clas tys) where (clas, tys) = getClassPredTys (ctPred ct) @@ -2431,7 +2492,18 @@ -- but we really only want to report the latter elim_superclasses cts = mkMinimalBySCs ctPred cts -mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) +-- [Note: mk_dict_err] +-- ~~~~~~~~~~~~~~~~~~~ +-- Different dictionary error messages are reported depending on the number of +-- matches and unifiers: +-- +-- - No matches, regardless of unifiers: report "No instance for ...". +-- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", +-- and show the matching and unifying instances. +-- - One match, one or more unifiers: report "Overlapping instances for", show the +-- matching and unifying instances, and say "The choice depends on the instantion of ..., +-- and the result of evaluating ...". +mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult) -> TcM SDoc -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) @@ -2620,12 +2692,24 @@ , nest 2 (vcat (pp_givens useful_givens))] , ppWhen (isSingleton matches) $ - parens (vcat [ text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) + parens (vcat [ ppUnless (null tyCoVars) $ + text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr tyCoVars) + , ppUnless (null famTyCons) $ + if (null tyCoVars) + then + text "The choice depends on the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + else + text "and the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) , ppWhen (null (matching_givens)) $ vcat [ text "To pick the first instance above, use IncoherentInstances" , text "when compiling the other instance declarations"] ])] + where + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys matching_givens = mapMaybe matchable useful_givens @@ -2862,8 +2946,8 @@ orphNamesOfTypes (is_tys cls_inst) name_in_scope name - | isBuiltInSyntax name - = True -- E.g. (->) + | pretendNameIsInScope name + = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names | Just mod <- nameModule_maybe name = qual_in_scope (qualName sty mod (nameOccName name)) | otherwise @@ -2897,7 +2981,7 @@ These are the ones most likely to be useful to the programmer. * Show at most n_show in-scope instances, - and summarise the rest ("plus 3 others") + and summarise the rest ("plus N others") * Summarise the not-in-scope instances ("plus 4 not in scope") @@ -2906,18 +2990,6 @@ -} {- -Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (C (Maybe (F x))), where F is a type function, and we have -instances - C (Maybe Int) and C (Maybe a) -Since (F x) might turn into Int, this is an overlap situation, and -indeed the main solver will have refrained -from solving. But by the time we get to error message generation, we've -un-flattened the constraint. So we must *re*-flatten it before looking -up in the instance environment, lest we only report one matching -instance when in fact there are two. - Note [Kind arguments in error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be terribly confusing to get an error message like (#9171) @@ -3048,7 +3120,7 @@ -- enclosing *type* equality, because that's more useful for the programmer ; let extra_tvs = case tidy_orig of KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] - _ -> emptyVarSet + _ -> emptyVarSet ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs -- Put a zonked, tidied CtOrigin into the Ct @@ -3164,19 +3236,26 @@ text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" ----------------------- -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty +warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () +warnDefaulting the_tv wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 $ tyCoVarsOfCtsList (listToBag wanteds) tidy_wanteds = map (tidyCt tidy_env) wanteds + tidy_tv = lookupVarEnv (snd tidy_env) the_tv (loc, ppr_wanteds) = pprWithArising tidy_wanteds warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) 2 ppr_wanteds ; let diag = TcRnUnknownMessage $ diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -66,7 +66,7 @@ import Data.Graph ( graphFromEdges, topSort ) -import GHC.Tc.Solver ( simplifyTopWanteds, runTcSDeriveds ) +import GHC.Tc.Solver ( simplifyTopWanteds, runTcSDerivedsEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) @@ -391,6 +391,26 @@ would cause the type checker to error, it is not a valid hole fit, and thus it is discarded. +Note [Speeding up valid hole-fits] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To fix #16875 we noted that a lot of time was being spent on uneccessary work. + +When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating +a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For +example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`, +we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int` +from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to +`TcSEnv` and adding a `runTcSDerivedsEarlyAbort`, we can fail as soon as we hit +an insoluble constraint. Since we don't need the result in the case that it +fails, a boolean `False` (i.e. "it didn't work" from `runTcSDerivedsEarlyAbort`) +is sufficient. + +We also check whether the type of the hole is an immutable type variable (i.e. +a skolem). In that case, the only possible fits are fits of exactly that type, +which can only come from the locals. This speeds things up quite a bit when we +don't know anything about the type of the hole. This also helps with degenerate +fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type +`a`, where `a` is a skolem. -} data HoleFitDispConfig = HFDC { showWrap :: Bool @@ -574,7 +594,11 @@ map IdHFCand lclBinds ++ map GreHFCand lcl globals = map GreHFCand gbl syntax = map NameHFCand builtIns - to_check = locals ++ syntax ++ globals + -- If the hole is a rigid type-variable, then we only check the + -- locals, since only they can match the type (in a meaningful way). + only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty + to_check = if only_locals then locals + else locals ++ syntax ++ globals ; cands <- foldM (flip ($)) to_check candidatePlugins ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) ; (searchDiscards, subs) <- @@ -876,7 +900,6 @@ ; traceTc "Did it fit?" $ ppr fits ; traceTc "wrap is: " $ ppr wrp ; traceTc "checkingFitOf }" empty - ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) -- We'd like to avoid refinement suggestions like `id _ _` or -- `head _ _`, and only suggest refinements where our all phantom -- variables got unified during the checking. This can be disabled @@ -885,24 +908,26 @@ -- variables, i.e. zonk them to read their final value to check for -- abstract refinements, and to report what the type of the simulated -- holes must be for this to be a match. - ; if fits - then if null ref_vars - then return (Just (z_wrp_tys, [])) - else do { let -- To be concrete matches, matches have to - -- be more than just an invented type variable. - fvSet = fvVarSet fvs - notAbstract :: TcType -> Bool - notAbstract t = case getTyVar_maybe t of - Just tv -> tv `elemVarSet` fvSet - _ -> True - allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars - ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs - ; allowAbstract <- goptM Opt_AbstractRefHoleFits - ; if allowAbstract || (allFilled && allConcrete ) - then return $ Just (z_wrp_tys, z_vars) - else return Nothing } + ; if fits then do { + -- Zonking is expensive, so we only do it if required. + z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) + ; if null ref_vars + then return (Just (z_wrp_tys, [])) + else do { let -- To be concrete matches, matches have to + -- be more than just an invented type variable. + fvSet = fvVarSet fvs + notAbstract :: TcType -> Bool + notAbstract t = case getTyVar_maybe t of + Just tv -> tv `elemVarSet` fvSet + _ -> True + allConcrete = all notAbstract z_wrp_tys + ; z_vars <- zonkTcTyVars ref_vars + ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars + ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs + ; allowAbstract <- goptM Opt_AbstractRefHoleFits + ; if allowAbstract || (allFilled && allConcrete ) + then return $ Just (z_wrp_tys, z_vars) + else return Nothing }} else return Nothing } where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty hole = typed_hole { th_hole = Nothing } @@ -942,7 +967,8 @@ -- constraints on the type of the hole. tcCheckHoleFit :: TypedHole -- ^ The hole to check against -> TcSigmaType - -- ^ The type to check against (possibly modified, e.g. refined) + -- ^ The type of the hole to check against (possibly modified, + -- e.g. refined with additional holes for refinement hole-fits.) -> TcSigmaType -- ^ The type to check whether fits. -> TcM (Bool, HsWrapper) -- ^ Whether it was a match, and the wrapper from hole_ty to ty. @@ -970,22 +996,21 @@ -- The relevant constraints may contain HoleDests, so we must -- take care to clone them as well (to avoid #15370). ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts - -- We wrap the WC in the nested implications, see + -- We wrap the WC in the nested implications, for details, see -- Note [Checking hole fits] - ; let outermost_first = reverse th_implics - -- We add the cloned relevants to the wanteds generated by - -- the call to tcSubType_NC, see Note [Relevant constraints] - -- There's no need to clone the wanteds, because they are - -- freshly generated by `tcSubtype_NC`. - w_rel_cts = addSimples wanted cloned_relevants - final_wc = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first + ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics + final_wc = wrapInImpls $ addSimples wanted cloned_relevants + -- We add the cloned relevants to the wanteds generated + -- by the call to tcSubType_NC, for details, see + -- Note [Relevant constraints]. There's no need to clone + -- the wanteds, because they are freshly generated by the + -- call to`tcSubtype_NC`. ; traceTc "final_wc is: " $ ppr final_wc - ; rem <- runTcSDeriveds $ simplifyTopWanteds final_wc - -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and necessary for e.g. undefined) - ; traceTc "rems was:" $ ppr rem + -- See Note [Speeding up valid-hole fits] + ; (rem, _) <- tryTc $ runTcSDerivedsEarlyAbort $ simplifyTopWanteds final_wc ; traceTc "}" empty - ; return (isSolvedWC rem, wrap) } } + ; return (any isSolvedWC rem, wrap) + } } where setWCAndBinds :: EvBindsVar -- Fresh ev binds var. -> Implication -- The implication to put WC in. diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -21,13 +22,21 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Builtin.Types (multiplicityTy) +import GHC.Types.Basic ( Arity ) +import GHC.Types.Id ( idArity, idName, hasNoBinding ) +import GHC.Types.Name ( isWiredInName ) +import GHC.Types.Var +import GHC.Builtin.Types ( multiplicityTy ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.DataCon ( dataConRepArity + , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) import GHC.Tc.Gen.Head import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType @@ -317,6 +326,22 @@ ; do_ql <- wantQuickLook rn_fun ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args + -- Check for representation polymorphism in the case that + -- the head of the application is a primop or data constructor + -- which has argument types that are representation-polymorphic. + -- This amounts to checking that the leftover argument types, + -- up until the arity, are not representation-polymorphic, + -- so that we can perform eta-expansion later without introducing + -- representation-polymorphic binders. + -- + -- See Note [Checking for representation-polymorphic built-ins] + ; traceTc "tcApp FRR" $ + vcat + [ text "tc_fun =" <+> ppr tc_fun + , text "inst_args =" <+> ppr inst_args + , text "app_res_rho =" <+> ppr app_res_rho ] + ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun + -- Quick look at result ; app_res_rho <- if do_ql then quickLookResultType delta app_res_rho exp_res_ty @@ -353,14 +378,221 @@ -- Typecheck the value arguments ; tc_args <- tcValArgs do_ql inst_args - -- Reconstruct, with special case for tagToEnum# - ; tc_expr <- if isTagToEnum rn_fun - then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho - else return (rebuildHsApps tc_fun fun_ctxt tc_args) + -- Reconstruct, with a special cases for tagToEnum#. + ; tc_expr <- + if isTagToEnum rn_fun + then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho + else do return (rebuildHsApps tc_fun fun_ctxt tc_args) -- Wrap the result ; return (mkHsWrapCo res_co tc_expr) } +{- +Note [Checking for representation-polymorphic built-ins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We cannot have representation-polymorphic or levity-polymorphic +function arguments. See Note [Representation polymorphism invariants] +in GHC.Core. That is checked by the calls to `hasFixedRuntimeRep ` in +`tcEValArg`. + +But some /built-in/ functions are representation-polymorphic. Users +can't define such Ids; they are all GHC built-ins or data +constructors. Specifically they are: + +1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings. +2. Primops, such as raise# +3. Newtype constructors with `UnliftedNewtypes` that have + a representation-polymorphic argument. +4. Representation-polymorphic data constructors: unboxed tuples + and unboxed sums. + +For (1) consider + badId :: forall r (a :: TYPE r). a -> a + badId = unsafeCoerce# @r @r @a @a + +The wired-in function + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b +has a convenient but representation-polymorphic type. It has no +binding; instead it has a compulsory unfolding, after which we +would have + badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#... +And this is no good because of that rep-poly \(x::a). So we want +to reject this. + +On the other hand + goodId :: forall (a :: Type). a -> a + goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a + +is absolutely fine, because after we inline the unfolding, the \(x::a) +is representation-monomorphic. + +Test cases: T14561, RepPolyWrappedVar2. + +For primops (2) the situation is similar; they are eta-expanded in +CorePrep to be saturated, and that eta-expansion must not add a +representation-polymorphic lambda. + +Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail. + +For (3), consider a representation-polymorphic newtype with +UnliftedNewtypes: + + type Id :: forall r. TYPE r -> TYPE r + newtype Id a where { MkId :: a } + + bad :: forall r (a :: TYPE r). a -> Id a + bad = MkId @r @a -- Want to reject + + good :: forall (a :: Type). a -> Id a + good = MkId @LiftedRep @a -- Want to accept + +Test cases: T18481, UnliftedNewtypesLevityBinder + +So these three cases need special treatment. We add a special case +in tcApp to check whether an application of an Id has any remaining +representation-polymorphic arguments, after instantiation and application +of previous arguments. This is achieved by the hasFixedRuntimeRep_remainingValArgs +function, which computes the types of the remaining value arguments, and checks +that each of these have a fixed runtime representation using hasFixedRuntimeRep. + +Wrinkles + +* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head, + we desugar a representation-polymorphic data constructor application + like this: + (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4 + That is, a rep-poly lambda applied to arguments that instantiate it in + a rep-mono way. It's a bit like a compulsory unfolding that has been + inlined, but not yet beta-reduced. + + Because we want to accept this, we switch off Lint's representation + polymorphism checks when Lint checks the output of the desugarer; + see the lf_check_fixed_repy flag in GHC.Core.Lint.lintCoreBindings. + +* Arity. We don't want to check for arguments past the + arity of the function. For example + + raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b + + has arity 1, so an instantiation such as: + + foo :: forall w r (z :: TYPE r). w -> z -> z + foo = raise# @w @(z -> z) + + is unproblematic. This means we must take care not to perform a + representation-polymorphism check on `z`. + + To achieve this, we consult the arity of the 'Id' which is the head + of the application (or just use 1 for a newtype constructor), + and keep track of how many value-level arguments we have seen, + to ensure we stop checking once we reach the arity. + This is slightly complicated by the need to include both visible + and invisible arguments, as the arity counts both: + see GHC.Tc.Gen.Head.countVisAndInvisValArgs. + + Test cases: T20330{a,b} + +-} + +-- | Check for representation-polymorphism in the remaining argument types +-- of a variable or data constructor, after it has been instantiated and applied to some arguments. +-- +-- See Note [Checking for representation-polymorphic built-ins] +hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM () +hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case + + HsVar _ (L _ fun_id) + + -- (1): unsafeCoerce# + -- 'unsafeCoerce#' is peculiar: it is patched in manually as per + -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore. + -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair, + -- at this stage, if we query idArity, we get 0. This is because + -- we end up looking at the non-patched version of unsafeCoerce# + -- defined in Unsafe.Coerce, and that one indeed has arity 0. + -- + -- We thus manually specify the correct arity of 1 here. + | idName fun_id == unsafeCoercePrimName + -> check_thing fun_id 1 (FRRNoBindingResArg fun_id) + + -- (2): primops and other wired-in representation-polymorphic functions, + -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings + -- in GHC.Types.Id.Make + | isWiredInName (idName fun_id) && hasNoBinding fun_id + -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg fun_id) + -- NB: idArity consults the IdInfo of the Id. This can be a problem + -- in the presence of hs-boot files, as we might not have finished + -- typechecking; inspecting the IdInfo at this point can cause + -- strange Core Lint errors (see #20447). + -- We avoid this entirely by only checking wired-in names, + -- as those are the only ones this check is applicable to anyway. + + + XExpr (ConLikeTc (RealDataCon con) _ _) + -- (3): Representation-polymorphic newtype constructors. + | isNewDataCon con + -- (4): Unboxed tuples and unboxed sums + || isUnboxedTupleDataCon con + || isUnboxedSumDataCon con + -> check_thing con (dataConRepArity con) (FRRDataConArg con) + + _ -> return () + + where + nb_applied_vis_val_args :: Int + nb_applied_vis_val_args = count isHsValArg applied_args + + nb_applied_val_args :: Int + nb_applied_val_args = countVisAndInvisValArgs applied_args + + arg_tys :: [TyCoBinder] + arg_tys = fst $ splitPiTys app_res_rho + -- We do not need to zonk app_res_rho first, because the number of arrows + -- in the (possibly instantiated) inferred type of the function will + -- be at least the arity of the function. + + check_thing :: Outputable thing => thing -> Arity -> (Int -> FRROrigin) -> TcM () + check_thing thing arity mk_frr_orig = do + traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity) + go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys + where + go :: Int -- ^ visible value argument index + -- (only used to report the argument position in error messages) + -> Int -- ^ value argument index + -- used to count up to the arity to ensure we don't check too many argument types + -> [TyCoBinder] + -> TcM () + go _ i_val _ + | i_val > arity + = return () + go _ _ [] + -- Should never happen: it would mean that the arity is higher + -- than the number of arguments apparent from the type + = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity) + go i_visval !i_val (Anon af (Scaled _ arg_ty) : tys) + = case af of + InvisArg -> + go i_visval (i_val + 1) tys + VisArg -> do + _concrete_ev <- hasFixedRuntimeRep (mk_frr_orig i_visval) arg_ty + go (i_visval + 1) (i_val + 1) tys + go i_visval i_val (_: tys) + = go i_visval i_val tys + + -- A message containing all the relevant info, in case this functions + -- needs to be debugged again at some point. + debug_msg :: Outputable thing => thing -> Arity -> SDoc + debug_msg thing arity = + vcat + [ text "thing =" <+> ppr thing + , text "arity =" <+> ppr arity + , text "applied_args =" <+> ppr applied_args + , text "nb_applied_vis_val_args =" <+> ppr nb_applied_vis_val_args + , text "nb_applied_val_args =" <+> ppr nb_applied_val_args + , text "arg_tys =" <+> ppr arg_tys ] + -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool -- GHC switches on impredicativity all the time for ($) @@ -438,9 +670,10 @@ tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma = addArgCtxt ctxt larg $ do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma) + ; _concrete_ev <- hasFixedRuntimeRep (FRRApp arg) exp_arg_sigma ; return (L arg_loc arg') } -tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) +tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc arg) , va_fun = (inner_fun, fun_ctxt) , va_args = inner_args , va_ty = app_res_rho }) exp_arg_sigma @@ -448,6 +681,7 @@ do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ]) ; tc_args <- tcValArgs True inner_args ; co <- unifyType Nothing app_res_rho exp_arg_sigma + ; _concrete_ev <- hasFixedRuntimeRep (FRRApp arg) exp_arg_sigma ; traceTc "tcEValArg }" empty ; return (L arg_loc $ mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args) } diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -22,6 +22,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId ) +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.Bind @@ -91,16 +92,17 @@ -> ExpRhoType -- Expected type of whole proc expression -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) -tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty +tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty = do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 -- start with the names as they are used to desugar the proc itself -- See #17423 - ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names + ; names' <- setSrcSpan loc $ + mapM (tcSyntaxName ProcOrigin arr_ty) names ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- newArrowScope - $ tcCheckPat ProcExpr pat (unrestricted arg_ty) + $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty) $ tcCmdTop cmd_env names' cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) @@ -141,9 +143,10 @@ ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) -- The main recursive function -tcCmd env (L loc cmd) res_ty +tcCmd env (L loc cmd) cmd_ty@(_, res_ty) = setSrcSpan (locA loc) $ do - { cmd' <- tc_cmd env cmd res_ty + { cmd' <- tc_cmd env cmd cmd_ty + ; _concrete_ev <- hasFixedRuntimeRep (FRRArrow $ ArrowCmdResTy cmd) res_ty ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) @@ -219,6 +222,10 @@ ; arg' <- tcCheckMonoExpr arg arg_ty + ; _concrete_ev <- hasFixedRuntimeRep + (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app) + fun_ty + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } where -- Before type-checking f, use the environment of the enclosing @@ -243,6 +250,9 @@ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) ; arg' <- tcCheckMonoExpr arg arg_ty + ; _concrete_ev <- hasFixedRuntimeRep + (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg)) + arg_ty ; return (HsCmdApp x fun' arg') } ------------------------------------------- @@ -262,20 +272,31 @@ -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpanA mtch_loc $ - tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ + tcPats (ArrowMatchCtxt KappaExpr) + pats (map (unrestricted . mkCheckExpType) arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) ; let match' = L mtch_loc (Match { m_ext = noAnn - , m_ctxt = LambdaExpr, m_pats = pats' + , m_ctxt = ArrowMatchCtxt KappaExpr + , m_pats = pats' , m_grhss = grhss' }) arg_tys = map (unrestricted . hsLPatType) pats' + + ; _concrete_evs <- + zipWithM + (\ (Scaled _ arg_ty) i -> + hasFixedRuntimeRep (FRRArrow $ ArrowCmdLam i) arg_ty) + arg_tys + [1..] + + ; let cmd' = HsCmdLam x (MG { mg_alts = L l [match'] , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) ; return (mkHsCmdWrap (mkWpCastN co) cmd') } where n_pats = length pats - match_ctxt = LambdaExpr -- Maybe KappaExpr? + match_ctxt = ArrowMatchCtxt KappaExpr pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs x grhss binds) stk_ty res_ty @@ -324,11 +345,12 @@ where tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType) - tc_cmd_arg cmd@(L _ (HsCmdTop names _)) + tc_cmd_arg cmd@(L loc (HsCmdTop names _)) = do { arr_ty <- newFlexiTyVarTy arrowTyConKind ; stk_ty <- newFlexiTyVarTy liftedTypeKind ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names + ; names' <- setSrcSpan loc $ + mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names ; let env' = env { cmd_arr = arr_ty } ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty) ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } @@ -350,7 +372,7 @@ tcCmdMatches env scrut_ty matches (stk, res_ty) = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where - match_ctxt = MC { mc_what = CaseAlt, + match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt, mc_body = mc_body } mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -34,6 +34,7 @@ import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env @@ -519,6 +520,11 @@ InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + ; _concrete_evs <- + mapM (\ poly_id -> + hasFixedRuntimeRep (FRRBinder $ idName poly_id) (idType poly_id)) + poly_ids + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] ]) @@ -1181,7 +1187,7 @@ -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTc, [MonoBindInfo]) --- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings] +-- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings] tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name , fun_matches = matches })] @@ -1210,7 +1216,7 @@ , mbi_sig = Nothing , mbi_mono_id = mono_id }]) } --- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings] +-- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings] tcMonoBinds is_rec sig_fn no_gen [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })] | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS @@ -1470,6 +1476,7 @@ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss (mkCheckExpType pat_ty) + ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' , pat_ext = pat_ty , pat_ticks = ([],[]) } )} diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -40,6 +40,7 @@ import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, mkWpFun ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head @@ -344,7 +345,16 @@ ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty ; -- Drop levity vars, we don't care about them here let arg_tys' = drop arity arg_tys - ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1)) + arg_ty = arg_tys' `getNth` (alt - 1) + ; expr' <- tcCheckPolyExpr expr arg_ty + -- Check the whole res_ty, not just the arg_ty, to avoid #20277. + -- Example: + -- a :: TYPE rep (representation-polymorphic) + -- (# 17# | #) :: (# Int# | a #) + -- This should cause an error, even though (17# :: Int#) + -- is not representation-polymorphic: we don't know how + -- wide the concrete representation of the sum type will be. + ; _concrete_ev <- hasFixedRuntimeRep FRRUnboxedSum res_ty ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } @@ -738,7 +748,7 @@ con1_tv_set = mkVarSet con1_tvs bad_fld (fld, ty) = fld `elem` upd_fld_occs && not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds) -- STEP 4 Note [Type of a record update] -- Figure out types for the scrutinee and result @@ -938,12 +948,17 @@ tcTupArgs args tys = do massert (equalLength args tys) checkTupSize (length args) - mapM go (args `zip` tys) + zipWith3M go [1,2..] args tys where - go (Missing {}, arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy - ; return (Missing (Scaled mult arg_ty)) } - go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty - ; return (Present x expr') } + go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc) + go i (Missing {}) arg_ty + = do { mult <- newFlexiTyVarTy multiplicityTy + ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleSection i) arg_ty + ; return (Missing (Scaled mult arg_ty)) } + go i (Present x expr) arg_ty + = do { expr' <- tcCheckPolyExpr expr arg_ty + ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleArg i) arg_ty + ; return (Present x expr') } --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1003,8 +1018,8 @@ -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) - <- tcSkolemise GenSigCtxt sigma_ty $ \ rho_ty -> - go rho_ty syn_ty + <- tcSkolemise GenSigCtxt sigma_ty + (\ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny @@ -1046,13 +1061,11 @@ do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} - ; return ( result - , match_wrapper <.> - mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - (Scaled op_mult arg_ty) res_ty doc ) } + ; fun_wrap <- mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + (Scaled op_mult arg_ty) res_ty (WpFunSyntaxOp orig) + ; return (result, match_wrapper <.> fun_wrap) } where herald = text "This rebindable syntax expects a function with" - doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1218,7 +1231,7 @@ identifyParent fam_inst_envs possible_parents = case foldr1 intersect possible_parents of -- No parents for all fields: record update is ill-typed - [] -> failWithTc (noPossibleParents rbnds) + [] -> failWithTc (TcRnNoPossibleParentForFields rbnds) -- Exactly one datatype with all the fields: use that [p] -> return p @@ -1237,7 +1250,7 @@ ; return (RecSelData tc) } -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate + _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds) -- Make a field unambiguous by choosing the given parent. -- Emits an error if the field cannot have that parent, @@ -1286,13 +1299,7 @@ -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () reportAmbiguousField parent_type = - setSrcSpan loc $ addDiagnostic $ - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnAmbiguousFields) noHints $ - vcat [ text "The record update" <+> ppr rupd - <+> text "with type" <+> ppr parent_type - <+> text "is ambiguous." - , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." - ] + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type where rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } loc = getLocA (head rbnds) @@ -1380,6 +1387,9 @@ | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcCheckPolyExprNC rhs field_ty + ; _concrete_ev <- + hasFixedRuntimeRep (FRRRecordUpdate (unLoc lbl) (unLoc rhs)) + field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) Many field_ty loc @@ -1401,13 +1411,10 @@ -- But C{} is still valid if no strict fields = if any isBanged field_strs then -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) + addErrTc (TcRnMissingStrictFields con_like []) else do when (notNull field_strs && null field_labels) $ do - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) - noHints - (missingFields con_like []) + let msg = TcRnMissingFields con_like [] (diagnosticTc True msg) | otherwise = do -- A record @@ -1415,7 +1422,7 @@ fs <- zonk_fields missing_s_fields -- It is an error to omit a strict field, because -- we can't substitute it with (error "Missing field f") - addErrTc (missingStrictFields con_like fs) + addErrTc (TcRnMissingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields when (warn && notNull missing_ns_fields) $ do @@ -1423,10 +1430,7 @@ -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingFields) - noHints - (missingFields con_like fs) + let msg = TcRnMissingFields con_like fs diagnosticTc True msg where @@ -1468,22 +1472,13 @@ fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" -badFieldTypes :: [(FieldLabelString,TcType)] -> TcRnMessage -badFieldTypes prs - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - badFieldsUpd :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> TcRnMessage badFieldsUpd rbinds data_cons - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) + = TcRnNoConstructorHasAllFields conflictingFields -- See Note [Finding the conflicting fields] where -- A (preferably small) set of fields such that no constructor contains @@ -1554,60 +1549,12 @@ mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot use a mixture of pattern synonym and record selectors" $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> colon - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> colon - <+> pprWithCommas ppr pat_syn_sels + = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels where RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id RecSelData rep_dc = recordSelectorTyCon dc_rep_id mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" - -missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage -missingStrictFields con fields - = TcRnUnknownMessage $ mkPlainError noHints $ vcat [header, nest 2 rest] - where - pprField (f,ty) = ppr f <+> dcolon <+> ppr ty - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = vcat (fmap pprField fields) - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" <> - if null fields then Outputable.empty else colon - -missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc -missingFields con fields - = vcat [header, nest 2 rest] - where - pprField (f,ty) = ppr f <+> text "::" <+> ppr ty - rest | null fields = Outputable.empty - | otherwise = vcat (fmap pprField fields) - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" <> - if null fields then Outputable.empty else colon - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField GhcRn] -> TcRnMessage -noPossibleParents rbinds - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hfbLHS . unLoc) rbinds - -badOverloadedUpdate :: TcRnMessage -badOverloadedUpdate = TcRnUnknownMessage $ mkPlainError noHints $ - text "Record update is ambiguous, and requires a type signature" - {- ************************************************************************ * * @@ -1616,11 +1563,6 @@ ************************************************************************ -} --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - -- | Checks if the given name is closed and emits an error if not. -- -- See Note [Not-closed error messages]. @@ -1686,25 +1628,7 @@ -- when the final node has a non-closed type. -- explain :: Name -> NotClosedReason -> TcRnMessage - explain name reason = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 + explain = TcRnStaticFormNotClosed -- Note [Not-closed error messages] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -22,6 +22,7 @@ , splitHsApps, rebuildHsApps , addArgWrap, isHsValArg , countLeadingValArgs, isVisibleArg, pprHsExprArgTc + , countVisAndInvisValArgs, countHsWrapperInvisArgs , tcInferAppHead, tcInferAppHead_maybe , tcInferId, tcCheckId @@ -75,6 +76,7 @@ import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic import GHC.Utils.Panic.Plain import Control.Monad @@ -322,6 +324,36 @@ isVisibleArg (EValArg {}) = True isVisibleArg (ETypeArg {}) = True isVisibleArg _ = False + +-- | Count visible and invisible value arguments in a list +-- of 'HsExprArg' arguments. +countVisAndInvisValArgs :: [HsExprArg id] -> Arity +countVisAndInvisValArgs [] = 0 +countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args +countVisAndInvisValArgs (EWrap wrap : args) = + case wrap of { EHsWrap hsWrap -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args + ; EPar {} -> countVisAndInvisValArgs args + ; EExpand {} -> countVisAndInvisValArgs args } +countVisAndInvisValArgs (EPrag {} : args) = countVisAndInvisValArgs args +countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args + +-- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'. +-- Precondition: this wrapper contains no abstractions. +countHsWrapperInvisArgs :: HsWrapper -> Arity +countHsWrapperInvisArgs = go + where + go WpHole = 0 + go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2 + go fun@(WpFun {}) = nope fun + go (WpCast {}) = 0 + go evLam@(WpEvLam {}) = nope evLam + go (WpEvApp _) = 1 + go tyLam@(WpTyLam {}) = nope tyLam + go (WpTyApp _) = 0 + go (WpLet _) = 0 + go (WpMultCoercion {}) = 0 + + nope x = pprPanic "countHsWrapperInvisApps" (ppr x) instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -2396,7 +2396,7 @@ candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } inf_candidates = candidates `delCandidates` spec_req_tkvs - ; inferred <- quantifyTyVars inf_candidates + ; inferred <- quantifyTyVars allVarsOfKindDefault inf_candidates -- NB: 'inferred' comes back sorted in dependency order ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs @@ -3505,7 +3505,7 @@ -- thus, every free variable is really a kv, never a tv. ; dvs <- candidateQTyVarsOfKind kind_or_type ; dvs <- filterConstrainedCandidates wanted dvs - ; quantifyTyVars dvs } + ; quantifyTyVars allVarsOfKindDefault dvs } filterConstrainedCandidates :: WantedConstraints -- Don't quantify over variables free in these @@ -3533,7 +3533,7 @@ kindGeneralizeAll kind_or_type = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) ; dvs <- candidateQTyVarsOfKind kind_or_type - ; quantifyTyVars dvs } + ; quantifyTyVars allVarsOfKindDefault dvs } -- | Specialized version of 'kindGeneralizeSome', but where no variables -- can be generalized, but perhaps some may need to be promoted. @@ -4094,10 +4094,11 @@ ordinary tuples we don't have the same limit as for constraint tuples (which need selectors and an associated class). -* Because it is ill-kinded, it trips an assert in writeMetaTyVar, - so now I disable the assertion if we are writing a type of - kind Constraint. (That seldom/never normally happens so we aren't - losing much.) +* Because it is ill-kinded (unifying something of kind Constraint with + something of kind Type), it should trip an assert in writeMetaTyVarRef. + However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling + over in this scenario (and another scenario, as detailed in + Note [coreView vs tcView] in GHC.Core.Type). Result works fine, but it may eventually bite us. diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -49,6 +49,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence @@ -226,6 +227,10 @@ = do { tcEmitBindingUsage bottomUE ; pat_tys <- mapM scaledExpTypeToType pat_tys ; rhs_ty <- expTypeToType rhs_ty + ; _concrete_evs <- zipWithM + (\ i (Scaled _ pat_ty) -> + hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty) + [1..] pat_tys ; return (MG { mg_alts = L l [] , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } @@ -236,6 +241,10 @@ ; tcEmitBindingUsage $ supUEs usages ; pat_tys <- mapM readScaledExpType pat_tys ; rhs_ty <- readExpType rhs_ty + ; _concrete_evs <- zipWithM + (\ i (Scaled _ pat_ty) -> + hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty) + [1..] pat_tys ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } @@ -431,6 +440,7 @@ -- two multiplicity to still be the same. (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs -- Stmt has a context already + ; _concrete_ev <- hasFixedRuntimeRep FRRBindStmtGuard rhs_ty ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) pat (unrestricted rhs_ty) $ thing_inside res_ty @@ -583,15 +593,17 @@ tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat_mult, pat', thing, new_res_ty), bind_op') + = do { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op') <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] -> do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat_mult, pat', thing, new_res_ty) } + ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) } + ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt MonadComprehension) rhs_ty + -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty @@ -613,17 +625,23 @@ -- guard_op :: test_ty -> rhs_ty -- then_op :: rhs_ty -> new_res_ty -> res_ty -- Where test_ty is, for example, Bool - ; ((thing, rhs', rhs_ty, guard_op'), then_op') + ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op') <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] -> - do { (rhs', guard_op') + do { ((rhs', test_ty), guard_op') <- tcScalingUsage rhs_mult $ tcSyntaxOp MCompOrigin guard_op [SynAny] (mkCheckExpType rhs_ty) $ - \ [test_ty] [test_mult] -> - tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty + \ [test_ty] [test_mult] -> do + rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty + return $ (rhs', test_ty) ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) - ; return (thing, rhs', rhs_ty, guard_op') } + ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') } + + ; _evTerm1 <- hasFixedRuntimeRep FRRBodyStmtGuard test_ty + ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 1) rhs_ty + ; _evTerm3 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 2) new_res_ty + ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } -- Grouping statements @@ -850,14 +868,16 @@ -- This level of generality is needed for using do-notation -- in full generality; see #1537 - ((rhs', pat_mult, pat', new_res_ty, thing), bind_op') + ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op') <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat_mult, pat', new_res_ty, thing) } + ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) } + ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt DoNotation) rhs_ty + -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty @@ -884,12 +904,14 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty - ; ((rhs', rhs_ty, thing), then_op') + ; ((rhs', rhs_ty, new_res_ty, thing), then_op') <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', rhs_ty, thing) } + ; return (rhs', rhs_ty, new_res_ty, thing) } + ; _evTerm1 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 1) rhs_ty + ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 2) new_res_ty ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -35,6 +36,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) +import GHC.Tc.Utils.Concrete ( mkWpFun ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate import GHC.Types.Error @@ -444,12 +446,12 @@ ; let Scaled w h_pat_ty = pat_ty ; pat_ty <- readExpType h_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - (Scaled w pat_ty) inf_res_sigma doc - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" - -- (pat_ty -> inf_res_sigma) + ; expr_wrap2' <- mkWpFun expr_wrap2 idHsWrapper + (Scaled w pat_ty) inf_res_sigma (WpFunViewPat $ unLoc expr) + -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" + -- (pat_ty -> inf_res_sigma) + ; let expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap - doc = text "When checking the view pattern function:" <+> (ppr expr) ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } @@ -655,6 +657,7 @@ ; return (lit2', wrap, bndr_id) } ; pat_ty <- readExpType pat_exp_ty + -- The Report says that n+k patterns must be in Integral -- but it's silly to insist on this in the RebindableSyntax case ; unlessM (xoptM LangExt.RebindableSyntax) $ @@ -886,8 +889,10 @@ -- Add the stupid theta ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys + -- Check that this isn't a GADT pattern match + -- in situations in which that isn't allowed. ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) - ; checkExistentials ex_tvs all_arg_tys penv + ; checkGADT (RealDataCon data_con) ex_tvs all_arg_tys penv ; tenv1 <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys -- NB: Do not use zipTvSubst! See #14154 @@ -979,8 +984,11 @@ ; (subst, univ_tvs') <- newMetaTyVars univ_tvs + -- Check that we aren't matching on a GADT-like pattern synonym + -- in situations in which that isn't allowed. ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) - ; checkExistentials ex_tvs all_arg_tys penv + ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs -- This freshens: Note [Freshen existentials] @@ -1206,9 +1214,11 @@ { checkTc (con_arity == no_of_args) -- Check correct arity (arityErr (text "constructor") con_like con_arity no_of_args) - ; let con_binders = conLikeUserTyVarBinders con_like - ; checkTc (type_args `leLength` con_binders) - (conTyArgArityErr con_like (length con_binders) (length type_args)) + -- forgetting to filter out inferred binders led to #20443 + ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $ + conLikeUserTyVarBinders con_like + ; checkTc (type_args `leLength` con_spec_binders) + (conTyArgArityErr con_like (length con_spec_binders) (length type_args)) ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys ; (type_args', (arg_pats', res)) @@ -1218,7 +1228,7 @@ -- This unification is straight from Figure 7 of -- "Type Variables in Patterns", Haskell'18 ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $ - binderVars con_binders) + binderVars con_spec_binders) -- OK to drop coercions here. These unifications are all about -- guiding inference based on a user-written type annotation -- See Note [Typechecking type applications in patterns] @@ -1344,12 +1354,16 @@ The Right Thing is not to confuse these constraints together. But for now the Easy Thing is to ensure that we do not have existential or -GADT constraints in a 'proc', and to short-cut the constraint -simplification for such vanilla patterns so that it binds no -constraints. Hence the 'fast path' in tcConPat; but it's also a good -plan for ordinary vanilla patterns to bypass the constraint -simplification step. +GADT constraints in a 'proc', which we do by disallowing any +non-vanilla pattern match (i.e. one that introduces existential +variables or provided constraints), in tcDataConPat and tcPatSynPat. +We also short-cut the constraint simplification for such vanilla patterns, +so that we bind no constraints. Hence the 'fast path' in tcDataConPat; +which applies more generally (not just within 'proc'), as it's a good +plan in general to bypass the constraint simplification step entirely +when it's not needed. + ************************************************************************ * * Note [Pattern coercions] @@ -1442,28 +1456,30 @@ msg = hang (text "In the pattern:") 2 (ppr pat) ----------------------------------------------- -checkExistentials :: [TyVar] -- existentials - -> [Type] -- argument types - -> PatEnv -> TcM () - -- See Note [Existential check]] - -- See Note [Arrows and patterns] -checkExistentials ex_tvs tys _ - | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () -checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () -checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ _ = return () -existentialLazyPat :: TcRnMessage -existentialLazyPat - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - -existentialProcPat :: TcRnMessage -existentialProcPat - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Proc patterns cannot use existential or GADT data constructors" +-- | Check that a pattern isn't a GADT, or doesn't have existential variables, +-- in a situation in which that is not permitted (inside a lazy pattern, or +-- in arrow notation). +checkGADT :: ConLike + -> [TyVar] -- ^ existentials + -> [Type] -- ^ argument types + -> PatEnv + -> TcM () +checkGADT conlike ex_tvs arg_tys = \case + PE { pe_ctxt = LetPat {} } + -> return () + PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) } + | not $ isVanillaConLike conlike + -- See Note [Arrows and patterns] + -> failWithTc TcRnArrowProcGADTPattern + PE { pe_lazy = True } + | has_existentials + -- See Note [Existential check] + -> failWithTc TcRnLazyGADTPattern + _ -> return () + where + has_existentials :: Bool + has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs badFieldCon :: ConLike -> FieldLabelString -> TcRnMessage badFieldCon con field diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -30,7 +30,7 @@ import GHC.Types.Id import GHC.Types.Var( EvVar ) import GHC.Types.Var.Set -import GHC.Types.Basic ( RuleName ) +import GHC.Types.Basic ( RuleName, allVarsOfKindDefault ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -151,7 +151,7 @@ -- See Note [Re-quantify type variables in rules] ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; qtkvs <- quantifyTyVars forall_tkvs + ; qtkvs <- quantifyTyVars allVarsOfKindDefault forall_tkvs ; traceTc "tcRule" (vcat [ pprFullRuleName rname , ppr forall_tkvs , ppr qtkvs @@ -477,12 +477,17 @@ new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool - rule_quant_ct skol_tvs ct - | EqPred _ t1 t2 <- classifyPredType (ctPred ct) - , not (ok_eq t1 t2) - = False -- Note [RULE quantification over equalities] - | otherwise - = tyCoVarsOfCt ct `disjointVarSet` skol_tvs + rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of + EqPred _ t1 t2 + | not (ok_eq t1 t2) + -> False -- Note [RULE quantification over equalities] + SpecialPred {} + -- RULES must never quantify over special predicates, as that + -- would leak internal GHC implementation details to the user. + -- + -- Tests (for Concrete# predicates): RepPolyRule{1,2,3}. + -> False + _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs ok_eq t1 t2 | t1 `tcEqType` t2 = False diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -32,15 +32,15 @@ import GHC.Hs -import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) +import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep ) import GHC.Tc.Utils.Zonk import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.TcMType import GHC.Tc.Validity ( checkValidType ) import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) @@ -452,10 +452,15 @@ ; checkValidType ctxt $ build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty - -- arguments become the types of binders. We thus cannot allow - -- representation polymorphism here - ; let (arg_tys, _) = tcSplitFunTys body_ty - ; mapM_ (checkForLevPoly LevityCheckPatSynSig . scaledThing) arg_tys + -- Neither argument types nor the return type may be representation polymorphic. + -- This is because, when creating a matcher: + -- - the argument types become the the binder types (see test RepPolyPatySynArg), + -- - the return type becomes the scrutinee type (see test RepPolyPatSynRes). + ; let (arg_tys, res_ty) = tcSplitFunTys body_ty + ; mapM_ + (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty) + arg_tys + ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty ; traceTc "tcTySig }" $ vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -1,18 +1,18 @@ - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated + AssocInstInfo(..), isNotAssociated, ) where import GHC.Prelude import GHC.Driver.Session +import GHC.Core.TyCo.Rep import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -25,7 +25,7 @@ import GHC.Rename.Env( addUsedGRE ) import GHC.Builtin.Types -import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) +import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName ) @@ -37,7 +37,7 @@ import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr ) +import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class @@ -608,7 +608,6 @@ where args' = [k, k, t1, t2] matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) - {- ******************************************************************** * * diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -40,7 +40,7 @@ import GHC.Utils.Outputable import GHC.Utils.FV -import GHC.Utils.Error( Validity(..), allValid ) +import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -153,9 +153,9 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc -import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) +import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.External @@ -204,7 +204,9 @@ (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -221,7 +223,7 @@ pair :: (Module, SrcSpan) pair@(this_mod,_) | Just (L mod_loc mod) <- hsmodName this_module - = (mkHomeModule home_unit mod, mod_loc) + = (mkHomeModule home_unit mod, locA mod_loc) | otherwise -- 'module M where' is omitted = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) @@ -268,7 +270,8 @@ ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = - ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) + ( renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual idecl) + , reLoc $ ideclName idecl) } ; raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src @@ -277,10 +280,9 @@ $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, L _ mod_name) = noLocA + ; let { mkImport mod_name = noLocA $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLocA [])} - ; mkImport _ = panic "mkImport" } + { ideclHiding = Just (False, noLocA [])}} ; let { withReason t imps = map (,text t) imps } ; let { all_imports = withReason "is implicitly imported" prel_imports ++ withReason "is directly imported" import_decls @@ -1306,7 +1308,7 @@ Nothing -> Just roles_msg -} - eqAlgRhs _ AbstractTyCon _rhs2 + eqAlgRhs _ (AbstractTyCon {}) _rhs2 = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") @@ -2033,12 +2035,13 @@ -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) - , text "ic_rn_gbl_env (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (ic_rn_gbl_env icxt) + , text "icReaderEnv (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] @@ -2049,10 +2052,9 @@ ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n Nothing - IIDecl i -> - let mb_pkg = sl_fs <$> ideclPkgQual i in - getOrphans (unLoc (ideclName i)) mb_pkg + IIModule n -> getOrphans n NoPkgQual + IIDecl i -> getOrphans (unLoc (ideclName i)) + (renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual i)) ; let imports = emptyImportAvails { imp_orphs = orphs @@ -2060,7 +2062,7 @@ ; (gbl_env, lcl_env) <- getEnvs ; let gbl_env' = gbl_env { - tcg_rdr_env = ic_rn_gbl_env icxt + tcg_rdr_env = icReaderEnv icxt , tcg_type_env = type_env , tcg_inst_env = extendInstEnvList (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) @@ -2907,7 +2909,7 @@ home_unit = hsc_home_unit hsc_env unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) + | gre <- globalRdrEnvElts (icReaderEnv ictxt) , let name = greMangledName gre , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only @@ -3086,12 +3088,12 @@ withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m = - case getTcPlugins hsc_env of + case catMaybes $ mapPlugins hsc_env tcPlugin of [] -> m -- Common fast case plugins -> do ev_binds_var <- newTcEvBinds (solvers, rewriters, stops) <- - unzip3 `fmap` mapM (startPlugin ev_binds_var) plugins + unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins let rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] !rewritersUniqFM = sequenceUFMList rewriters @@ -3105,19 +3107,33 @@ Left _ -> failM Right res -> return res where - startPlugin ev_binds_var (TcPlugin start solve rewrite stop) = + start_plugin ev_binds_var (TcPlugin start solve rewrite stop) = do s <- runTcPluginM start return (solve s ev_binds_var, rewrite s, stop s) -getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin] -getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args) - +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a +withDefaultingPlugins hsc_env m = + do case catMaybes $ mapPlugins hsc_env defaultingPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that dePluginStop is called even if a type + -- error occurs during compilation + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (DefaultingPlugin start fill stop) = + do s <- runTcPluginM start + return (fill s, stop s) withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m = - case getHfPlugins hsc_env of + case catMaybes $ mapPlugins hsc_env holeFitPlugin of [] -> m -- Common fast case - plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins -- This ensures that hfPluginStop is called even if a type -- error occurs during compilation. eitherRes <- tryM $ @@ -3127,13 +3143,9 @@ Left _ -> failM Right res -> return res where - startPlugin (HoleFitPluginR init plugin stop) = + start_plugin (HoleFitPluginR init plugin stop) = do ref <- init return (plugin ref, stop ref) - -getHfPlugins :: HscEnv -> [HoleFitPluginR] -getHfPlugins hsc_env = - catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args) runRenamerPlugin :: TcGblEnv diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -86,8 +86,8 @@ import GHC.Core.Type ( Kind, Type, PredType ) import GHC.Types.Id ( Id ) import GHC.Core.InstEnv ( InstEnvs ) -import GHC.Data.FastString ( FastString ) import GHC.Types.Unique ( Unique ) +import GHC.Types.PkgQual ( PkgQual ) -- | Perform some IO, typically to interact with an external tool. @@ -99,7 +99,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult +findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv let fc = hsc_FC hsc_env diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -23,7 +23,11 @@ -- For Rules we need these solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds + approximateWC, runTcSDeriveds, + + -- We need this for valid hole-fits + runTcSDerivedsEarlyAbort + ) where import GHC.Prelude @@ -54,13 +58,14 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type -import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) +import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Types.Basic ( IntWithInf, intGtLimit + , DefaultKindVars(..), allVarsOfKindDefault ) import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt @@ -222,9 +227,11 @@ -- Emit the bad constraints, wrapped in an implication -- See Note [Wrapping failing kind equalities] ; tclvl <- TcM.getTcLevel - ; implic <- buildTvImplication UnkSkol [] tclvl wanted - -- UnkSkol: doesn't matter, because - -- we bind no skolem variables here + ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use UnkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] ; emitImplication implic ; failM } Just (simples, holes) @@ -403,13 +410,31 @@ * Right here in simplifyAndEmitFlatConstraints, use buildTvImplication to wrap the failing constraint in a degenerate implication (no - skolems, no theta, no bumped TcLevel), with ic_binds = CoEvBindsVar. - That way any failing equalities will lead to an error not a warning, - irrespective of -fdefer-type-errors. + skolems, no theta), with ic_binds = CoEvBindsVar. This setting of + `ic_binds` means that any failing equalities will lead to an + error not a warning, irrespective of -fdefer-type-errors: see + Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, + and `maybeSwitchOffDefer` in that module. - This is a slight hack, because the implication doesn't have a bumped - TcLevel, but that doesn't matter. + We still take care to bump the TcLevel of the implication. Partly, + that ensures that nested implications have increasing level numbers + which seems nice. But more specifically, suppose the outer level + has a Given `(C ty)`, which has pending (not-yet-expanded) + superclasses. Consider what happens when we process this implication + constraint (which we have re-emitted) in that context: + - in the inner implication we'll call `getPendingGivenScs`, + - we /do not/ want to get the `(C ty)` from the outer level, + lest we try to add an evidence term for the superclass, + which we can't do because we have specifically set + `ic_binds` = `CoEvBindsVar`. + - as `getPendingGivenSCcs is careful to only get Givens from + the /current/ level, and we bumped the `TcLevel` of the implication, + we're OK. + TL;DR: bump the `TcLevel` when creating the nested implication. + If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). + + We re-emit the implication rather than reporting the errors right now, so that the error mesages are improved by other solving and defaulting. e.g. we prefer @@ -1027,7 +1052,7 @@ , pred <- sig_inst_theta sig ] ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; qtkvs <- quantifyTyVars dep_vars + ; qtkvs <- quantifyTyVars allVarsOfKindDefault dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1479,7 +1504,10 @@ | tv `elemVarSet` mono_tvs = return False | otherwise - = defaultTyVar (not poly_kinds && is_kind_var) tv + = defaultTyVar + (if not poly_kinds && is_kind_var then DefaultKinds else Don'tDefaultKinds) + allVarsOfKindDefault + tv simplify_cand candidates = do { clone_wanteds <- newWanteds DefaultOrigin candidates @@ -1539,7 +1567,7 @@ , text "grown_tcvs =" <+> ppr grown_tcvs , text "dvs =" <+> ppr dvs_plus]) - ; quantifyTyVars dvs_plus } + ; quantifyTyVars allVarsOfKindDefault dvs_plus } ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet @@ -2374,6 +2402,11 @@ = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) ; unifyTyVar the_tv liftedRepTy ; return True } + | isLevityVar the_tv + , not (isTyVarTyVar the_tv) + = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) + ; unifyTyVar the_tv liftedDataConTy + ; return True } | isMultiplicityVar the_tv , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar -- never with a type; c.f. TcMType.defaultTyVar @@ -2568,6 +2601,17 @@ = do { info@(default_tys, _) <- getDefaultInfo ; wanteds <- TcS.zonkWC wanteds + ; tcg_env <- TcS.getGblEnv + ; let plugins = tcg_defaulting_plugins tcg_env + + ; plugin_defaulted <- if null plugins then return [] else + do { + ; traceTcS "defaultingPlugins {" (ppr wanteds) + ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins + ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) + ; return defaultedGroups + } + ; let groups = findDefaultableGroups info wanteds ; traceTcS "applyDefaultingRules {" $ @@ -2579,8 +2623,21 @@ ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - ; return (or something_happeneds) } + ; return $ or something_happeneds || or plugin_defaulted } + where run_defaulting_plugin wanteds p = + do { groups <- runTcPluginTcS (p wanteds) + ; defaultedGroups <- + filterM (\g -> disambigGroup + (deProposalCandidates g) + (deProposalTyVar g, deProposalCts g)) + groups + ; traceTcS "defaultingPlugin " $ ppr defaultedGroups + ; case defaultedGroups of + [] -> return False + _ -> return True + } + findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) @@ -2641,8 +2698,7 @@ ------------------------------ disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- sharing same type variable + -> (TcTyVar, [Ct]) -- All constraints sharing same type variable -> TcS Bool -- True <=> something happened, reflected in ty_binds disambigGroup [] _ @@ -2656,7 +2712,7 @@ ; if success then -- Success: record the type variable binding, and return do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty ; traceTcS "disambigGroup succeeded }" (ppr default_ty) ; return True } else @@ -2670,7 +2726,8 @@ = do { lcl_env <- TcS.getLclEnv ; tc_lvl <- TcS.getTcLevel ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) + -- Equality constraints are possible due to type defaulting plugins + ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred) wanteds ; fmap isEmptyWC $ solveSimpleWanteds $ listToBag $ diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -15,6 +15,7 @@ import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Concrete ( newConcretePrimWanted ) import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Core.Type @@ -41,6 +42,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Builtin.Types ( anyTypeOfKind ) +import GHC.Builtin.Types.Prim ( concretePrimTyCon ) import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Type( HsIPName(..) ) @@ -97,6 +99,9 @@ canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) = canForAll ev pend_sc +canonicalize (CSpecialCan { cc_ev = ev, cc_special_pred = special_pred, cc_xi = xi }) + = canSpecial ev special_pred xi + canonicalize (CIrredCan { cc_ev = ev }) = canNC ev -- Instead of rewriting the evidence before classifying, it's possible we @@ -131,6 +136,8 @@ canIrred ev ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) canForAllNC ev tvs th p + SpecialPred tc ty -> do traceTcS "canEvNC:special" (ppr pred) + canSpecial ev tc ty where pred = ctEvPred ev @@ -208,7 +215,7 @@ -- Precondition: EvVar is class evidence canClass ev cls tys pend_sc fds - = -- all classes do *nominal* matching + = -- all classes do *nominal* matching assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ do { redns@(Reductions _ xis) <- rewriteArgsNom ev cls_tc tys ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns @@ -718,12 +725,19 @@ -- that the IrredPred branch stops work ; case classifyPredType (ctEvPred new_ev) of ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 + EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so + -- cannot become EqPreds + pprPanic "canIrred: EqPred" + (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2) ForAllPred tvs th p -> -- this is highly suspect; Quick Look -- should never leave a meta-var filled -- in with a polytype. This is #18987. do traceTcS "canEvNC:forall" (ppr pred) canForAllNC ev tvs th p + SpecialPred tc tys -> -- IrredPreds have kind Constraint, so cannot + -- become SpecialPreds + pprPanic "canIrred: SpecialPred" + (ppr ev $$ ppr tc $$ ppr tys) IrredPred {} -> continueWith $ mkIrredCt IrredShapeReason new_ev } } @@ -896,6 +910,133 @@ ************************************************************************ +* * +* Special predicates +* * +********************************************************************* -} + +-- | Canonicalise a 'SpecialPred' constraint. +canSpecial :: CtEvidence -> SpecialPred -> TcType -> TcS (StopOrContinue Ct) +canSpecial ev special_pred ty + = do { -- Special constraints should never appear in Givens. + ; massertPpr (not $ isGivenOrigin $ ctEvOrigin ev) + (text "canSpecial: Given Special constraint" $$ ppr ev) + ; case special_pred of + { ConcretePrimPred -> canConcretePrim ev ty } } + +{- Note [Canonical Concrete# constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A 'Concrete#' constraint can be decomposed precisely when +it is an application, possibly nullary, of a concrete 'TyCon'. + +A canonical 'Concrete#' constraint is one that cannot be decomposed. + +To illustrate, when we come across a constraint of the form `Concrete# (f a_1 ... a_n)`, +to canonicalise it, we decompose it into the collection of constraints +`Concrete# a_1`, ..., `Concrete# a_n`, whenever `f` is a concrete type constructor +(that is, it is not a type variable, nor a type-family, nor an abstract 'TyCon' +as declared in a Backpack signature file). + +Writing NC for a non-canonical constraint and C for a canonical one, +here are some examples: + + (1) + NC: Concrete# IntRep + ==> nullary decomposition, by observing that `IntRep = TyConApp intRepTyCon []` + + (2) + NC: Concrete# (TYPE (TupleRep '[Rep, rr])) -- where 'Rep' is an abstract type and 'rr' is a type variable + ==> decompose once, noting that 'TYPE' is a concrete 'TyCon' + NC: Concrete# (TupleRep '[Rep, rr]) + ==> decompose again in the same way but with 'TupleRep' + NC: Concrete# ((:) @RuntimeRep Rep ((:) @RuntimeRep rr [])) + ==> handle (:) and its type-level argument 'RuntimeRep' (which is concrete) + C: Concrete# Rep, NC: Concrete# ((:) @RuntimeRep rr [])) + ==> the second constraint can be decomposed again; 'RuntimeRep' and '[]' are concrete, so we get + C: Concrete# Rep, C: Concrete# rr + +-} + +-- | Canonicalise a 'Concrete#' constraint. +-- +-- See Note [Canonical Concrete# constraints] for details. +canConcretePrim :: CtEvidence -> TcType -> TcS (StopOrContinue Ct) +canConcretePrim ev ty + = do { + -- As per Note [The Concrete mechanism] in GHC.Tc.Instance.Class, + -- in PHASE 1, we don't allow a 'Concrete#' constraint to be rewritten. + -- We still need to zonk, otherwise we can end up stuck with a constraint + -- such as `Concrete# rep` for a unification variable `rep`, + -- which we can't make progress on. + ; ty <- zonkTcType ty + ; traceTcS "canConcretePrim" $ + vcat [text "ev =" <+> ppr ev, text "ty =" <+> ppr ty] + + ; decomposeConcretePrim ev ty } + +-- | Try to decompose a 'Concrete#' constraint: +-- +-- - calls 'canDecomposableConcretePrim' if the constraint can be decomposed; +-- - calls 'canNonDecomposableConcretePrim' otherwise. +decomposeConcretePrim :: CtEvidence -> Type -> TcS (StopOrContinue Ct) +decomposeConcretePrim ev ty + -- Handle applications of concrete 'TyCon's. + -- See examples (1,2) in Note [Canonical Concrete# constraints]. + | (f,args) <- tcSplitAppTys ty + , Just f_tc <- tyConAppTyCon_maybe f + , isConcreteTyCon f_tc + = canDecomposableConcretePrim ev f_tc args + + -- Couldn't decompose the constraint: keep it as-is. + | otherwise + = canNonDecomposableConcretePrim ev ty + +-- | Decompose a constraint of the form @'Concrete#' (f t_1 ... t_n)@, +-- for a concrete `TyCon' `f`. +-- +-- This function will emit new Wanted @Concrete# t_i@ constraints, one for +-- each of the arguments of `f`. +-- +-- See Note [Canonical Concrete# constraints]. +canDecomposableConcretePrim :: CtEvidence + -> TyCon + -> [TcType] + -> TcS (StopOrContinue Ct) +canDecomposableConcretePrim ev f_tc args + = do { traceTcS "canDecomposableConcretePrim" $ + vcat [text "args =" <+> ppr args, text "ev =" <+> ppr ev] + ; arg_cos <- mapM (emit_new_concretePrim_wanted (ctEvLoc ev)) args + ; case ev of + CtWanted { ctev_dest = dest } + -> setWantedEvTerm dest (evCoercion $ mkTyConAppCo Nominal f_tc arg_cos) + _ -> pprPanic "canDecomposableConcretePrim: non-Wanted" $ + vcat [ text "ev =" <+> ppr ev + , text "args =" <+> ppr args ] + ; stopWith ev "Decomposed Concrete#" } + +-- | Canonicalise a non-decomposable 'Concrete#' constraint. +canNonDecomposableConcretePrim :: CtEvidence -> TcType -> TcS (StopOrContinue Ct) +canNonDecomposableConcretePrim ev ty + = do { -- Update the evidence to account for the zonk to `ty`. + let ki = typeKind ty + new_ev = ev { ctev_pred = mkTyConApp concretePrimTyCon [ki, ty] } + new_ct = + CSpecialCan { cc_ev = new_ev + , cc_special_pred = ConcretePrimPred + , cc_xi = ty } + ; traceTcS "canNonDecomposableConcretePrim" $ + vcat [ text "ty =" <+> ppr ty, text "new_ev =" <+> ppr new_ev ] + ; continueWith new_ct } + +-- | Create a new 'Concrete#' Wanted constraint and immediately add it +-- to the work list. +emit_new_concretePrim_wanted :: CtLoc -> Type -> TcS Coercion +emit_new_concretePrim_wanted loc ty + = do { (hole, wanted) <- wrapTcS $ newConcretePrimWanted loc ty + ; emitWorkNC [wanted] + ; return $ mkHoleCo hole } + +{- ********************************************************************** * * * Equalities * * diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -1,5 +1,4 @@ - {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -431,9 +430,10 @@ = do { inerts <- getTcSInerts ; let ics = inert_cans inerts ; case wi of - CEqCan {} -> interactEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi + CEqCan {} -> interactEq ics wi + CIrredCan {} -> interactIrred ics wi + CDictCan {} -> interactDict ics wi + CSpecialCan {} -> continueWith wi -- cannot have Special Givens, so nothing to interact with _ -> pprPanic "interactWithInerts" (ppr wi) } -- CNonCanonical have been canonicalised @@ -1573,7 +1573,7 @@ interactEq _ wi = pprPanic "interactEq" (ppr wi) ---------------------- --- We have a meta-tyvar on the left, and metaTyVarUpateOK has said "yes" +-- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes" -- So try to solve by unifying. -- Three reasons why not: -- Skolem escape @@ -1905,14 +1905,24 @@ topReactionsStage work_item = do { traceTcS "doTopReact" (ppr work_item) ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - CEqCan {} -> doTopReactEq work_item - CIrredCan {} -> doTopReactOther work_item - _ -> -- Any other work item does not react with any top-level equations - continueWith work_item } + CDictCan {} -> + do { inerts <- getTcSInerts + ; doTopReactDict inerts work_item } + CEqCan {} -> + doTopReactEq work_item + + CSpecialCan {} -> + -- No top-level interactions for special constraints. + continueWith work_item + + CIrredCan {} -> + doTopReactOther work_item + + -- Any other work item does not react with any top-level equations + _ -> continueWith work_item } + -------------------- doTopReactOther :: Ct -> TcS (StopOrContinue Ct) -- Try local quantified constraints for @@ -1938,6 +1948,12 @@ ev = ctEvidence work_item loc = ctEvLoc ev pred = ctEvPred ev + +{-******************************************************************** +* * + Top-level reaction for equality constraints (CEqCan) +* * +********************************************************************-} doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2 diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -13,9 +13,8 @@ module GHC.Tc.Solver.Monad ( -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts, - failTcS, warnTcS, addErrTcS, wrapTcS, - runTcSEqualities, + TcS, runTcS, runTcSDeriveds, runTcSDerivedsEarlyAbort, runTcSWithEvBinds, + runTcSInerts, failTcS, warnTcS, addErrTcS, wrapTcS, runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, @@ -160,6 +159,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Misc (HasDebugCallStack) import GHC.Data.Bag as Bag import GHC.Types.Unique.Supply import GHC.Tc.Types @@ -614,10 +614,11 @@ addInertCan :: Ct -> TcS () -- Precondition: item /is/ canonical -- See Note [Adding an equality to the InertCans] -addInertCan ct - = do { traceTcS "addInertCan {" $ +addInertCan ct = + do { traceTcS "addInertCan {" $ text "Trying to insert new inert item:" <+> ppr ct - + ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> + when (abort_flag && insolubleEqCt ct) TcM.failM) ; ics <- getInertCans ; ct <- maybeEmitShadow ics ct ; ics <- maybeKickOut ics ct @@ -729,7 +730,7 @@ -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item } + = ics { inert_safehask = addDictCt (inert_dicts ics) (classTyCon cls) tys item } addInertSafehask _ item = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item @@ -767,7 +768,6 @@ = updInertTcS $ \ ics -> ics { inert_solved_dicts = solved_dicts } - {- ********************************************************************* * * Other inert-set operations @@ -878,7 +878,7 @@ add :: Ct -> DictMap Ct -> DictMap Ct add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDictCt dicts cls tys ct + = addDictCt dicts (classTyCon cls) tys ct add ct _ = pprPanic "getPendingScDicts" (ppr ct) get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) @@ -901,21 +901,21 @@ -- (because they come from the inert set) -- the unsolved implics may not be getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_blocked = blocked - , inert_dicts = idicts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_blocked = blocked + , inert_dicts = idicts } <- getInertCans - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_blocked = blocked -- all blocked equalities are W/D - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unionManyBags [ unsolved_irreds - , unsolved_dicts - , unsolved_blocked ] + ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts + unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_blocked = blocked -- all blocked equalities are W/D + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + unsolved_others = unionManyBags [ unsolved_irreds + , unsolved_dicts + , unsolved_blocked ] ; implics <- getWorkListImplics @@ -1077,6 +1077,8 @@ CQuantCan {} -> panic "removeInertCt: CQuantCan" CIrredCan {} -> panic "removeInertCt: CIrredEvCan" CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + CSpecialCan _ special_pred _ -> + pprPanic "removeInertCt" (ppr "CSpecialCan" <+> parens (ppr special_pred)) -- | Looks up a family application in the inerts. lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) @@ -1198,6 +1200,11 @@ tcs_inerts :: IORef InertSet, -- Current inert set + -- Whether to throw an exception if we come across an insoluble constraint. + -- Used to fail-fast when checking for hole-fits. See Note [Speeding up + -- valid hole-fits]. + tcs_abort_on_insoluble :: Bool, + -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet tcs_worklist :: IORef WorkList -- Current worklist } @@ -1313,6 +1320,7 @@ ; res <- runTcSWithEvBinds ev_binds_var tcs ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } + -- | This variant of 'runTcS' will keep solving, even when only Deriveds -- are left around. It also doesn't return any evidence, as callers won't -- need it. @@ -1321,6 +1329,14 @@ = do { ev_binds_var <- TcM.newTcEvBinds ; runTcSWithEvBinds ev_binds_var tcs } + +-- | This variant of 'runTcSDeriveds' will immediatley fail upon encountering an +-- insoluble ct. See Note [Speeding up valid-hole fits] +runTcSDerivedsEarlyAbort :: TcS a -> TcM a +runTcSDerivedsEarlyAbort tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds' True True ev_binds_var tcs } + -- | This can deal only with equality constraints. runTcSEqualities :: TcS a -> TcM a runTcSEqualities thing_inside @@ -1332,7 +1348,7 @@ runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) runTcSInerts inerts tcs = do ev_binds_var <- TcM.newTcEvBinds - runTcSWithEvBinds' False ev_binds_var $ do + runTcSWithEvBinds' False False ev_binds_var $ do setTcSInerts inerts a <- tcs new_inerts <- getTcSInerts @@ -1341,27 +1357,29 @@ runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' True +runTcSWithEvBinds = runTcSWithEvBinds' True False runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? -- Don't if you want to reuse the InertSet. -- See also Note [Type variable cycles] -- in GHC.Tc.Solver.Canonical + -> Bool -> EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds' restore_cycles ev_binds_var tcs +runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs = do { unified_var <- TcM.newTcRef 0 ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef emptyInert ; wl_var <- TcM.newTcRef emptyWorkList ; unif_lvl_var <- TcM.newTcRef Nothing - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_unif_lvl = unif_lvl_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_worklist = wl_var } + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_unif_lvl = unif_lvl_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_abort_on_insoluble = abort_on_insoluble + , tcs_worklist = wl_var } -- Run the computation ; res <- unTcS tcs env @@ -1418,10 +1436,11 @@ -> TcLevel -> TcS a -> TcS a nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - , tcs_unif_lvl = unif_lvl + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count + , tcs_unif_lvl = unif_lvl + , tcs_abort_on_insoluble = abort_on_insoluble } -> do { inerts <- TcM.readTcRef old_inert_var ; let nest_inert = inerts { inert_cycle_breakers = [] @@ -1430,12 +1449,13 @@ -- All other InertSet fields are inherited ; new_inert_var <- TcM.newTcRef nest_inert ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_count = count -- Inherited - , tcs_unif_lvl = unif_lvl -- Inherited - , tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } + ; let nest_env = TcSEnv { tcs_count = count -- Inherited + , tcs_unif_lvl = unif_lvl -- Inherited + , tcs_ev_binds = ref + , tcs_unified = unified_var + , tcs_inerts = new_inert_var + , tcs_abort_on_insoluble = abort_on_insoluble + , tcs_worklist = new_wl_var } ; res <- TcM.setTcLevel inner_tclvl $ thing_inside nest_env @@ -2007,7 +2027,7 @@ ; TcM.writeTcRef ref tcvs' } } -- | Equalities only -setWantedEq :: TcEvDest -> Coercion -> TcS () +setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS () setWantedEq (HoleDest hole) co = do { useVars (coVarsOfCo co) ; fillCoercionHole hole co } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -33,7 +33,7 @@ import GHC.Hs -import GHC.Tc.Errors.Types ( TcRnMessage(..), LevityCheckProvenance(..) ) +import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -907,7 +907,7 @@ -- Step 2b: quantify, mainly meaning skolemise the free variables -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars dvs2 + ; inferred <- quantifyTyVars allVarsOfKindDefault dvs2 ; traceTc "generaliseTcTyCon: pre zonk" (vcat [ text "tycon =" <+> ppr tc @@ -2701,7 +2701,7 @@ , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "data family:" (ppr tc_name) + { traceTc "tcFamDecl1 data family:" (ppr tc_name) ; checkFamFlag tc_name -- Check that the result kind is OK @@ -2727,7 +2727,7 @@ | OpenTypeFamily <- fam_info = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "open type family:" (ppr tc_name) + { traceTc "tcFamDecl1 open type family:" (ppr tc_name) ; checkFamFlag tc_name ; inj' <- tcInjectivity binders inj ; checkResultSigFlag tc_name sig -- check after injectivity for better errors @@ -2739,7 +2739,7 @@ | ClosedTypeFamily mb_eqns <- fam_info = -- Closed type families are a little tricky, because they contain the definition -- of both the type family and the equations for a CoAxiom. - do { traceTc "Closed type family:" (ppr tc_name) + do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name) -- the variables in the header scope only over the injectivity -- declaration but this is not involved here ; (inj', binders, res_kind) @@ -2955,21 +2955,21 @@ mk_permissive_kind HsigFile [] = True mk_permissive_kind _ _ = False - -- In hs-boot, a 'data' declaration with no constructors + -- In an hs-boot or a signature file, + -- a 'data' declaration with no constructors -- indicates a nominally distinct abstract data type. - mk_tc_rhs HsBootFile _ [] - = return AbstractTyCon - - mk_tc_rhs HsigFile _ [] -- ditto + mk_tc_rhs (isHsBootOrSig -> True) _ [] = return AbstractTyCon mk_tc_rhs _ tycon data_cons = case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) + DataType -> return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind (tyConResKind tycon)) + data_cons NewType -> assert (not (null data_cons)) $ mkNewTyConRhs tc_name tycon (head data_cons) - ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only @@ -2985,32 +2985,19 @@ , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) , text "feqn_bndrs =" <+> ppr outer_bndrs , text "feqn_pats =" <+> ppr hs_pats ]) - -- this check reports an arity error instead of a kind error; easier for user - ; let vis_pats = numVisibleArgs hs_pats - -- First, check if we're dealing with a closed type family equation, and - -- if so, ensure that each equation's type constructor is for the right - -- type family. E.g. barf on - -- type family F a where { G Int = Bool } - ; checkTc (tc_fam_tc_name == eqn_tc_name) $ - wrongTyFamName tc_fam_tc_name eqn_tc_name - - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity + ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats ; discardResult $ bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $ do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } - -- Why "_Tv" here? Consider (#14066 + -- Why "_Tv" here? Consider (#14066) -- type family Bar x y where -- Bar (x :: a) (y :: b) = Int -- Bar (x :: c) (y :: d) = Bool -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately } - where - vis_arity = length (tyConVisibleTyVars tc_fam_tc) - tc_fam_tc_name = getName tc_fam_tc -------------------------- tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn @@ -3019,7 +3006,8 @@ -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (FamEqn { feqn_bndrs = outer_bndrs + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) = setSrcSpanA loc $ @@ -3030,15 +3018,8 @@ NotAssociated {} -> empty InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - -- First, check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - -- Note that for closed type families, kcTyFamInstEqn has already - -- checked the arity previously. - ; let vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity + ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_bndrs hs_pats hs_rhs_ty -- Don't print results they may be knot-tied @@ -3047,6 +3028,24 @@ (map (const Nominal) qtvs) (locA loc)) } +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM () +checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = + do { -- Ensure that each equation's type constructor is for the right + -- type family. E.g. barf on + -- type family F a where { G Int = Bool } + let tc_fam_tc_name = getName tc_fam_tc + ; checkTc (tc_fam_tc_name == eqn_tc_name) $ + wrongTyFamName tc_fam_tc_name eqn_tc_name + + -- Check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + wrongNumberOfParmsErr vis_arity + } + {- Note [Instantiating a family tycon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's possible that kind-checking the result of a family tycon applied to @@ -3141,7 +3140,7 @@ -- See Note [Generalising in tcTyFamInstEqnGuts] ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs) - ; qtvs <- quantifyTyVars dvs + ; qtvs <- quantifyTyVars noVarsOfKindDefault dvs ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs @@ -4373,10 +4372,11 @@ -- If we are dealing with a newtype, we allow representation -- polymorphism regardless of whether or not UnliftedNewtypes -- is enabled. A later check in checkNewDataCon handles this, - -- producing a better error message than checkForLevPoly would. + -- producing a better error message than checkTypeHasFixedRuntimeRep would. ; unless (isNewTyCon tc) $ checkNoErrs $ - mapM_ (checkForLevPoly LevityCheckInValidDataCon) (map scaledThing $ dataConOrigArgTys con) + mapM_ (checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField) + (map scaledThing $ dataConOrigArgTys con) -- the checkNoErrs is to prevent a panic in isVanillaDataCon -- (called a a few lines down), which can fall over if there is a -- bang on a representation-polymorphic argument. This is #18534, @@ -4588,12 +4588,11 @@ -- newBoard :: MonadState b m => m () -- Here, MonadState has a fundep m->b, so newBoard is fine - -- a method cannot be representation-polymorphic, as we have to - -- store the method in a dictionary - -- example of what this prevents: - -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad - ; checkForLevPoly LevityCheckInValidClass tau1 + -- NB: we don't check that the class method is not representation-polymorphic here, + -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees + -- typeclass methods always have kind 'Type'. + -- + -- Test case: rep-poly/RepPolyClassMethod. ; unless constrained_class_methods $ mapM_ check_constraint (tail (cls_pred:op_theta)) diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -52,11 +52,11 @@ = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) - ; return (NewTyCon { data_con = con, - nt_rhs = rhs_ty, - nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = nt_ax, - nt_lev_poly = isKindLevPoly res_kind } ) } + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = nt_ax, + nt_fixed_rep = isFixedRuntimeRepKind res_kind } ) } -- Coreview looks through newtypes with a Nothing -- for nt_co, or uses explicit coercions otherwise where @@ -292,7 +292,8 @@ ; tc_rep_name <- newTyConRepName tycon_name ; let univ_tvs = binderVars binders tycon = mkClassTyCon tycon_name binders roles - AbstractTyCon rec_clas tc_rep_name + AbstractTyCon + rec_clas tc_rep_name result = mkAbstractClass tycon_name univ_tvs fds tycon ; traceIf (text "buildClass" <+> ppr tycon) ; return result } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -750,7 +750,10 @@ ; rep_tc_name <- newFamInstTyConName lfam_name pats ; axiom_name <- newFamInstAxiomName lfam_name [pats] ; tc_rhs <- case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) + DataType -> return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind final_res_kind) + data_cons NewType -> assert (not (null data_cons)) $ mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) @@ -912,7 +915,7 @@ -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs + ; qtvs <- quantifyTyVars noVarsOfKindDefault dvs ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted -- Zonk the patterns etc into the Type world @@ -1333,8 +1336,9 @@ where con_app = mkLams dfun_bndrs $ mkApps (Var (dataConWrapId dict_con)) dict_args - -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad + -- This application will satisfy the Core invariants + -- from Note [Representation polymorphism invariants] in GHC.Core, + -- because typeclass method types are never unlifted. dict_args = map Type inst_tys ++ [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -4,9 +4,7 @@ {-# LANGUAGE TypeFamilies #-} module GHC.Tc.Utils.Backpack ( - findExtraSigImports', findExtraSigImports, - implicitRequirements', implicitRequirements, implicitRequirementsShallow, checkUnit, @@ -40,6 +38,7 @@ import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Name.Shape +import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Finder @@ -278,50 +277,33 @@ -- process A first, because the merging process will cause B to indirectly -- import A. This function finds the TRANSITIVE closure of all such imports -- we need to make. -findExtraSigImports' :: HscEnv - -> HscSource - -> ModuleName - -> IO (UniqDSet ModuleName) -findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> - (initIfaceLoad hsc_env +findExtraSigImports :: HscEnv + -> HscSource + -> ModuleName + -> IO [ModuleName] +findExtraSigImports hsc_env HsigFile modname = do + let + dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle + unit_state = hsc_units hsc_env + reqs = requirementMerges unit_state modname + holes <- forM reqs $ \(Module iuid mod_name) -> do + initIfaceLoad hsc_env . withException ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (VirtUnit iuid) mod_name))) - where - dflags = hsc_dflags hsc_env - ctx = initSDocContext dflags defaultUserStyle - unit_state = hsc_units hsc_env - reqs = requirementMerges unit_state modname - -findExtraSigImports' _ _ _ = return emptyUniqDSet - --- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and --- "GHC.Tc.Module". -findExtraSigImports :: HscEnv -> HscSource -> ModuleName - -> IO [(Maybe FastString, Located ModuleName)] -findExtraSigImports hsc_env hsc_src modname = do - extra_requirements <- findExtraSigImports' hsc_env hsc_src modname - return [ (Nothing, noLoc mod_name) - | mod_name <- uniqDSetToList extra_requirements ] + (mkModule (VirtUnit iuid) mod_name) + return (uniqDSetToList (unionManyUniqDSets holes)) --- A version of 'implicitRequirements'' which is more friendly --- for "GHC.Tc.Module". -implicitRequirements :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [(Maybe FastString, Located ModuleName)] -implicitRequirements hsc_env normal_imports - = do mns <- implicitRequirements' hsc_env normal_imports - return [ (Nothing, noLoc mn) | mn <- mns ] +findExtraSigImports _ _ _ = return [] -- Given a list of 'import M' statements in a module, figure out -- any extra implicit requirement imports they may have. For -- example, if they 'import M' and M resolves to p[A=,C=D], then -- they actually also import the local requirement B. -implicitRequirements' :: HscEnv - -> [(Maybe FastString, Located ModuleName)] +implicitRequirements :: HscEnv + -> [(PkgQual, Located ModuleName)] -> IO [ModuleName] -implicitRequirements' hsc_env normal_imports +implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule fc fopts units home_unit imp mb_pkg @@ -342,7 +324,7 @@ -- than a transitive closure done here) all the free holes are still reachable. implicitRequirementsShallow :: HscEnv - -> [(Maybe FastString, Located ModuleName)] + -> [(PkgQual, Located ModuleName)] -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where @@ -626,7 +608,7 @@ let insts = instUnitInsts iuid isFromSignaturePackage = let inst_uid = instUnitInstanceOf iuid - pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid) + pkg = unsafeLookupUnitId unit_state inst_uid in null (unitExposedModules pkg) -- 3(a). Rename the exports according to how the dependency -- was instantiated. The resulting export list will be accurate @@ -1076,7 +1058,7 @@ -- the local one just to get the information? Hmm... massert (isHomeModule home_unit outer_mod ) massert (isHomeUnitInstantiating home_unit) - let uid = Indefinite (homeUnitInstanceOf home_unit) + let uid = homeUnitInstanceOf home_unit inner_mod `checkImplements` Module (mkInstantiatedUnit uid (homeUnitInstantiations home_unit)) diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Utils.Concrete + ( -- * Creating/emitting 'Concrete#' constraints + hasFixedRuntimeRep + , newConcretePrimWanted + -- * HsWrapper: checking for representation-polymorphism + , mkWpFun + ) + where + +import GHC.Prelude + +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType ( TcType, mkTyConApp ) +import GHC.Tc.Utils.TcMType ( newCoercionHole, newFlexiTyVarTy ) +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin ( CtOrigin(..), FRROrigin(..), WpFunOrigin(..) ) + +import GHC.Builtin.Types ( unliftedTypeKindTyCon, liftedTypeKindTyCon ) +import GHC.Builtin.Types.Prim ( concretePrimTyCon ) + +import GHC.Types.Basic ( TypeOrKind(KindLevel) ) + +import GHC.Core.Type ( isConcrete, typeKind ) + +{- Note [Concrete overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Special predicates of the form `Concrete# ty` are used +to check, in the typechecker, that certain types have a fixed runtime representation. +We give here an overview of the various moving parts, to serve +as a central point of reference for this topic. + + * Representation polymorphism + Note [Representation polymorphism invariants] in GHC.Core + Note [Representation polymorphism checking] + + The first note explains why we require that certain types have + a fixed runtime representation. + + The second note details why we sometimes need a constraint to + perform such checks in the typechecker: we might not know immediately + whether a type has a fixed runtime representation. For example, we might + need further unification to take place before being able to decide. + So, instead of checking immediately, we emit a constraint. + + * What does it mean for a type to be concrete? + Note [Concrete types] + Note [The Concrete mechanism] + + The predicate 'Concrete# ty' is satisfied when we can produce + a coercion + + co :: ty ~ concrete_ty + + where 'concrete_ty' consists only of concrete types (no type variables, + no type families). + + The first note explains more precisely what it means for a type to be concrete. + The second note explains how this relates to the `Concrete#` predicate, + and explains that the implementation is happening in two phases (PHASE 1 and PHASE 2). + In PHASE 1 (the current implementation) we only allow trivial evidence + of the form `co = Refl`. + + * Fixed runtime representation vs fixed RuntimeRep + Note [Fixed RuntimeRep] + + We currently enforce the representation-polymorphism invariants by checking + that binders and function arguments have a "fixed RuntimeRep". + That is, `ty :: ki` has a "fixed RuntimeRep" if we can solve `Concrete# ki`. + + This is slightly less general than we might like, as this rules out + types with kind `TYPE (BoxedRep l)`: we know that this will be represented + by a pointer, which should be enough to go on in many situations. + + * When do we emit 'Concrete#' constraints? + Note [hasFixedRuntimeRep] + + We introduce 'Concrete#' constraints to satisfy the representation-polymorphism + invariants outlined in Note [Representation polymorphism invariants] in GHC.Core, + which mostly amounts to the following two cases: + + - checking that a binder has a fixed runtime representation, + - checking that a function argument has a fixed runtime representation. + + The note explains precisely how we emit these 'Concrete#' constraints. + + * How do we solve Concrete# constraints? + Note [Solving Concrete# constraints] in GHC.Tc.Instance.Class + + Concrete# constraints are solved through two mechanisms, + which are both explained further in the note: + + - by decomposing them, e.g. `Concrete# (TYPE r)` is turned + into `Concrete# r` (canonicalisation of `Concrete#` constraints), + - by using 'Concrete' instances (top-level interactions). + The note explains that the evidence we get from using such 'Concrete' + instances can only ever be Refl, even in PHASE 2. + + * Reporting unsolved Concrete# constraints + Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin + + When we emit a 'Concrete#' constraint, we also provide a 'FRROrigin' + which gives context about the check being done. This origin gets reported + to the user if we end up with an unsolved Wanted 'Concrete#' constraint. + +Note [Representation polymorphism checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the "Levity Polymorphism" paper (PLDI '17), +there are two places in which we must know that a type has a +fixed runtime representation, as explained in + Note [Representation polymorphism invariants] in GHC.Core: + + I1. the type of a bound term-level variable, + I2. the type of an argument to a function. + +The paper explains the restrictions more fully, but briefly: +expressions in these contexts need to be stored in registers, and it's +hard (read: impossible) to store something that does not have a +fixed runtime representation. + +In practice, we enforce these types to have a /fixed RuntimeRep/, which is slightly +stronger, as explained in Note [Fixed RuntimeRep]. + +There are two different ways we check whether a given type +has a fixed runtime representation, both in the typechecker: + + 1. When typechecking type declarations (e.g. datatypes, typeclass, pattern synonyms), + under the GHC.Tc.TyCl module hierarchy. + In these situations, we can immediately reject bad representation polymorphism. + + For instance, the following datatype declaration + + data Foo (r :: RuntimeRep) (a :: TYPE r) = Foo a + + is rejected in GHC.Tc.TyCl.checkValidDataCon upon seeing that the type 'a' + is representation-polymorphic. + + Such checks are done using `GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep`, + with `GHC.Tc.Errors.Types.FixedRuntimeRepProvenance` describing the different + contexts in which bad representation polymorphism can occur while validity checking. + + 2. When typechecking value-level declarations (functions, expressions, patterns, ...), + under the GHC.Tc.Gen module hierarchy. + In these situations, the typechecker might need to do some work to figure out + whether a type has a fixed runtime representation or not. For instance, + GHC might introduce a metavariable (rr :: RuntimeRep), which is only later + (through constraint solving) discovered to be equal to FloatRep. + + This is handled by the Concrete mechanism outlined in + Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. + See Note [Concrete overview] in GHC.Tc.Utils.Concrete for an overview + of the various moving parts. + + The idea is that, to guarantee that a type (rr :: RuntimeRep) is + representation-monomorphic, we emit a 'Concrete# rr' Wanted constraint. + If GHC can solve this constraint, it means 'rr' is monomorphic, and we + are OK to proceed. Otherwise, we report this unsolved Wanted in the form + of a representation-polymorphism error. The different contexts in which + such constraints arise are enumerated in 'FRROrigin'. + +Note [Concrete types] +~~~~~~~~~~~~~~~~~~~~~ +Definition: a type is /concrete/ + iff it consists of a tree of concrete type constructors + See GHC.Core.Type.isConcrete + +Definition: a /concrete type constructor/ is defined by + - a promoted data constructor + - a class, data type or newtype + - a primitive type like Array# or Int# + - an abstract type as defined in a Backpack signature file + (see Note [Synonyms implement abstract data] in GHC.Tc.Module) + In particular, type and data families are not concrete. + See GHC.Core.TyCon.isConcreteTyCon. + +Examples of concrete types: + Lifted, BoxedRep Lifted, TYPE (BoxedRep Lifted) are all concrete +Examples of non-concrete types + F Int, TYPE (F Int), TYPE r, a Int + NB: (F Int) is not concrete because F is a type function + +Note [The Concrete mechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in (2) in Note [Representation polymorphism checking], +to check (ty :: ki) has a fixed runtime representation, +we emit a `Concrete# ki` constraint, where + + Concrete# :: forall k. k -> TupleRep '[] + +Such constraints get solved by decomposition, as per + Note [Canonical Concrete# constraints] in GHC.Tc.Solver.Canonical. +When unsolved Wanted `Concrete#` constraints remain after typechecking, +we report them as representation-polymorphism errors, using `GHC.Tc.Types.Origin.FRROrigin` +to inform the user of the context in which a fixed-runtime-rep check arose. + +-------------- +-- EVIDENCE -- +-------------- + +The evidence for a 'Concrete# ty' constraint is a nominal coercion + + co :: ty ~# concrete_ty + +where 'concrete_ty' consists only of (non-synonym) type constructors and applications +(after expanding any vanilla type synonyms). + + OK: + + TYPE FloatRep + TYPE (BoxedRep Lifted) + Type + TYPE (TupleRep '[ FloatRep, SumRep '[ IntRep, IntRep ] ]) + + Not OK: + + Type variables: + + ty + TYPE r + TYPE (BoxedRep l) + + Type family applications: + + TYPE (Id FloatRep) + +This is so that we can compute the 'PrimRep's needed to represent the type +using 'runtimeRepPrimRep', which expects to be able to read off the 'RuntimeRep', +as per Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. + +Note that the evidence for a `Concrete#` constraint isn't a typeclass dictionary: +like with `(~#)`, the evidence is an (unlifted) nominal coercion, which justifies defining + + Concrete# :: forall k. k -> TYPE (TupleRep '[]) + +We still need a constraint that users can write in their own programs, +so much like `(~#)` and `(~)` we also define: + + Concrete :: forall k. k -> Constraint + +The need for user-facing 'Concrete' constraints is detailed in + Note [Concrete and Concrete#] in GHC.Builtin.Types. + +------------------------- +-- PHASE 1 and PHASE 2 -- +------------------------- + +The Concrete mechanism is being implemented in two separate phases. + +In PHASE 1 (currently implemented), we never allow a 'Concrete#' constraint +to be rewritten (see e.g. GHC.Tc.Solver.Canonical.canConcretePrim). +The only allowable evidence term is Refl, which forbids any program +that requires type family evaluation in order to determine that a 'RuntimeRep' is fixed. +N.B.: we do not currently check that this invariant is upheld: as we are discarding the +evidence in PHASE 1, we no longer have access to the coercion after constraint solving +(which is the point at which we would want to check that the filled in evidence is Refl). + +In PHASE 2 (future work), we lift this restriction. To illustrate what this entails, +recall that the code generator needs to be able to compute 'PrimRep's, so that it +can put function arguments in the correct registers, etc. +As a result, we must insert additional casts in Core to ensure that no type family +reduction is needed to be able to compute 'PrimRep's. For example, the Core + + f = /\ ( a :: F Int ). \ ( x :: a ). some_expression + +is problematic when 'F' is a type family: we don't know what runtime representation to use +for 'x', so we can't compile this function (we can't evaluate type family applications +after we are done with typechecking). Instead, we ensure the 'RuntimeRep' is always +explicitly visible: + + f = /\ ( a :: F Int ). \ ( x :: ( a |> kco ) ). some_expression + +where 'kco' is the evidence for `Concrete# (F Int)`, for example if `F Int = TYPE Int#` +this would be: + + kco :: F Int ~# TYPE Int# + +As `( a |> kco ) :: TYPE Int#`, the code generator knows to use a machine-sized +integer register for `x`, and all is good again. + +Example test cases that require PHASE 2: T13105, T17021, T20363b. + +Note [Fixed RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~ +Definition: + a type `ty :: ki` has a /fixed RuntimeRep/ + iff we can solve `Concrete# ki` + +In PHASE 1 (see Note [The Concrete mechanism]), this is equivalent to: + + a type `ty :: ki` has a /fixed RuntimeRep/ + iff `ki` is a concrete type (in the sense of Note [Concrete types]). + +This definition is crafted to be useful to satisfy the invariants of +Core; see Note [Representation polymorphism invariants] in GHC.Core. + +Notice that "fixed RuntimeRep" means (for now anyway) that + * we know the runtime representation, and + * we know the levity. + +For example (ty :: TYPE (BoxedRep l)), where `l` is a levity variable +is /not/ "fixed RuntimeRep", even though it is always represented by +a heap pointer, because we don't know the levity. In due course we +will want to make finer distinctions, as explained in the paper +Kinds are Calling Conventions [ICFP'20], but this suffices for now. + +Note [hasFixedRuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'hasFixedRuntimeRep' function is responsible for taking a type 'ty' +and emitting a 'Concrete#' constraint to ensure that 'ty' has a fixed `RuntimeRep`, +as outlined in Note [The Concrete mechanism]. + +To do so, we compute the kind 'ki' of 'ty' and emit a 'Concrete# ki' constraint, +which will only be solved if we can prove that 'ty' indeed has a fixed RuntimeRep. + + [Wrinkle: Typed Template Haskell] + We don't perform any checks when type-checking a typed Template Haskell quote: + we want to allow representation polymorphic quotes, as long as they are + monomorphised at splice site. + + Example: + + Module1 + + repPolyId :: forall r (a :: TYPE r). CodeQ (a -> a) + repPolyId = [|| \ x -> x ||] + + Module2 + + import Module1 + + id1 :: Int -> Int + id1 = $$repPolyId + + id2 :: Int# -> Int# + id2 = $$repPolyId + + We implement this skip by inspecting the TH stage in `hasFixedRuntimeRep`. + + A better solution would be to use 'CodeC' constraints, as in the paper + "Staging With Class", POPL 2022 + by Ningning Xie, Matthew Pickering, Andres Löh, Nicolas Wu, Jeremy Yallop, Meng Wang + but for the moment, as we will typecheck again when splicing, + this shouldn't cause any problems in practice. See ticket #18170. + + Test case: rep-poly/T18170a. + +Note [Solving Concrete# constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The representation polymorphism checks emit 'Concrete# ty' constraints, +as explained in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + +The main mechanism through which a `Concrete# ty` constraint is solved +is to directly inspect 'ty' to check that it is a concrete type +such as 'TYPE IntRep' or `TYPE (TupleRep '[ TupleRep '[], FloatRep ])`, +and not, e.g., a skolem type variable. + +There are, however, some interactions to take into account: + + 1. Decomposition. + + The solving of `Concrete#` constraints works recursively. + For example, to solve a Wanted `Concrete# (TYPE r)` constraint, + we decompose it, emitting a new `Concrete# @RuntimeRep r` Wanted constraint, + and use it to solve the original `Concrete# (TYPE r)` constraint. + This happens in the canonicaliser -- see GHC.Tc.Solver.Canonical.canDecomposableConcretePrim. + + Note that Decomposition fully solves `Concrete# ty` whenever `ty` is a + concrete type. For example: + + Concrete# (TYPE (BoxedRep Lifted)) + ==> (decompose) + Concrete# (BoxedRep Lifted) + ==> (decompose) + Concrete# Lifted + ==> (decompose) + + + 2. Rewriting. + + In PHASE 1 (as per Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete), + we don't have to worry about a 'Concrete#' constraint being rewritten. + We only need to zonk: if e.g. a metavariable, `alpha`, gets unified with `IntRep`, + we should be able to solve `Concrete# alpha`. + + In PHASE 2, we will need to proceed as in GHC.Tc.Solver.Canonical.canClass: + if we have a constraint `Concrete# (F ty1)` and a coercion witnessing the reduction of + `F`, say `co :: F ty1 ~# ty2`, then we will solve `Concrete# (F ty1)` in terms of `Concrete# ty2`, + by rewriting the evidence for `Concrete# ty2` using `co` (see GHC.Tc.Solver.Canonical.rewriteEvidence). + + 3. Backpack + + Abstract 'TyCon's in Backpack signature files are always considered to be concrete. + This is because of the strong restrictions around how abstract types are allowed + to be implemented, as laid out in Note [Synonyms implement abstract data] in GHC.Tc.Module. + In particular, no variables or type family applications are allowed. + + Examples: backpack/should_run/T13955.bkp, rep-poly/RepPolyBackpack2. +-} + +-- | A coercion hole used to store evidence for `Concrete#` constraints. +-- +-- See Note [The Concrete mechanism]. +type ConcreteHole = CoercionHole + +-- | Evidence for a `Concrete#` constraint: +-- essentially a 'ConcreteHole' (a coercion hole) that will be filled later, +-- except: +-- +-- - we might already have the evidence now; no point in creating a coercion hole +-- in that case; +-- - we sometimes skip the check entirely, e.g. in Typed Template Haskell +-- (see [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]). +data ConcreteEvidence + = ConcreteReflEvidence + -- ^ We have evidence right now: don't bother creating a 'ConcreteHole'. + | ConcreteTypedTHNoEvidence + -- ^ We don't emit 'Concrete#' constraints in Typed Template Haskell. + -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]. + | ConcreteHoleEvidence ConcreteHole + -- ^ The general form of evidence: a 'ConcreteHole' that should be + -- filled in later by the constraint solver, as per + -- Note [Solving Concrete# constraints]. + +-- | Check that the kind of the provided type is of the form +-- @TYPE rep@ for a __fixed__ 'RuntimeRep' @rep@. +-- +-- If this isn't immediately obvious, for instance if the 'RuntimeRep' +-- is hidden under a type-family application such as +-- +-- > ty :: TYPE (F x) +-- +-- this function will emit a new Wanted 'Concrete#' constraint. +hasFixedRuntimeRep :: FRROrigin -> Type -> TcM ConcreteEvidence +hasFixedRuntimeRep frrOrig ty + + -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms. + | TyConApp tc [] <- ki + , tc == liftedTypeKindTyCon || tc == unliftedTypeKindTyCon + = return ConcreteReflEvidence + + | otherwise + = do { th_stage <- getStage + ; if + -- We have evidence for 'Concrete# ty' right now: + -- no need to emit a constraint/create an evidence hole. + | isConcrete ki + -> return ConcreteReflEvidence + + -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]. + | Brack _ (TcPending {}) <- th_stage + -> return ConcreteTypedTHNoEvidence + + -- Create a new Wanted 'Concrete#' constraint and emit it. + | otherwise + -> do { loc <- getCtLocM (FixedRuntimeRepOrigin ty frrOrig) (Just KindLevel) + ; (hole, ct_ev) <- newConcretePrimWanted loc ki + ; emitSimple $ mkNonCanonical ct_ev + ; return $ ConcreteHoleEvidence hole } } + where + ki :: Kind + ki = typeKind ty + +-- | Create a new (initially unfilled) coercion hole, +-- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint. +newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy') + -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep') + -> TcM ConcreteHole +newConcreteHole ki ty + = do { concrete_ty <- newFlexiTyVarTy ki + ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty + ; newCoercionHole co_ty } + +-- | Create a new 'Concrete#' constraint. +newConcretePrimWanted :: CtLoc -> Type -> TcM (ConcreteHole, CtEvidence) +newConcretePrimWanted loc ty + = do { let + ki :: Kind + ki = typeKind ty + ; hole <- newConcreteHole ki ty + ; let + wantedCtEv :: CtEvidence + wantedCtEv = + CtWanted + { ctev_dest = HoleDest hole + , ctev_pred = mkTyConApp concretePrimTyCon [ki, ty] + , ctev_nosh = WOnly -- WOnly, because Derived Concrete# constraints + -- aren't useful: solving a Concrete# constraint + -- can't cause any unification to take place. + , ctev_loc = loc + } + ; return (hole, wantedCtEv) } + +{-*********************************************************************** +* * + HsWrapper +* * +***********************************************************************-} + +-- | Smart constructor to create a 'WpFun' 'HsWrapper'. +-- +-- Might emit a 'Concrete#' constraint, to check for +-- representation polymorphism. This is necessary, as 'WpFun' will desugar to +-- a lambda abstraction, whose binder must have a fixed runtime representation. +mkWpFun :: HsWrapper -> HsWrapper + -> Scaled TcType -- ^ the "from" type of the first wrapper + -> TcType -- ^ either type of the second wrapper (used only when the + -- second wrapper is the identity) + -> WpFunOrigin -- ^ what caused you to want a WpFun? + -> TcM HsWrapper +mkWpFun WpHole WpHole _ _ _ = return $ WpHole +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ _ = return $ WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 _ wpFunOrig + = do { _concrete_ev <- hasFixedRuntimeRep (FRRWpFun wpFunOrig) (scaledThing t1) + ; return $ WpFun co1 co2 t1 } diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -69,12 +69,13 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence import GHC.Tc.Instance.FunDeps +import GHC.Tc.Utils.Concrete import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..), Arity ) import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc @@ -95,7 +96,7 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE -import Control.Monad( unless ) +import Control.Monad( when, unless, void ) import Data.Function ( on ) {- @@ -740,10 +741,10 @@ -} tcSyntaxName :: CtOrigin - -> TcType -- ^ Type to instantiate it at - -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) + -> TcType -- ^ Type to instantiate it at + -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) -> TcM (Name, HsExpr GhcTc) - -- ^ (Standard name, suitable expression) + -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" @@ -755,35 +756,69 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do std_id <- tcLookupId std_nm let - -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) sigma1 = substTyWith [tv] [ty] tau -- Actually, the "tau-type" might be a sigma-type in the -- case of locally-polymorphic methods. - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do + span <- getSrcSpanM + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do -- Check that the user-supplied thing has the -- same type as the standard one. -- Tiresome jiggling because tcCheckSigma takes a located expression - span <- getSrcSpanM expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1 + hasFixedRuntimeRepRes std_nm user_nm_expr sigma1 return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) +syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg) + where + msg = vcat [ text "When checking that" <+> quotes (ppr name) <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (pprCtLoc inst_loc) ] - ; return (tidy_env, msg) } + , nest 2 (text "has the required type:" + <+> ppr (tidyType tidy_env ty)) + , nest 2 (sep [ppr orig, text "at" <+> ppr loc])] {- ************************************************************************ * * + FixedRuntimeRep +* * +************************************************************************ +-} + +-- | Check that the result type of an expression has a fixed runtime representation. +-- +-- Used only for arrow operations such as 'arr', 'first', etc. +hasFixedRuntimeRepRes :: Name -> HsExpr GhcRn -> TcSigmaType -> TcM () +hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity + where + do_check :: Arity -> TcM () + do_check arity = + let res_ty = nTimes arity (snd . splitPiTy) ty + in void $ hasFixedRuntimeRep (FRRArrow $ ArrowFun user_expr) res_ty + mb_arity :: Maybe Arity + mb_arity -- arity of the arrow operation, counting type-level arguments + | std_nm == arrAName -- result used as an argument in, e.g., do_premap + = Just 3 + | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + = Just 5 + | std_nm == firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + = Just 4 + | std_nm == appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp + = Just 2 + | std_nm == choiceAName -- result used as an argument in, e.g., HsCmdIf + = Just 5 + | std_nm == loopAName -- result used as an argument in, e.g., HsCmdIf + = Just 4 + | otherwise + = Nothing + +{- +************************************************************************ +* * Instances * * ************************************************************************ @@ -827,7 +862,8 @@ ; oflag <- getOverlapFlag overlap_mode ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIf (isOrphan (is_orphan inst)) (TcRnOrphanInstance inst) + ; when (isOrphan (is_orphan inst)) $ + addDiagnostic (TcRnOrphanInstance inst) ; return inst } tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -351,6 +351,7 @@ tcg_dependent_files = dependent_files_var, tcg_tc_plugin_solvers = [], tcg_tc_plugin_rewriters = emptyUFM, + tcg_defaulting_plugins = [], tcg_hf_plugins = [], tcg_top_loc = loc, tcg_static_wc = static_wc_var, @@ -2086,7 +2087,7 @@ if_doc = text "initIfaceLoad", if_rec_types = emptyKnotVars } - initTcRnIf 'i' hsc_env gbl_env () do_this + initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this -- | This is used when we are doing to call 'typecheckModule' on an 'ModIface', -- if it's part of a loop with some other modules then we need to use their diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -66,7 +66,7 @@ -------------------------------- -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, + zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins, tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarToTyVar, zonkInvisTVBinder, @@ -93,7 +93,7 @@ ------------------------------ -- Representation polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, + checkTypeHasFixedRuntimeRep, ) where import GHC.Prelude @@ -116,6 +116,7 @@ import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.Predicate +import GHC.Core.InstEnv (ClsInst(is_tys)) import GHC.Types.Var import GHC.Types.Id as Id @@ -127,7 +128,8 @@ import GHC.Types.Var.Env import GHC.Types.Name.Env import GHC.Types.Unique.Set -import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) + , DefaultKindVars(..), DefaultVarsOfKind(..), allVarsOfKindDefault ) import GHC.Data.FastString import GHC.Data.Bag @@ -203,7 +205,7 @@ cloneWanted :: Ct -> TcM Ct cloneWanted ct - | ev@(CtWanted { ctev_pred = pty }) <- ctEvidence ct + | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct = do { co_hole <- newCoercionHole pty ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } | otherwise @@ -307,6 +309,9 @@ EqPred {} -> mkVarOccFS (fsLit "co") IrredPred {} -> mkVarOccFS (fsLit "irred") ForAllPred {} -> mkVarOccFS (fsLit "df") + SpecialPred special_pred _ -> + case special_pred of + ConcretePrimPred -> mkVarOccFS (fsLit "concr") -- | Create a new 'Implication' with as many sensible defaults for its fields -- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do @@ -987,10 +992,10 @@ zonked_ty_lvl = tcTypeLevel zonked_ty level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - kind_check_ok = tcIsConstraintKind zonked_tv_kind - || tcEqKind zonked_ty_kind zonked_tv_kind - -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType - -- Note [Extra-constraint holes in partial type signatures] + kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind + -- Hack alert! eqType, not tcEqType. see: + -- Note [coreView vs tcView] in GHC.Core.Type + -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType kind_msg = hang (text "Ill-kinded update to meta tyvar") 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) @@ -1686,7 +1691,8 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: CandidatesQTvs -- See Note [Dependent type variables] +quantifyTyVars :: DefaultVarsOfKind + -> CandidatesQTvs -- See Note [Dependent type variables] -- Already zonked -> TcM [TcTyVar] -- See Note [quantifyTyVars] @@ -1696,16 +1702,18 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars dvs +quantifyTyVars def_varsOfKind dvs -- short-circuit common case | isEmptyCandidates dvs = do { traceTc "quantifyTyVars has nothing to quantify" empty ; return [] } | otherwise - = do { traceTc "quantifyTyVars {" (ppr dvs) + = do { traceTc "quantifyTyVars {" + ( vcat [ text "def_varsOfKind =" <+> ppr def_varsOfKind + , text "dvs =" <+> ppr dvs ]) - ; undefaulted <- defaultTyVars dvs + ; undefaulted <- defaultTyVars def_varsOfKind dvs ; final_qtvs <- mapMaybeM zonk_quant undefaulted ; traceTc "quantifyTyVars }" @@ -1783,11 +1791,12 @@ _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk -defaultTyVar :: Bool -- True <=> please default this kind variable to * +defaultTyVar :: DefaultKindVars + -> DefaultVarsOfKind -> TcTyVar -- If it's a MetaTyVar then it is unbound -> TcM Bool -- True <=> defaulted away altogether -defaultTyVar default_kind tv +defaultTyVar def_kindVars def_varsOfKind tv | not (isMetaTyVar tv) = return False @@ -1799,22 +1808,26 @@ = return False - | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var - -- unless it is a TyVarTv, handled earlier + | isRuntimeRepVar tv + , def_runtimeRep def_varsOfKind + -- Do not quantify over a RuntimeRep var + -- unless it is a TyVarTv, handled earlier = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) ; writeMetaTyVar tv liftedRepTy ; return True } | isLevityVar tv + , def_levity def_varsOfKind = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) ; writeMetaTyVar tv liftedDataConTy ; return True } | isMultiplicityVar tv + , def_multiplicity def_varsOfKind = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv) ; writeMetaTyVar tv manyDataConTy ; return True } - | default_kind -- -XNoPolyKinds and this is a kind var - = default_kind_var tv -- so default it to * if possible + | DefaultKinds <- def_kindVars -- -XNoPolyKinds and this is a kind var + = default_kind_var tv -- so default it to * if possible | otherwise = return False @@ -1851,12 +1864,15 @@ -- Multiplicity tyvars default to Many -- Type tyvars from dv_kvs default to Type, when -XNoPolyKinds -- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) -defaultTyVars :: CandidatesQTvs -- ^ all candidates for quantification +defaultTyVars :: DefaultVarsOfKind + -> CandidatesQTvs -- ^ all candidates for quantification -> TcM [TcTyVar] -- ^ those variables not defaulted -defaultTyVars dvs +defaultTyVars def_varsOfKind dvs = do { poly_kinds <- xoptM LangExt.PolyKinds - ; defaulted_kvs <- mapM (defaultTyVar (not poly_kinds)) dep_kvs - ; defaulted_tvs <- mapM (defaultTyVar False) nondep_tvs + ; let + def_kinds = if poly_kinds then Don'tDefaultKinds else DefaultKinds + ; defaulted_kvs <- mapM (defaultTyVar def_kinds def_varsOfKind ) dep_kvs + ; defaulted_tvs <- mapM (defaultTyVar Don'tDefaultKinds def_varsOfKind ) nondep_tvs ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] ; return (undefaulted_kvs ++ undefaulted_tvs) } @@ -2013,7 +2029,7 @@ | otherwise = do { traceTc "doNotQuantifyTyVars" (ppr dvs) - ; undefaulted <- defaultTyVars dvs + ; undefaulted <- defaultTyVars allVarsOfKindDefault dvs -- could have regular TyVars here, in an associated type RHS, or -- bound by a type declaration head. So filter looking only for -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` @@ -2550,8 +2566,20 @@ ; (env2, p2') <- zonkTidyTcType env1 p2 ; (env3, o1') <- zonkTidyOrigin env2 o1 ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env (CycleBreakerOrigin orig) + = do { (env1, orig') <- zonkTidyOrigin env orig + ; return (env1, CycleBreakerOrigin orig') } +zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) + = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) + ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } +zonkTidyOrigin env (FixedRuntimeRepOrigin ty frr_orig) + = do { (env1, ty') <- zonkTidyTcType env ty + ; return (env1, FixedRuntimeRepOrigin ty' frr_orig)} zonkTidyOrigin env orig = return (env, orig) +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin]) +zonkTidyOrigins = mapAccumLM zonkTidyOrigin + ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting @@ -2614,43 +2642,22 @@ %* * Representation polymorphism checks * * -************************************************************************* - -See Note [Representation polymorphism checking] in GHC.HsToCore.Monad - --} - --- | According to the rules around representation polymorphism --- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotLevPoly :: Type -- its zonked type - -> LevityCheckProvenance -- where this happened - -> TcM () -ensureNotLevPoly ty provenance - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly provenance ty - - -- See Note [Representation polymorphism checking] in GHC.HsToCore.Monad -checkForLevPoly :: LevityCheckProvenance -> Type -> TcM () -checkForLevPoly = checkForLevPolyX (\ty -> addDetailedDiagnostic . TcLevityPolyInType ty) +***********************************************************************-} -checkForLevPolyX :: Monad m - => (Type -> LevityCheckProvenance -> m ()) -- how to report an error - -> LevityCheckProvenance - -> Type - -> m () -checkForLevPolyX add_err provenance ty - | isTypeLevPoly ty - = add_err ty provenance - | otherwise - = return () +-- | Check that the specified type has a fixed runtime representation. +-- +-- If it isn't, throw a representation-polymorphism error appropriate +-- for the context (as specified by the 'FixedRuntimeRepProvenance'). +-- +-- Unlike the other representation polymorphism checks, which emit +-- 'Concrete#' constraints, this function does not emit any constraints, +-- as it has enough information to immediately make a decision. +-- +-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () +checkTypeHasFixedRuntimeRep prov ty = + unless (typeHasFixedRuntimeRep ty) + (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) {- %************************************************************************ diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -43,18 +43,23 @@ import GHC.Hs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Concrete ( mkWpFun ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Env + + import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity + import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin import GHC.Types.Name( isSystemName ) -import GHC.Tc.Utils.Instantiate + import GHC.Core.TyCon import GHC.Builtin.Types import GHC.Types.Var as Var @@ -210,13 +215,9 @@ (n_val_args_wanted, so_far) fun_ty ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 - ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc + ; wrap_fun2 <- mkWpFun idHsWrapper wrap_res arg_ty1 res_ty (WpFunFunTy fun_ty) ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr fun_ty) - {- ************************************************************************ * * @@ -320,11 +321,8 @@ = assert (af == VisArg) $ do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty - ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc + ; fun_wrap <- mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty (WpFunFunExpTy orig_ty) ; return ( fun_wrap, result ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) go acc_arg_tys n ty@(TyVarTy tv) | isMetaTyVar tv @@ -779,7 +777,7 @@ returned by tcSubMult (and derived functions such as tcCheckUsage and checkManyPattern) is quite unlike any other wrapper: it checks whether the coercion produced by the constraint solver is trivial, producing a type error -is it is not. This is implemented via the WpMultCoercion wrapper, as desugared +if it is not. This is implemented via the WpMultCoercion wrapper, as desugared by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check. This wrapper needs to be placed in the term; otherwise, checking of the @@ -788,11 +786,14 @@ Why do we check this in the desugarer? It's a convenient place, since it's right after all the constraints are solved. We need the constraints to be -solved to check whether they are trivial or not. Plus there is precedent for -type errors during desuraging (such as the representation polymorphism -restriction). An alternative would be to have a kind of constraint which can -only produce trivial evidence, then this check would happen in the constraint -solver (#18756). +solved to check whether they are trivial or not. + +An alternative would be to have a kind of constraint which can +only produce trivial evidence. This would allow such checks to happen +in the constraint solver (#18756). +This would be similar to the existing setup for Concrete, see + Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete + (PHASE 1 in particular). -} tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper @@ -1763,38 +1764,6 @@ Revisited in Nov '20, along with removing flattening variables. Problem is still present, and the solution is still the same. - -Note [Refactoring hazard: metaTyVarUpdateOK] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Richard E.) have a sad story about refactoring this code, retained here -to prevent others (or a future me!) from falling into the same traps. - -It all started with #11407, which was caused by the fact that the TyVarTy -case of defer_me didn't look in the kind. But it seemed reasonable to -simply remove the defer_me check instead. - -It referred to two Notes (since removed) that were out of date, and the -fast_check code in occurCheckExpand seemed to do just about the same thing as -defer_me. The one piece that defer_me did that wasn't repeated by -occurCheckExpand was the type-family check. (See Note [Prevent unification -with type families].) So I checked the result of occurCheckExpand for any -type family occurrences and deferred if there were any. This was done -in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . - -This approach turned out not to be performant, because the expanded -type was bigger than the original type, and tyConsOfType (needed to -see if there are any type family occurrences) looks through type -synonyms. So it then struck me that we could dispense with the -defer_me check entirely. This simplified the code nicely, and it cut -the allocations in T5030 by half. But, as documented in Note [Prevent -unification with type families], this destroyed performance in -T3064. Regardless, I missed this regression and the change was -committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . - -Bottom lines: - * defer_me is back, but now fixed w.r.t. #11407. - * Tread carefully before you start to refactor here. There can be - lots of hard-to-predict consequences. Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -49,7 +49,6 @@ import GHC.Hs -import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) @@ -387,8 +386,6 @@ zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - ensureNotLevPoly ty' (LevityCheckInBinder v) - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] @@ -1065,10 +1062,10 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkScaledTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1' d) } +zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; t1' <- zonkScaledTcTypeToTypeX env2 t1 + ; return (env2, WpFun c1' c2' t1') } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev @@ -1348,7 +1345,6 @@ zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' LevityCheckInWildcardPattern ; return (env, WildPat ty') } zonk_pat env (VarPat x (L l v)) @@ -1389,8 +1385,7 @@ ; (env', pat') <- zonkPat env pat ; return (env', SumPat tys' pat' alt arity) } -zonk_pat env p@(ConPat { pat_con = L _ con - , pat_args = args +zonk_pat env p@(ConPat { pat_args = args , pat_con_ext = p'@(ConPatTc { cpt_tvs = tyvars , cpt_dicts = evs @@ -1401,16 +1396,6 @@ }) = assert (all isImmutableTyVar tyvars) $ do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - - -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have representation-polymorphic arguments. - -- Check for this badness. - ; case con of - RealDataCon dc - | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly (LevityCheckInUnboxedTuplePattern p)) (dropRuntimeRepArgs new_tys) - _ -> return () - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars -- Must zonk the existential variables, because their -- /kind/ need potential zonking. diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -32,7 +33,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes ) -import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy ) +import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) @@ -692,8 +693,10 @@ check_type ve ty@(TyConApp tc tys) | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc = check_syn_tc_app ve ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys - | otherwise = mapM_ (check_arg_type False ve) tys + | isUnboxedTupleTyCon tc + = check_ubx_tuple ve ty tys + | otherwise + = mapM_ (check_arg_type False ve) tys check_type _ (LitTy {}) = return () @@ -1384,11 +1387,12 @@ Note [Instances of built-in classes in signature files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -User defined instances for KnownNat, KnownSymbol and Typeable are -disallowed -- they are generated when needed by GHC itself on-the-fly. +User defined instances for KnownNat, KnownSymbol, KnownChar, +and Typeable are disallowed + -- they are generated when needed by GHC itself, on-the-fly. However, if they occur in a Backpack signature file, they have an -entirely different meaning. Suppose in M.hsig we see +entirely different meaning. To illustrate, suppose in M.hsig we see signature M where data T :: Nat @@ -1407,6 +1411,7 @@ check_special_inst_head :: DynFlags -> Bool -> Bool -> UserTypeCtxt -> Class -> [Type] -> TcM () -- Wow! There are a surprising number of ad-hoc special cases here. +-- TODO: common up the logic for special typeclasses (see GHC ticket #20441). check_special_inst_head dflags is_boot is_sig ctxt clas cls_args -- If not in an hs-boot file, abstract classes cannot have instances @@ -1421,15 +1426,15 @@ , not is_sig -- Note [Instances of built-in classes in signature files] , hand_written_bindings - = failWithTc rejected_class_msg + = failWithTc $ TcRnSpecialClassInst clas False - -- Handwritten instances of KnownNat/KnownSymbol class - -- are always forbidden (#12837) + -- Handwritten instances of KnownNat/KnownSymbol + -- are forbidden outside of signature files (#12837) | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] , not is_sig -- Note [Instances of built-in classes in signature files] , hand_written_bindings - = failWithTc rejected_class_msg + = failWithTc $ TcRnSpecialClassInst clas False -- For the most part we don't allow -- instances for (~), (~~), or Coercible; @@ -1437,12 +1442,12 @@ -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ] , not quantified_constraint - = failWithTc rejected_class_msg + = failWithTc $ TcRnSpecialClassInst clas False -- Check for hand-written Generic instances (disallowed in Safe Haskell) | clas_nm `elem` genericClassNames , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) gen_inst_err + = do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True) ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName @@ -1501,18 +1506,6 @@ text "Only one type can be given in an instance head." $$ text "Use MultiParamTypeClasses if you want to allow more, or zero." - rejected_class_msg :: TcRnMessage - rejected_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ rejected_class_doc - - rejected_class_doc :: SDoc - rejected_class_doc = - text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - - gen_inst_err :: TcRnMessage - gen_inst_err = TcRnUnknownMessage $ mkPlainError noHints $ - rejected_class_doc $$ nest 2 (text "(in Safe Haskell)") - mb_ty_args_msg | not (xopt LangExt.TypeSynonymInstances dflags) , not (all tcInstHeadTyNotSynonym ty_args) @@ -1819,8 +1812,9 @@ check :: VarSet -> PredType -> TcM () check foralld_tvs pred = case classifyPredType pred of - EqPred {} -> return () -- See #4200. - IrredPred {} -> check2 foralld_tvs pred (sizeType pred) + EqPred {} -> return () -- See #4200. + SpecialPred {} -> return () + IrredPred {} -> check2 foralld_tvs pred (sizeType pred) ClassPred cls tys | isTerminatingClass cls -> return () @@ -2834,6 +2828,7 @@ -- The filtering looks bogus -- See Note [Invisible arguments and termination] go (EqPred {}) = 0 + go (SpecialPred {}) = 0 go (IrredPred ty) = sizeType ty go (ForAllPred _ _ pred) = goClass pred diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Unit/Finder.hs @@ -0,0 +1,665 @@ +{- +(c) The University of Glasgow, 2000-2006 + +-} + + +{-# LANGUAGE FlexibleContexts #-} + +-- | Module finder +module GHC.Unit.Finder ( + FindResult(..), + InstalledFindResult(..), + FinderOpts(..), + FinderCache, + initFinderCache, + flushFinderCaches, + findImportedModule, + findPluginModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + mkHiPath, + mkObjPath, + addHomeModuleToFinder, + uncacheModule, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + -- Hash cache + lookupFileCache + ) where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Builtin.Names ( gHC_PRIM ) + +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Home +import GHC.Unit.State +import GHC.Unit.Finder.Types + +import GHC.Data.Maybe ( expectJust ) +import qualified GHC.Data.ShortText as ST + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Linker.Types +import GHC.Types.PkgQual + +import GHC.Fingerprint +import Data.IORef +import System.Directory +import System.FilePath +import Control.Monad +import Data.Time +import qualified Data.Map as M + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllUnits for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + + +initFinderCache :: IO FinderCache +initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv + <*> newIORef M.empty + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session; also flush the file hash +-- cache +flushFinderCaches :: FinderCache -> HomeUnit -> IO () +flushFinderCaches (FinderCache ref file_ref) home_unit = do + atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + atomicModifyIORef' file_ref $ \_ -> (M.empty, ()) + where + is_ext mod _ = not (isHomeInstalledModule home_unit mod) + +addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO () +addToFinderCache (FinderCache ref _) key val = + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) + +removeFromFinderCache :: FinderCache -> InstalledModule -> IO () +removeFromFinderCache (FinderCache ref _) key = + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) + +lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) +lookupFinderCache (FinderCache ref _) key = do + c <- readIORef ref + return $! lookupInstalledModuleEnv c key + +lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint +lookupFileCache (FinderCache _ ref) key = do + c <- readIORef ref + case M.lookup key c of + Nothing -> do + hash <- getFileHash key + atomicModifyIORef' ref $ \c -> (M.insert key hash c, ()) + return hash + Just fp -> return fp + +-- ----------------------------------------------------------------------------- +-- The three external entry points + + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule + :: FinderCache + -> FinderOpts + -> UnitState + -> HomeUnit + -> ModuleName + -> PkgQual + -> IO FindResult +findImportedModule fc fopts units home_unit mod_name mb_pkg = + case mb_pkg of + NoPkgQual -> unqual_import + ThisPkg _ -> home_import + OtherPkg _ -> pkg_import + where + home_import = findHomeModule fc fopts home_unit mod_name + pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule fc fopts units mod_name NoPkgQual + +-- | Locate a plugin module requested by the user, for a compiler +-- plugin. This consults the same set of exposed packages as +-- 'findImportedModule', unless @-hide-all-plugin-packages@ or +-- @-plugin-package@ are specified. +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult +findPluginModule fc fopts units home_unit mod_name = + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + findExposedPluginPackageModule fc fopts units mod_name + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult +findExactModule fc fopts unit_state home_unit mod = do + if isHomeInstalledModule home_unit mod + then findInstalledHomeModule fc fopts home_unit (moduleName mod) + else findPackageModule fc unit_state fopts mod + +-- ----------------------------------------------------------------------------- +-- Helpers + +-- | Given a monadic actions @this@ and @or_this@, first execute +-- @this@. If the returned 'FindResult' is successful, return +-- it; otherwise, execute @or_this@. If both failed, this function +-- also combines their failure messages in a reasonable way. +orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + _other -> return res + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache fc home_unit mod_name do_this = do + let mod = mkHomeInstalledModule home_unit mod_name + modLocationCache fc mod do_this + +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult +findExposedPackageModule fc fopts units mod_name mb_pkg = + findLookupResult fc fopts + $ lookupModuleWithSuggestions units mod_name mb_pkg + +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult +findExposedPluginPackageModule fc fopts units mod_name = + findLookupResult fc fopts + $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual + +findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult +findLookupResult fc fopts r = case r of + LookupFound m pkg_conf -> do + let im = fst (getModuleInstantiation m) + r' <- findPackageModule_ fc fopts im (fst pkg_conf) + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = []}) + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens + , fr_unusables = [] + , fr_suggestions = [] }) + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (m, ModUnusable r) = (moduleUnit m, r) + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = unusables' + , fr_suggestions = [] }) + LookupNotFound suggest -> do + let suggest' + | finder_enableSuggestions fopts = suggest + | otherwise = [] + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = suggest' }) + +modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult +modLocationCache fc mod do_this = do + m <- lookupFinderCache fc mod + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache fc mod result + return result + +-- This returns a module because it's more convenient for users +addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder fc home_unit mod_name loc = do + let mod = mkHomeInstalledModule home_unit mod_name + addToFinderCache fc mod (InstalledFound loc mod) + return (mkHomeModule home_unit mod_name) + +uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO () +uncacheModule fc home_unit mod_name = do + let mod = mkHomeInstalledModule home_unit mod_name + removeFromFinderCache fc mod + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult +findHomeModule fc fopts home_unit mod_name = do + let uid = homeUnitAsUnit home_unit + r <- findInstalledHomeModule fc fopts home_unit mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the unit id associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findInstalledHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule fc fopts home_unit mod_name = do + homeSearchCache fc home_unit mod_name $ + let + home_path = finder_importPaths fopts + hisuf = finder_hiSuf fopts + mod = mkHomeInstalledModule home_unit mod_name + + source_exts = + [ ("hs", mkHomeModLocationSearched fopts mod_name "hs") + , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs") + , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig") + ] + + -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that + -- when hiDir field is set in dflags, we know to look there (see #16500) + hi_exts = [ (hisuf, mkHomeModHiOnlyLocation fopts mod_name) + , (addBootSuffix hisuf, mkHomeModHiOnlyLocation fopts mod_name) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | finder_lookupHomeInterfaces fopts = hi_exts + | otherwise = source_exts + in + + -- special case for GHC.Prim; we won't find it in the filesystem. + -- This is important only when compiling the base package (where GHC.Prim + -- is a home module). + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else searchPathExts home_path mod exts + + +-- | Search for a module in external packages only. +findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult +findPackageModule fc unit_state fopts mod = do + let pkg_id = moduleUnit mod + case lookupUnitId unit_state pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) + Just u -> findPackageModule_ fc fopts mod u + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2) +-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ fc fopts mod pkg_conf = do + massertPpr (moduleUnit mod == unitId pkg_conf) + (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf)) + modLocationCache fc mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else + + let + tag = waysBuildTag (finder_ways fopts) + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + + package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf + + import_dirs = map ST.unpack $ unitImportDirs pkg_conf + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + in + case import_dirs of + [one] | finder_bypassHiFileCheck fopts -> + -- there's only one place that this .hi file can be, so + -- don't bother looking for it. + let basename = moduleNameSlashes (moduleName mod) + loc = mk_hi_loc one basename + in return $ InstalledFound loc mod + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts :: [FilePath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts = search to_search + where + basename = moduleNameSlashes (moduleName mod) + + to_search :: [(FilePath, ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] + + search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) + + search ((file, loc) : rest) = do + b <- doesFileExist file + if b + then return $ InstalledFound loc mod + else search rest + +mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt + -> FilePath -> BaseName -> ModLocation +mkHomeModLocationSearched fopts mod suff path basename = + mkHomeModLocation2 fopts mod (path basename) suff + + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation +mkHomeModLocation dflags mod src_filename = + let (basename,extension) = splitExtension src_filename + in mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: FinderOpts + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> ModLocation +mkHomeModLocation2 fopts mod src_basename ext = + let mod_basename = moduleNameSlashes mod + + obj_fn = mkObjPath fopts src_basename mod_basename + dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename + hi_fn = mkHiPath fopts src_basename mod_basename + dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename + hie_fn = mkHiePath fopts src_basename mod_basename + + in (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + ml_hi_file = hi_fn, + ml_dyn_hi_file = dyn_hi_fn, + ml_obj_file = obj_fn, + ml_dyn_obj_file = dyn_obj_fn, + ml_hie_file = hie_fn }) + +mkHomeModHiOnlyLocation :: FinderOpts + -> ModuleName + -> FilePath + -> BaseName + -> ModLocation +mkHomeModHiOnlyLocation fopts mod path basename = + let loc = mkHomeModLocation2 fopts mod (path basename) "" + in loc { ml_hs_file = Nothing } + +-- This function is used to make a ModLocation for a package module. Hence why +-- we explicitly pass in the interface file suffixes. +mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String + -> ModLocation +mkHiOnlyModLocation fopts hisuf dynhisuf path basename + = let full_basename = path basename + obj_fn = mkObjPath fopts full_basename basename + dyn_obj_fn = mkDynObjPath fopts full_basename basename + hie_fn = mkHiePath fopts full_basename basename + in ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_dyn_obj_file = dyn_obj_fn, + -- MP: TODO + ml_dyn_hi_file = full_basename <.> dynhisuf, + ml_obj_file = obj_fn, + ml_hie_file = hie_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkObjPath fopts basename mod_basename = obj_basename <.> osuf + where + odir = finder_objectDir fopts + osuf = finder_objectSuf fopts + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .dyn_o file for a given source file. +-- Does /not/ check whether the .dyn_o file exists +mkDynObjPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf + where + odir = finder_objectDir fopts + dynosuf = finder_dynObjectSuf fopts + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiPath fopts basename mod_basename = hi_basename <.> hisuf + where + hidir = finder_hiDir fopts + hisuf = finder_hiSuf fopts + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .dyn_hi file for a given source file. +-- Does /not/ check whether the .dyn_hi file exists +mkDynHiPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf + where + hidir = finder_hiDir fopts + dynhisuf = finder_dynHiSuf fopts + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + +-- | Constructs the filename of a .hie file for a given source file. +-- Does /not/ check whether the .hie file exists +mkHiePath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf + where + hiedir = finder_hieDir fopts + hiesuf = finder_hieSuf fopts + + hie_basename | Just dir <- hiedir = dir mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: FinderOpts + -> ModuleName + -> ModLocation + -> FilePath + +mkStubPaths fopts mod location + = let + stubdir = finder_stubDir fopts + + mod_basename = moduleNameSlashes mod + src_basename = dropExtension $ expectJust "mkStubPaths" + (ml_hs_file location) + + stub_basename0 + | Just dir <- stubdir = dir mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + stub_basename <.> "h" + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20211001 +version: 0.20211101 license: BSD3 license-file: LICENSE category: Development @@ -64,24 +64,24 @@ else build-depends: Win32 build-depends: - ghc-prim > 0.2 && < 0.8, base >= 4.14 && < 4.17, + ghc-prim > 0.2 && < 0.9, + bytestring >= 0.9 && < 0.12, + time >= 1.4 && < 1.12, + exceptions == 0.10.*, + parsec, containers >= 0.5 && < 0.7, - bytestring >= 0.9 && < 0.11, binary == 0.8.*, filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.5, pretty == 1.1.*, - time >= 1.4 && < 1.10, transformers == 0.5.*, process >= 1 && < 1.7, - exceptions == 0.10.*, - parsec, rts, hpc == 0.6.*, - ghc-lib-parser == 0.20211001, + ghc-lib-parser == 0.20211101, stm build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: @@ -223,7 +223,6 @@ GHC.Driver.CmdLine, GHC.Driver.Config, GHC.Driver.Config.Diagnostic, - GHC.Driver.Config.Finder, GHC.Driver.Config.Logger, GHC.Driver.Config.Parser, GHC.Driver.Env, @@ -340,6 +339,7 @@ GHC.Types.Annotations, GHC.Types.Avail, GHC.Types.Basic, + GHC.Types.BreakInfo, GHC.Types.CompleteMatch, GHC.Types.CostCentre, GHC.Types.CostCentre.State, @@ -367,6 +367,7 @@ GHC.Types.Name.Ppr, GHC.Types.Name.Reader, GHC.Types.Name.Set, + GHC.Types.PkgQual, GHC.Types.RepType, GHC.Types.SafeHaskell, GHC.Types.SourceError, @@ -393,7 +394,6 @@ GHC.Unit.Database, GHC.Unit.Env, GHC.Unit.External, - GHC.Unit.Finder, GHC.Unit.Finder.Types, GHC.Unit.Home, GHC.Unit.Home.ModInfo, @@ -616,6 +616,7 @@ GHC.Driver.Backpack GHC.Driver.CodeOutput GHC.Driver.Config.CmmToAsm + GHC.Driver.Config.Finder GHC.Driver.GenerateCgIPEStub GHC.Driver.Main GHC.Driver.Make @@ -779,6 +780,7 @@ GHC.Tc.TyCl.Utils GHC.Tc.Types.EvTerm GHC.Tc.Utils.Backpack + GHC.Tc.Utils.Concrete GHC.Tc.Utils.Env GHC.Tc.Utils.Instantiate GHC.Tc.Utils.Monad @@ -789,6 +791,7 @@ GHC.ThToHs GHC.Types.Name.Shape GHC.Types.TyThing.Ppr + GHC.Unit.Finder GHC.Utils.Asm GHC.Utils.Monad.State.Lazy GHCi.CreateBCO diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -97,7 +97,7 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_BFD_H */ -/* Does GCC support __atomic primitives? */ +/* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 /* Define to 1 if you have the `clock_gettime' function. */ @@ -377,6 +377,9 @@ /* Define to 1 if C symbols have a leading underscore added by the compiler. */ #define LEADING_UNDERSCORE 1 + +/* Define to 1 if we need -latomic for sub-word atomic operations. */ +#define NEED_ATOMIC_LIB 0 /* Define 1 if we need to link code using pthreads with -lpthread */ #define NEED_PTHREAD_LIB 0