packages feed

ghc-lib 0.20211001 → 0.20211101

raw patch · 93 files changed

+4068/−2460 lines, 93 filesdep ~bytestringdep ~ghc-lib-parserdep ~ghc-prim

Dependency ranges changed: bytestring, ghc-lib-parser, ghc-prim, time

Files

compiler/GHC.hs view
@@ -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 ->
compiler/GHC/CmmToAsm.hs view
@@ -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
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -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
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -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
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -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
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -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
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -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
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -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]
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -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 $
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -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
compiler/GHC/Core/Opt/Simplify.hs view
@@ -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 <alts>)...@@ -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
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -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
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -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
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -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 <S(AAAA)>, 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:--   <S,U(U, L)>-   <S(L,S),U>--will be unpacked, but--   <S,U> or <B,U>--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 <L, U(U)>; 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 <L,A> we can-  safely turn it into <S,A>; 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 <S,A> or <B,A> is possible.-   E.g. <B,A> 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 <S,A> 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  {- ************************************************************************
compiler/GHC/Driver/Backpack.hs view
@@ -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)
compiler/GHC/Driver/Config/CmmToAsm.hs view
@@ -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    }
+ compiler/GHC/Driver/Config/Finder.hs view
@@ -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+  }
compiler/GHC/Driver/Main.hs view
@@ -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
compiler/GHC/Driver/Make.hs view
@@ -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++-}
compiler/GHC/Driver/MakeFile.hs view
@@ -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
compiler/GHC/Driver/Pipeline.hs view
@@ -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 <-
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -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
compiler/GHC/Hs/Syn/Type.hs view
@@ -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
compiler/GHC/HsToCore.hs view
@@ -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) }
compiler/GHC/HsToCore/Arrows.hs view
@@ -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
compiler/GHC/HsToCore/Binds.hs view
@@ -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
compiler/GHC/HsToCore/Expr.hs view
@@ -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 ()
compiler/GHC/HsToCore/Expr.hs-boot view
@@ -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
compiler/GHC/HsToCore/ListComp.hs view
@@ -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
compiler/GHC/HsToCore/Match.hs view
@@ -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'
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -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))
compiler/GHC/HsToCore/Monad.hs view
@@ -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
compiler/GHC/HsToCore/Pmc/Utils.hs view
@@ -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
compiler/GHC/HsToCore/Utils.hs view
@@ -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") }  {- ********************************************************************* *                                                                      *
compiler/GHC/Iface/Ext/Ast.hs view
@@ -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
compiler/GHC/Iface/Ext/Types.hs view
@@ -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
compiler/GHC/Iface/Load.hs view
@@ -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
compiler/GHC/Iface/Recomp.hs view
@@ -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))
compiler/GHC/IfaceToCore.hs view
@@ -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
compiler/GHC/Linker/Dynamic.hs view
@@ -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)
compiler/GHC/Linker/Loader.hs view
@@ -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
compiler/GHC/Linker/Static.hs view
@@ -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
compiler/GHC/Plugins.hs view
@@ -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
compiler/GHC/Rename/Bind.hs view
@@ -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  {- ************************************************************************
compiler/GHC/Rename/Env.hs view
@@ -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
compiler/GHC/Rename/Expr.hs view
@@ -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
compiler/GHC/Rename/Names.hs view
@@ -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 "<pkg>" M, then we should-                           -- check that "<pkg>" 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 "<pkg>" M, then we should+                            -- check that "<pkg>" 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) })) }
compiler/GHC/Rename/Unbound.hs view
@@ -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
compiler/GHC/Rename/Utils.hs view
@@ -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
compiler/GHC/Runtime/Eval.hs view
@@ -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)
compiler/GHC/Settings/IO.hs view
@@ -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       }
+ compiler/GHC/StgToCmm/Foreign.hs-boot view
@@ -0,0 +1,6 @@+module GHC.StgToCmm.Foreign where++import GHC.Cmm+import GHC.StgToCmm.Monad++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
compiler/GHC/StgToCmm/Ticky.hs view
@@ -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
compiler/GHC/StgToCmm/Utils.hs view
@@ -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 }
compiler/GHC/Tc/Deriv.hs view
@@ -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")
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -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 <*> ..
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -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 * -> *"  {- ************************************************************************
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -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  ------------------------------------------------------------------
compiler/GHC/Tc/Errors.hs view
@@ -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 $
compiler/GHC/Tc/Errors/Hole.hs view
@@ -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.
compiler/GHC/Tc/Gen/App.hs view
@@ -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) }
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -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') }
compiler/GHC/Tc/Gen/Bind.hs view
@@ -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 = ([],[]) } )}
compiler/GHC/Tc/Gen/Expr.hs view
@@ -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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Gen/Head.hs view
@@ -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
compiler/GHC/Tc/Gen/HsType.hs view
@@ -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.
compiler/GHC/Tc/Gen/Match.hs view
@@ -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
compiler/GHC/Tc/Gen/Pat.hs view
@@ -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
compiler/GHC/Tc/Gen/Rule.hs view
@@ -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
compiler/GHC/Tc/Gen/Sig.hs view
@@ -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)
compiler/GHC/Tc/Instance/Class.hs view
@@ -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)-  {- ******************************************************************** *                                                                     *
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -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
compiler/GHC/Tc/Module.hs view
@@ -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
compiler/GHC/Tc/Plugin.hs view
@@ -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
compiler/GHC/Tc/Solver.hs view
@@ -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 $
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -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 *                                                                      *
compiler/GHC/Tc/Solver/Interact.hs view
@@ -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
compiler/GHC/Tc/Solver/Monad.hs view
@@ -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 }
compiler/GHC/Tc/TyCl.hs view
@@ -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))
compiler/GHC/Tc/TyCl/Build.hs view
@@ -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 }
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -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]
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -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=<B>,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))
+ compiler/GHC/Tc/Utils/Concrete.hs view
@@ -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)+          <nothing, since Lifted is nullary>++  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 }
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -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
compiler/GHC/Tc/Utils/Monad.hs view
@@ -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
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -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)  {- %************************************************************************
compiler/GHC/Tc/Utils/Unify.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -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.
compiler/GHC/Tc/Validity.hs view
@@ -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
+ compiler/GHC/Unit/Finder.hs view
@@ -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)+
ghc-lib.cabal view
@@ -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
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -97,7 +97,7 @@ /* Define to 1 if you have the <bfd.h> 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