ghc-lib 9.10.2.20250515 → 9.10.3.20250912
raw patch · 31 files changed
+660/−264 lines, 31 filesdep ~ghc-lib-parserPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
+ GHC: Opt_InterModuleFarJumps :: GeneralFlag
+ GHC: [maxForcedSpecArgs] :: DynFlags -> Int
+ GHC.CmmToAsm.Config: [ncgEnableInterModuleFarJumps] :: NCGConfig -> !Bool
+ GHC.CmmToAsm.Wasm.Types: [WasmSqrt] :: forall (t :: WasmType) (a :: WasmType) (pre :: [WasmType]). WasmTypeTag t -> WasmInstr a (t ': pre) (t ': pre)
+ GHC.Core.Opt.SpecConstr: SpecFailForcedArgCount :: Name -> SpecFailWarning
+ GHC.Core.Opt.SpecConstr: [spec_failed_fun_name] :: SpecFailWarning -> Name
+ GHC.Core.Opt.SpecConstr: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.SpecConstr.SpecFailWarning
+ GHC.Core.Opt.SpecConstr: newtype SpecFailWarning
+ GHC.Rename.Names: instance GHC.Utils.Outputable.Outputable GHC.Rename.Names.UnusedNames
- GHC: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
+ GHC: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
- GHC.CmmToAsm.Config: NCGConfig :: !Platform -> !SDocContext -> !Module -> !Maybe Int -> !Bool -> !Bool -> !Word -> !Word -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> Maybe SseVersion -> Maybe BmiVersion -> !Bool -> !Bool -> !Bool -> !Weights -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> NCGConfig
+ GHC.CmmToAsm.Config: NCGConfig :: !Platform -> !SDocContext -> !Module -> !Maybe Int -> !Bool -> !Bool -> !Word -> !Word -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> Maybe SseVersion -> Maybe BmiVersion -> !Bool -> !Bool -> !Bool -> !Weights -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> NCGConfig
- GHC.Tc.Gen.Match: tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) => TcMatchAltChecker body -> Scaled TcSigmaTypeFRR -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
+ GHC.Tc.Gen.Match: tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) => HsMatchContextRn -> TcMatchAltChecker body -> Scaled TcSigmaTypeFRR -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
- GHC.Tc.Utils.Env: failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+ GHC.Tc.Utils.Env: failIllegalTyCon :: WhatLooking -> Name -> TcM a
Files
- compiler/GHC/ByteCode/Asm.hs +2/−2
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +22/−7
- compiler/GHC/CmmToAsm/Config.hs +1/−0
- compiler/GHC/CmmToAsm/Wasm/Asm.hs +1/−0
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +26/−4
- compiler/GHC/CmmToAsm/Wasm/Types.hs +1/−0
- compiler/GHC/CmmToLlvm/Base.hs +3/−3
- compiler/GHC/CmmToLlvm/Data.hs +1/−1
- compiler/GHC/Core/Opt/SpecConstr.hs +150/−89
- compiler/GHC/Driver/Config/CmmToAsm.hs +1/−0
- compiler/GHC/Driver/Pipeline/Execute.hs +7/−5
- compiler/GHC/HsToCore/Binds.hs +5/−5
- compiler/GHC/HsToCore/GuardedRHSs.hs +26/−18
- compiler/GHC/Rename/Bind.hs +29/−5
- compiler/GHC/Rename/Env.hs +27/−16
- compiler/GHC/Rename/Expr.hs +2/−2
- compiler/GHC/Rename/Names.hs +126/−25
- compiler/GHC/Settings/IO.hs +36/−28
- compiler/GHC/StgToByteCode.hs +13/−9
- compiler/GHC/SysTools/Ar.hs +1/−1
- compiler/GHC/SysTools/Process.hs +3/−1
- compiler/GHC/Tc/Gen/Arrow.hs +2/−1
- compiler/GHC/Tc/Gen/Expr.hs +1/−1
- compiler/GHC/Tc/Gen/Head.hs +1/−1
- compiler/GHC/Tc/Gen/Match.hs +58/−11
- compiler/GHC/Tc/Solver/Dict.hs +14/−10
- compiler/GHC/Tc/Solver/Monad.hs +85/−6
- compiler/GHC/Tc/TyCl.hs +2/−0
- compiler/GHC/Tc/Utils/Env.hs +9/−8
- ghc-lib.cabal +2/−2
- ghc-lib/stage0/lib/settings +3/−3
compiler/GHC/ByteCode/Asm.hs view
@@ -51,7 +51,6 @@ import Foreign hiding (shiftL, shiftR) import Data.Char ( ord )-import Data.List ( genericLength ) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map@@ -338,6 +337,7 @@ , lblEnv :: LabelEnvMap } + inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) inspectAsm platform long_jumps initial_offset = go (InspectState initial_offset 0 0 Map.empty)@@ -345,7 +345,7 @@ go s (NullAsm _) = (instrCount s, lblEnv s) go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) where n = ptrCount s- go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)+ go s (AllocLit ls k) = go (s { litCount = n + strictGenericLength ls }) (k n) where n = litCount s go s (AllocLabel lbl k) = go s' k where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -23,7 +23,7 @@ import GHC.CmmToAsm.Monad ( NatM, getNewRegNat , getPicBaseMaybeNat, getPlatform, getConfig- , getDebugBlock, getFileId+ , getDebugBlock, getFileId, getThisModuleNat ) -- import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC@@ -835,21 +835,25 @@ CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x- return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))+ `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`- (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+ (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do (reg_x, _format_x, code_x) <- getSomeReg x- return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))+ `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`- (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+ (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32 || w == W64@@ -1353,8 +1357,19 @@ -- Jumps genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock-genJump expr@(CmmLit (CmmLabel lbl))- = return $ unitOL (annExpr expr (J (TLabel lbl)))+genJump expr@(CmmLit (CmmLabel lbl)) = do+ cur_mod <- getThisModuleNat+ !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig+ let is_local = isLocalCLabel cur_mod lbl++ -- We prefer to generate a near jump using a simble `B` instruction+ -- with a range (+/-128MB). But if the target is outside the current module+ -- we might have to account for large code offsets. (#24648)+ if not useFarJumps || is_local+ then return $ unitOL (annExpr expr (J (TLabel lbl)))+ else do+ (target, _format, code) <- getSomeReg expr+ return (code `appOL` unitOL (annExpr expr (J (TReg target)))) genJump expr = do (target, _format, code) <- getSomeReg expr
compiler/GHC/CmmToAsm/Config.hs view
@@ -44,6 +44,7 @@ , ncgDwarfSourceNotes :: !Bool -- ^ Enable GHC-specific source note DIEs , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+ , ncgEnableInterModuleFarJumps:: !Bool -- ^ Use far-jumps for cross-module jumps. , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables , ncgEnableDeadCodeElimination :: !Bool -- ^ Whether to enable the dead-code elimination }
compiler/GHC/CmmToAsm/Wasm/Asm.hs view
@@ -361,6 +361,7 @@ WasmF32DemoteF64 -> asmTellLine "f32.demote_f64" WasmF64PromoteF32 -> asmTellLine "f64.promote_f32" WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"+ WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt" WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg" WasmCond t -> do asmTellLine "if"
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -1057,6 +1057,28 @@ x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" +-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.+lower_CMO_Un_Homo_Prim ::+ CLabel ->+ ( forall pre t.+ WasmTypeTag t ->+ WasmInstr+ w+ (t : pre)+ (t : pre)+ ) ->+ WasmTypeTag t ->+ [CmmFormal] ->+ [CmmActual] ->+ WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do+ (ri, _) <- onCmmLocalReg reg+ WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+ pure $+ WasmStatements $+ x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"+ -- | Lower a binary homogeneous 'CallishMachOp' to a ccall. lower_CMO_Bin_Homo :: CLabel ->@@ -1160,8 +1182,8 @@ lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs@@ -1184,8 +1206,8 @@ lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs lower_CallishMachOp lbl MO_F32_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1f" rs xs-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop
compiler/GHC/CmmToAsm/Wasm/Types.hs view
@@ -305,6 +305,7 @@ WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre) WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre) WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+ WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre
compiler/GHC/CmmToLlvm/Base.hs view
@@ -219,7 +219,7 @@ text ") both alive AND mapped to the same real register: " <> ppr real <> text ". This isn't currently supported by the LLVM backend." go (c:cs) f- | fpr_num c == f = go cs f -- already covered by a real register+ | fpr_num c == f = go cs (f+1) -- already covered by a real register | otherwise = ctor f : go (c:cs) (f + 1) -- add padding register fpr_ctor :: GlobalReg -> Int -> GlobalReg@@ -499,10 +499,10 @@ modifyEnv $ \env -> env { envAliases = emptyUniqSet } return (concat defss, []) --- | Is a variable one of the special @$llvm@ globals?+-- | Is a variable one of the special @\@llvm@ globals? isBuiltinLlvmVar :: LlvmVar -> Bool isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =- "$llvm" `isPrefixOf` unpackFS lbl+ "llvm." `isPrefixOf` unpackFS lbl isBuiltinLlvmVar _ = False -- | Here we take a global variable definition, rename it with a
compiler/GHC/CmmToLlvm/Data.hs view
@@ -124,7 +124,7 @@ prio = LMStaticLit $ LMIntLit 0xffff i32 in LMStaticStrucU [prio, fn, null] entry_ty - arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+ arr_var = LMGlobalVar var_nm arr_ty Appending Nothing Nothing Global mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8] arr_ty = LMArray (length clbls) entry_ty
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -20,7 +20,8 @@ module GHC.Core.Opt.SpecConstr( specConstrProgram,- SpecConstrAnnotation(..)+ SpecConstrAnnotation(..),+ SpecFailWarning(..) ) where import GHC.Prelude@@ -51,6 +52,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts +import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) )@@ -526,9 +528,11 @@ (see argToPat; #4448) (FS4) Only specialise on recursive types a finite number of times (see sc_recursive; #5550; Note [Limit recursive specialisation])-(FS5) Lift the restriction on the maximum number of arguments which- the optimisation will specialise.- (see `too_many_worker_args` in `callsToNewPats`; #14003)+(FS5) Use a different restriction on the maximum number of arguments which+ the optimisation will specialise. We tried removing the limit on worker+ args for forced specs (#14003) but this caused issues when specializing+ code for large data structures (#25197).+ This is handled by `too_many_worker_args` in `callsToNewPats` The flag holds only for specialising a single binding group, and NOT for nested bindings. (So really it should be passed around explicitly@@ -782,16 +786,25 @@ specConstrProgram guts = do { env0 <- initScEnv guts ; us <- getUniqueSupplyM- ; let (_usg, binds') = initUs_ us $+ ; let (_usg, binds', warnings) = initUs_ us $ scTopBinds env0 (mg_binds guts) + ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)+ ; return (guts { mg_binds = binds' }) } -scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])-scTopBinds _env [] = return (nullUsage, [])-scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $+ where+ specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing+ warn_msg :: SpecFailWarnings -> SDoc+ warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$+ text "which resulted in no specialization being generated for these functions:" $$+ nest 2 (vcat (map ppr warnings)) $$+ (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")+scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])+scTopBinds _env [] = return (nullUsage, [], [])+scTopBinds env (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $ (\env -> scTopBinds env bs)- ; return (usg, b' ++ bs') }+ ; return (usg, b' ++ bs', warnings) } {- ************************************************************************@@ -905,6 +918,12 @@ -- ^ The threshold at which a worker-wrapper transformation used as part of -- this pass will no longer happen, measured in the number of arguments. + , sc_max_forced_args :: !Int+ -- ^ The threshold at which a worker-wrapper transformation used as part of+ -- this pass will no longer happen even if a SPEC arg was used to force+ -- specialization. Measured in the number of arguments.+ -- See Note [Forcing specialisation]+ , sc_debug :: !Bool -- ^ Whether to print debug information @@ -973,6 +992,7 @@ initScOpts :: DynFlags -> Module -> SpecConstrOpts initScOpts dflags this_mod = SpecConstrOpts { sc_max_args = maxWorkerArgs dflags,+ sc_max_forced_args = maxForcedSpecArgs dflags, sc_debug = hasPprDebug dflags, sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod,@@ -1386,29 +1406,29 @@ -} scBind :: TopLevelFlag -> ScEnv -> InBind- -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding- -> UniqSM (ScUsage, [OutBind], a)+ -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])) -- Specialise the scope of the binding+ -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning]) scBind top_lvl env (NonRec bndr rhs) do_body | isTyVar bndr -- Type-lets may be created by doBeta- = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)- ; return (final_usage, [], body') }+ = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs)+ ; return (final_usage, [], body', warnings) } | not (isTopLevel top_lvl) -- Nested non-recursive value binding -- See Note [Specialising local let bindings] = do { let (body_env, bndr') = extendBndr env bndr -- Not necessary at top level; but here we are nested - ; rhs_info <- scRecRhs env (bndr',rhs)+ ; (rhs_info, rhs_ws) <- scRecRhs env (bndr',rhs) ; let body_env2 = extendHowBound body_env [bndr'] RecFun rhs' = ri_new_rhs rhs_info body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - ; (body_usg, body') <- do_body body_env3+ ; (body_usg, body', warnings_body) <- do_body body_env3 -- Now make specialised copies of the binding, -- based on calls in body_usg- ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info+ ; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info -- NB: For non-recursive bindings we inherit sc_force flag from -- the parent function (see Note [Forcing specialisation]) @@ -1417,7 +1437,7 @@ bind_usage = (body_usg `delCallsFor` [bndr']) `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg] - ; return (bind_usage, spec_bnds, body')+ ; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws]) } | otherwise -- Top-level, non-recursive value binding@@ -1429,15 +1449,15 @@ -- -- I tried always specialising non-recursive top-level bindings too, -- but found some regressions (see !8135). So I backed off.- = do { (rhs_usage, rhs') <- scExpr env rhs+ = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs -- At top level, we've already put all binders into scope; see initScEnv -- Hence no need to call `extendBndr`. But we still want to -- extend the `ValueEnv` to record the value of this binder. ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')- ; (body_usage, body') <- do_body body_env+ ; (body_usage, body', body_warnings) <- do_body body_env - ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }+ ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) } scBind top_lvl env (Rec prs) do_body | isTopLevel top_lvl@@ -1448,19 +1468,20 @@ -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor -- why it only applies at top level. But that's the way it has been -- for a while. See #21456.- do { (body_usg, body') <- do_body rhs_env2- ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss+ do { (body_usg, body', warnings_body) <- do_body rhs_env2+ ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg) `delCallsFor` bndrs' bind' = Rec (bndrs' `zip` rhss')- ; return (all_usg, [bind'], body') }+ ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) } | otherwise- = do { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)- ; (body_usg, body') <- do_body rhs_env2+ = do { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+ ; let rhs_ws = mconcat rhs_wss+ ; (body_usg, body', warnings_body) <- do_body rhs_env2 - ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)- (scu_calls body_usg) rhs_infos+ ; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec)+ (scu_calls body_usg) rhs_infos -- Do not unconditionally generate specialisations from rhs_usgs -- Instead use them only if we find an unspecialised call -- See Note [Seeding recursive groups]@@ -1471,7 +1492,7 @@ -- zipWithEqual: length of returned [SpecInfo] -- should be the same as incoming [RhsInfo] - ; return (all_usg, [bind'], body') }+ ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) } where (bndrs,rhss) = unzip prs force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation]@@ -1499,59 +1520,63 @@ harmful. I'm not sure. -} +withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings)+withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2)+ -------------------------scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) -- The unique supply is needed when we invent -- a new name for the specialised function and its args scExpr env e = scExpr' env e scExpr' env (Var v) = case scSubstId env v of- Var v' -> return (mkVarUsage env v' [], Var v')+ Var v' -> return (mkVarUsage env v' [], Var v', []) e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = let !(MkSolo ty') = scSubstTy env t- in return (nullUsage, Type ty')-scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))-scExpr' _ e@(Lit {}) = return (nullUsage, e)-scExpr' env (Tick t e) = do (usg, e') <- scExpr env e- return (usg, Tick (scTickish env t) e')-scExpr' env (Cast e co) = do (usg, e') <- scExpr env e- return (usg, mkCast e' (scSubstCo env co))+ in return (nullUsage, Type ty', [])+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c), [])+scExpr' _ e@(Lit {}) = return (nullUsage, e, [])+scExpr' env (Tick t e) = do (usg, e', ws) <- scExpr env e+ return (usg, Tick (scTickish env t) e', ws)+scExpr' env (Cast e co) = do (usg, e', ws) <- scExpr env e+ return (usg, mkCast e' (scSubstCo env co), ws) -- Important to use mkCast here -- See Note [SpecConstr call patterns] scExpr' env e@(App _ _) = scApp env (collectArgs e) scExpr' env (Lam b e) = do let (env', b') = extendBndr env b- (usg, e') <- scExpr env' e- return (usg, Lam b' e')+ (usg, e', ws) <- scExpr env' e+ return (usg, Lam b' e', ws) scExpr' env (Let bind body)- = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $+ = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $ (\env -> scExpr env body)- ; return (final_usage, mkLets binds' body') }+ ; return (final_usage, mkLets binds' body', ws) } scExpr' env (Case scrut b ty alts)- = do { (scrut_usg, scrut') <- scExpr env scrut+ = do { (scrut_usg, scrut', ws) <- scExpr env scrut ; case isValue (sc_vals env) scrut' of Just (ConVal args_are_work_free con args)- | args_are_work_free -> sc_con_app con args scrut'+ | args_are_work_free -> sc_con_app con args scrut' ws -- Don't duplicate work!! #7865 -- See Note [ConVal work-free-ness] (1)- _other -> sc_vanilla scrut_usg scrut'+ _other -> sc_vanilla scrut_usg scrut' ws } where- sc_con_app con args scrut' -- Known constructor; simplify+ sc_con_app con args scrut' ws -- Known constructor; simplify = do { let Alt _ bs rhs = findAlt con alts `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr") alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)- ; scExpr alt_env' rhs }+ ; (use',expr',ws_new) <- scExpr alt_env' rhs+ ; return (use',expr',ws ++ ws_new) } - sc_vanilla scrut_usg scrut' -- Normal case+ sc_vanilla scrut_usg scrut' ws -- Normal case = do { let (alt_env,b') = extendBndrWith RecArg env b -- Record RecArg for the components - ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts+ ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (sc_alt alt_env scrut' b') alts ; let scrut_occ = foldr combineOcc NoOcc alt_occs scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ@@ -1561,21 +1586,21 @@ ; let !(MkSolo ty') = scSubstTy env ty ; return (foldr combineUsage scrut_usg' alt_usgs,- Case scrut' b' ty' alts') }+ Case scrut' b' ty' alts', ws ++ concat ws_alts) } single_alt = isSingleton alts sc_alt env scrut' b' (Alt con bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1- ; (usg, rhs') <- scExpr env2 rhs+ ; (usg, rhs', ws) <- scExpr env2 rhs ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) scrut_occ = case con of DataAlt dc -- See Note [Do not specialise evals] | not (single_alt && all deadArgOcc arg_occs) -> ScrutOcc (unitUFM dc arg_occs) _ -> UnkOcc- ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }+ ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) } -- | Substitute the free variables captured by a breakpoint.@@ -1624,19 +1649,20 @@ still worth specialising on x. Hence the /single-alternative/ guard. -} -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)+scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) scApp env (Var fn, args) -- Function is a variable = assert (not (null args)) $ do { args_w_usgs <- mapM (scExpr env) args- ; let (arg_usgs, args') = unzip args_w_usgs+ ; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs arg_usg = combineUsages arg_usgs+ arg_w = concat arg_ws ; case scSubstId env fn of- fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')+ fn'@(Lam {}) -> withWarnings arg_w <$> scExpr (zapScSubst env) (doBeta fn' args') -- Do beta-reduction and try again Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args',- mkApps (Var fn') args')+ mkApps (Var fn') args', arg_w ) where -- arg_usg': see Note [Specialising on dictionaries] arg_usg' | Just cls <- isClassOpId_maybe fn'@@ -1645,7 +1671,7 @@ | otherwise = arg_usg - other_fn' -> return (arg_usg, mkApps other_fn' args') }+ other_fn' -> return (arg_usg, mkApps other_fn' args', arg_w) } -- NB: doing this ignores any usage info from the substituted -- function, but I don't think that matters. If it does -- we can fix it.@@ -1659,9 +1685,9 @@ -- which it may, we can get -- (let f = ...f... in f) arg1 arg2 scApp env (other_fn, args)- = do { (fn_usg, fn') <- scExpr env other_fn- ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args- ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }+ = do { (fn_usg, fn', fn_ws) <- scExpr env other_fn+ ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args+ ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) } ---------------------- mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage@@ -1677,16 +1703,16 @@ | otherwise = evalScrutOcc -----------------------scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings) scRecRhs env (bndr,rhs) = do { let (arg_bndrs,body) = collectBinders rhs (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs- ; (body_usg, body') <- scExpr body_env body+ ; (body_usg, body', body_ws) <- scExpr body_env body ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' ; return (RI { ri_rhs_usg = rhs_usg , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' , ri_lam_bndrs = arg_bndrs, ri_lam_body = body- , ri_arg_occs = arg_occs }) }+ , ri_arg_occs = arg_occs }, body_ws) } -- The arg_occs says how the visible, -- lambda-bound binders of the RHS are used -- (including the TyVar binders)@@ -1755,7 +1781,7 @@ specNonRec :: ScEnv -> CallEnv -- Calls in body -> RhsInfo -- Structure info usage info for un-specialised RHS- -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not)+ -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- Usage from RHSs (specialised and not) -- plus details of specialisations specNonRec env body_calls rhs_info@@ -1765,11 +1791,12 @@ specRec :: ScEnv -> CallEnv -- Calls in body -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs- -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not)+ -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+ -- Usage from all RHSs (specialised and not) -- plus details of specialisations specRec env body_calls rhs_infos- = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)+ = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) [] -- body_calls: see Note [Seeding recursive groups] -- NB: 'go' always calls 'specialise' once, which in turn unleashes -- si_mb_unspec if there are any boring calls in body_calls,@@ -1784,23 +1811,25 @@ -- Two accumulating parameters: -> ScUsage -- Usage from earlier specialisations -> [SpecInfo] -- Details of specialisations so far- -> UniqSM (ScUsage, [SpecInfo])- go n_iter seed_calls usg_so_far spec_infos+ -> SpecFailWarnings -- Warnings so far+ -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+ go n_iter seed_calls usg_so_far spec_infos ws_so_far = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) -- , text "iteration" <+> int n_iter -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) -- ]) $ do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos- ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg++ ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg extra_usg = combineUsages extra_usg_s all_usg = usg_so_far `combineUsage` extra_usg new_calls = scu_calls extra_usg- ; go_again n_iter new_calls all_usg all_spec_infos }+ ; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) } -- go_again deals with termination- go_again n_iter seed_calls usg_so_far spec_infos+ go_again n_iter seed_calls usg_so_far spec_infos ws_so_far | isEmptyVarEnv seed_calls- = return (usg_so_far, spec_infos)+ = return (usg_so_far, spec_infos, ws_so_far) -- Limit recursive specialisation -- See Note [Limit recursive specialisation]@@ -1814,10 +1843,10 @@ -- for the unspecialised function, since it may now be called -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)- in return (usg_so_far `combineUsage` rhs_usgs, spec_infos)+ in return (usg_so_far `combineUsage` rhs_usgs, spec_infos, ws_so_far) | otherwise- = go (n_iter + 1) seed_calls usg_so_far spec_infos+ = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far -- See Note [Limit recursive specialisation] the_limit = case sc_count opts of@@ -1830,7 +1859,7 @@ -> CallEnv -- Info on newly-discovered calls to this function -> RhsInfo -> SpecInfo -- Original RHS plus patterns dealt with- -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage+ -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- New specialised versions and their usage -- See Note [spec_usg includes rhs_usg] @@ -1848,7 +1877,7 @@ | isDeadEndId fn -- Note [Do not specialise diverging functions] -- /and/ do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $- return (nullUsage, spec_info)+ return (nullUsage, spec_info, []) | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]@@ -1859,7 +1888,7 @@ , not (null arg_bndrs) -- Only specialise functions , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $- do { (boring_call, pats_discarded, new_pats)+ do { (boring_call, pats_discarded, new_pats, warnings) <- callsToNewPats env fn spec_info arg_occs all_calls ; let n_pats = length new_pats@@ -1874,7 +1903,7 @@ -- , text "new_pats" <+> ppr new_pats]) ; let spec_env = decreaseSpecCount env n_pats- ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)+ ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body) (new_pats `zip` [spec_count..]) -- See Note [Specialise original body] @@ -1898,15 +1927,16 @@ ; return (new_usg, SI { si_specs = new_specs ++ specs , si_n_specs = spec_count + n_pats- , si_mb_unspec = mb_unspec' }) }+ , si_mb_unspec = mb_unspec' }+ ,warnings ++ concat new_wss) } | otherwise -- No calls, inactive, or not a function -- Behave as if there was a single, boring call = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $ case mb_unspec of -- Behave as if there was a single, boring call- Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+ Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }, []) -- See Note [spec_usg includes rhs_usg]- Nothing -> return (nullUsage, spec_info)+ Nothing -> return (nullUsage, spec_info, []) ---------------------@@ -1915,7 +1945,7 @@ -> [InVar] -- Lambda-binders of RHS; should match patterns -> InExpr -- Body of the original function -> (CallPat, Int)- -> UniqSM (ScUsage, OneSpec) -- Rule and binding+ -> UniqSM (ScUsage, OneSpec, SpecFailWarnings) -- Rule and binding, warnings if any -- spec_one creates a specialised copy of the function, together -- with a rule for using it. I'm very proud of how short this@@ -1967,7 +1997,7 @@ -- Specialise the body -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)- ; (spec_usg, spec_body) <- scExpr body_env body+ ; (spec_usg, spec_body, body_warnings) <- scExpr body_env body -- And build the results ; (qvars', pats') <- generaliseDictPats qvars pats@@ -2016,7 +2046,7 @@ -- ] ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id- , os_rhs = spec_rhs }) }+ , os_rhs = spec_rhs }, body_warnings) } generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats@@ -2400,12 +2430,26 @@ , text "cp_args =" <+> ppr args , text "cp_strict_args = " <> ppr strict ]) +newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name }++type SpecFailWarnings = [SpecFailWarning]++instance Outputable SpecFailWarning where+ ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name++combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings+combineSpecWarning = (++)++data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name+ callsToNewPats :: ScEnv -> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM ( Bool -- At least one boring call , Bool -- Patterns were discarded- , [CallPat] ) -- Patterns to specialise+ , [CallPat] -- Patterns to specialise+ , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about)+ ) -- Result has no duplicate patterns, -- nor ones mentioned in si_specs (hence "new" patterns) -- Bool indicates that there was at least one boring pattern@@ -2431,12 +2475,18 @@ non_dups = subsumePats in_scope new_pats -- Remove ones that have too many worker variables- small_pats = filterOut too_many_worker_args non_dups+ (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups - too_many_worker_args _- | sc_force env = False -- See (FS5) of Note [Forcing specialisation]+ -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool too_many_worker_args (CP { cp_qvars = vars, cp_args = args })- = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+ | sc_force env+ -- See (FS5) of Note [Forcing specialisation]+ = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars)+ then WorkerSmallEnough+ else WorkerTooLargeForced (idName fn)+ | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+ = WorkerSmallEnough+ | otherwise = WorkerTooLarge -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils@@ -2452,10 +2502,21 @@ -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "trimmed_pats:" <+> ppr trimmed_pats ]) - ; return (have_boring_call, pats_were_discarded, trimmed_pats) }+ ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) } -- If any of the calls does not give rise to a specialisation, either -- because it is boring, or because there are too many specialisations, -- return a flag to say so, so that we know to keep the original function.+ where+ partitionByWorkerSize worker_size pats = go pats [] []+ where+ go [] small warnings = (small, warnings)+ go (p:ps) small warnings+ | WorkerSmallEnough <- worker_size p+ = go ps (p:small) warnings+ | WorkerTooLarge <- worker_size p+ = go ps small warnings+ | WorkerTooLargeForced name <- worker_size p+ = go ps small (SpecFailForcedArgCount name : warnings) trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
compiler/GHC/Driver/Config/CmmToAsm.hs view
@@ -68,6 +68,7 @@ , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags+ , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps dflags , ncgComputeUnwinding = debugLevel dflags > 0 , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) -- Disable when -finfo-table-map is on (#20428)
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -400,7 +400,7 @@ let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env- let home_unit = hsc_home_unit hsc_env+ let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc@@ -492,10 +492,12 @@ -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not.- ++ (if platformOS platform == OSMinGW32 &&- isHomeUnitId home_unit baseUnitId- then [ "-DCOMPILING_BASE_PACKAGE" ]- else [])+ ++ (case home_unit of+ Just hu+ | isHomeUnitId hu baseUnitId+ , platformOS platform == OSMinGW32+ -> ["-DCOMPILING_BASE_PACKAGE"]+ _ -> []) -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
compiler/GHC/HsToCore/Binds.hs view
@@ -1533,14 +1533,14 @@ | Just (t1,t2) <- splitAppTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2- ; mkTrApp <- dsLookupGlobalId mkTrAppName- -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).- -- TypeRep a -> TypeRep b -> TypeRep (a b)+ ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName+ -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+ -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, -- since it's a kind- ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])+ ; let expr = mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ]) [ e1, e2 ]- -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr+ -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr ; return expr }
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -78,7 +78,8 @@ dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))- = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty+ = updPmNablas rhs_nablas $+ matchGuards (map unLoc guards) hs_ctx rhs rhs_ty {- ************************************************************************@@ -90,7 +91,6 @@ matchGuards :: [GuardStmt GhcTc] -- Guard -> HsMatchContextRn -- Context- -> Nablas -- The RHS's covered set for PmCheck -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM (MatchResult CoreExpr)@@ -98,8 +98,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ nablas rhs _- = do { core_rhs <- updPmNablas nablas (dsLExpr rhs)+matchGuards [] _ rhs _+ = do { core_rhs <- dsLExpr rhs ; return (cantFailMatchResult core_rhs) } -- BodyStmts must be guards@@ -109,42 +109,50 @@ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty+ match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do+ match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do- match_result <- matchGuards stmts ctx nablas rhs rhs_ty- return (adjustMatchResultDs (dsLocalBinds binds) match_result)+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do+ ldi_nablas <- getPmNablas+ match_result <- matchGuards stmts ctx rhs rhs_ty+ -- Propagate long-distance information when desugaring let bindings, e.g.+ --+ -- f r@(K1 {})+ -- | let g = fld r+ -- = g+ --+ -- Failing to do so resulted in #25749.+ return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar ManyTy upat -- We only allow unrestricted patterns in guards, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. - match_result <- matchGuards stmts ctx nablas rhs rhs_ty+ match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx) pat rhs_ty match_result return $ bindNonRec match_var core_rhs <$> match_result' -matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ _ =+matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"+matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" {-
compiler/GHC/Rename/Bind.hs view
@@ -1303,14 +1303,38 @@ -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) -- see Note [Empty MatchGroups]- = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt))+ = do { when (null ms) $ checkEmptyCase ctxt ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }++-- Check the validity of a MatchGroup with an empty list of alternatives.+--+-- 1. Normal `case x of {}` passes this check as long as EmptyCase is enabled.+-- Ditto lambda-case `\case {}`.+--+-- 2. Multi-case with no alternatives `\cases {}` is never valid.+--+-- 3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not+-- considered here because there is no syntax to construct them with+-- no alternatives.+--+-- Test case: rename/should_fail/RnEmptyCaseFail+--+-- Validation continues in the type checker, namely in tcMatches.+-- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match+checkEmptyCase :: HsMatchContextRn -> RnM ()+checkEmptyCase ctxt+ | disallowed_ctxt =+ addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt)+ | otherwise =+ unlessXOptM LangExt.EmptyCase $+ addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag) where- mustn't_be_empty = case ctxt of- LamAlt LamCases -> return True- ArrowMatchCtxt (ArrowLamAlt LamCases) -> return True- _ -> not <$> xoptM LangExt.EmptyCase+ disallowed_ctxt =+ case ctxt of+ LamAlt LamCases -> True+ ArrowMatchCtxt (ArrowLamAlt LamCases) -> True+ _ -> False rnMatch :: AnnoBody body => HsMatchContextRn
compiler/GHC/Rename/Env.hs view
@@ -436,6 +436,7 @@ ; case info of IAmConLike con_info -> return con_info UnboundGRE -> return ConHasPositionalArgs+ IAmTyCon {} -> failIllegalTyCon WL_Constructor con_name _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ vcat [ text "name:" <+> ppr con_name ] }@@ -1029,24 +1030,12 @@ lookupOccRn :: RdrName -> RnM Name lookupOccRn = lookupOccRn' WL_Anything --- lookupOccRnConstr looks up an occurrence of a RdrName and displays--- constructors and pattern synonyms as suggestions if it is not in scope------ There is a fallback to the type level, when the first lookup fails.--- This is required to implement a pat-to-type transformation--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)--- Consider this example:------ data VisProxy a where VP :: forall a -> VisProxy a------ f :: VisProxy Int -> ()--- f (VP Int) = ()+-- | Look up an occurrence of a 'RdrName'. ----- Here `Int` is actually a type, but it stays on position where--- we expect a data constructor.+-- Displays constructors and pattern synonyms as suggestions if+-- it is not in scope. ----- In all other cases we just use this additional lookup for better--- error messaging (See Note [Promotion]).+-- See Note [lookupOccRnConstr] lookupOccRnConstr :: RdrName -> RnM Name lookupOccRnConstr rdr_name = do { mb_gre <- lookupOccRn_maybe rdr_name@@ -1057,6 +1046,28 @@ ; case mb_ty_gre of Just gre -> return $ greName gre Nothing -> reportUnboundName' WL_Constructor rdr_name} }++{- Note [lookupOccRnConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.++However, there is a fallback to the type level when the lookup fails.+This is required to implement a pat-to-type transformation+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)++Consider this example:++ data VisProxy a where VP :: forall a -> VisProxy a++ f :: VisProxy Int -> ()+ f (VP Int) = ()++Here `Int` is actually a type, but it occurs in a position in which we expect+a data constructor.++In all other cases we just use this additional lookup for better+error messaging (See Note [Promotion]).+-} -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- record fields as suggestions if it is not in scope
compiler/GHC/Rename/Expr.hs view
@@ -532,9 +532,9 @@ = do { (expr', fvs) <- rnLExpr expr ; return (ExplicitSum noExtField alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con = con_id+rnExpr (RecordCon { rcon_con = con_rdr , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })- = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id+ = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
compiler/GHC/Rename/Names.hs view
@@ -92,6 +92,7 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps ( removeDups ) +import Control.Arrow ( second ) import Control.Monad import Data.Foldable ( for_ ) import Data.IntMap ( IntMap )@@ -99,6 +100,8 @@ import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing )+import Data.Semigroup ( Any(..) )+import qualified Data.Semigroup as S import Data.List ( partition, find, sortBy ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -1873,21 +1876,21 @@ -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map greName used_gres)+ used_gre_env = mkGlobalRdrEnv used_gres used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) unused_imps -- Not trivial; see eg #7454 = case imps of Just (Exactly, L _ imp_ies) ->- foldr (add_unused . unLoc) emptyNameSet imp_ies+ let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies+ in collectUnusedNames unused _other -> emptyNameSet -- No explicit import list => no unused-name list - add_unused :: IE GhcRn -> NameSet -> NameSet- add_unused (IEVar _ n _) acc = add_unused_name (lieWrappedName n) acc- add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) acc+ add_unused :: IE GhcRn -> UnusedNames -> UnusedNames+ add_unused (IEVar _ n _) acc = add_unused_name (lieWrappedName n) True acc+ add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) False acc add_unused (IEThingAll _ n _) acc = add_unused_all (lieWrappedName n) acc- add_unused (IEThingWith _ p wc ns _) acc =- add_wc_all (add_unused_with pn xs acc)+ add_unused (IEThingWith _ p wc ns _) acc = add_wc_all (add_unused_with pn xs acc) where pn = lieWrappedName p xs = map lieWrappedName ns add_wc_all = case wc of@@ -1895,23 +1898,117 @@ IEWildcard _ -> add_unused_all pn add_unused _ acc = acc - add_unused_name n acc- | n `elemNameSet` used_names = acc- | otherwise = acc `extendNameSet` n- add_unused_all n acc- | n `elemNameSet` used_names = acc- | n `elemNameSet` used_parents = acc- | otherwise = acc `extendNameSet` n+ add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames+ add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs)+ | is_ie_var+ , isFieldName n+ -- See Note [Reporting unused imported duplicate record fields]+ = let+ fs = getOccFS n+ (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False)+ acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used)+ in UnusedNames acc_ns acc_fs'+ | used+ = acc+ | otherwise+ = UnusedNames (acc_ns `extendNameSet` n) acc_fs+ where+ used = isJust $ lookupGRE_Name used_gre_env n++ add_unused_all :: Name -> UnusedNames -> UnusedNames+ add_unused_all n (UnusedNames acc_ns acc_fs)+ | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs+ | n `elemNameSet` used_parents = UnusedNames acc_ns acc_fs+ | otherwise = UnusedNames (acc_ns `extendNameSet` n) acc_fs++ add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames add_unused_with p ns acc- | all (`elemNameSet` acc1) ns = add_unused_name p acc1- | otherwise = acc1+ | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1+ | otherwise = acc1 where- acc1 = foldr add_unused_name acc ns- -- If you use 'signum' from Num, then the user may well have- -- imported Num(signum). We don't want to complain that- -- Num is not itself mentioned. Hence the two cases in add_unused_with.+ acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns+ -- If you use 'signum' from Num, then the user may well have+ -- imported Num(signum). We don't want to complain that+ -- Num is not itself mentioned. Hence the two cases in add_unused_with. +-- | An accumulator for unused names in an import list.+--+-- See Note [Reporting unused imported duplicate record fields].+data UnusedNames =+ UnusedNames+ { unused_names :: NameSet+ -- ^ Unused 'Name's in an import list, not including record fields+ -- that are plain 'IEVar' imports+ , rec_fld_uses :: FastStringEnv (NameSet, Any)+ -- ^ Record fields imported without a parent (i.e. an 'IEVar' import).+ --+ -- The 'Any' value records whether any of the record fields+ -- sharing the same underlying 'FastString' have been used.+ }+instance Outputable UnusedNames where+ ppr (UnusedNames nms flds) =+ text "UnusedNames" <+>+ braces (ppr nms <+> ppr (fmap (second getAny) flds))++-- | Collect all unused names from a 'UnusedNames' value.+collectUnusedNames :: UnusedNames -> NameSet+collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds })+ = nms S.<> unused_flds+ where+ unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds+ collect_unused :: (NameSet, Any) -> NameSet -> NameSet+ collect_unused (nms, Any at_least_one_name_is_used) acc+ | at_least_one_name_is_used = acc+ | otherwise = unionNameSet nms acc++{- Note [Reporting unused imported duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#24035):++ {-# LANGUAGE DuplicateRecordFields #-}+ module M1 (R1(..), R2(..)) where+ data R1 = MkR1 { fld :: Int }+ data R2 = MkR2 { fld :: Int }++ {-# LANGUAGE DuplicateRecordFields #-}+ module M2 where+ import M1 (R1(MkR1), R2, fld)+ f :: R1 -> Int+ f (MkR1 { fld = x }) = x+ g :: R2 -> Int+ g _ = 3++In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs,+namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular+the 'findImportUsage' function, it's as if the user had imported the two names+separately (even though no source syntax allows that).++This means that we need to be careful when reporting unused imports: the R2(fld)+import is indeed unused, but because R1(fld) is used, we should not report+fld as unused altogether.++To achieve this, we keep track of record field imports without a parent (i.e.+using the IEVar constructor) separately from other import items, using the+UnusedNames datatype.+Once we have accumulated usages, we emit warnings for unused record fields+without parents one whole group (of record fields sharing the same textual name)+at a time, and only if *all* of the record fields in the group are unused;+see 'collectUnusedNames'.++Note that this only applies to record fields imported without a parent. If we+had:++ import M1 (R1(MkR1, fld), R2(fld))+ f :: R1 -> Int+ f (MkR1 { fld = x }) = x+ g :: R2 -> Int+ g _ = 3++then of course we should report the second 'fld' as unused.+-}++ {- Note [The ImportMap] ~~~~~~~~~~~~~~~~~~~~~~~ The ImportMap is a short-lived intermediate data structure records, for@@ -1976,12 +2073,15 @@ | null unused = return () - -- Only one import is unused, with `SrcSpan` covering only the unused item instead of- -- the whole import statement+ -- Some imports are unused: make the `SrcSpan` cover only the unused+ -- items instead of the whole import statement | Just (_, L _ imports) <- ideclImportList decl- , length unused == 1- , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports- = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused))+ , let unused_locs = [ locA loc | L loc ie <- imports+ , name <- ieNames ie+ , name `elem` unused ]+ , loc1 : locs <- unused_locs+ , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs )+ = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused)) -- Some imports are unused | otherwise@@ -2294,3 +2394,4 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name)+
compiler/GHC/Settings/IO.hs view
@@ -20,13 +20,14 @@ import GHC.Settings import GHC.SysTools.BaseDir -import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class+import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory + data SettingsError = SettingsError_MissingData String | SettingsError_BadData String@@ -70,44 +71,51 @@ mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir -- see Note [tooldir: How GHC finds mingw on Windows] + -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally+ -- introduce unescaped spaces. See #24265 and #25204.+ let escaped_top_dir = escapeArg top_dir+ escaped_mtool_dir = fmap escapeArg mtool_dir++ getSetting_raw key = either pgmError pure $+ getRawSetting settingsFile mySettings key+ getSetting_topDir top key = either pgmError pure $+ getRawFilePathSetting top settingsFile mySettings key+ getSetting_toolDir top tool key =+ expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key++ getSetting :: String -> ExceptT SettingsError m String+ getSetting key = getSetting_topDir top_dir key+ getToolSetting :: String -> ExceptT SettingsError m String+ getToolSetting key = getSetting_toolDir top_dir mtool_dir key+ getFlagsSetting :: String -> ExceptT SettingsError m [String]+ getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key+ -- Make sure to unescape, as we have escaped top_dir and tool_dir.+ -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light.- let getSetting key = either pgmError pure $- -- Escape the 'top_dir', to make sure we don't accidentally introduce an- -- unescaped space- getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key- getToolSetting :: String -> ExceptT SettingsError m String- -- Escape the 'mtool_dir', to make sure we don't accidentally introduce- -- an unescaped space- getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key- targetPlatformString <- getSetting "target platform string"+ targetPlatformString <- getSetting_raw "target platform string" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command"- cc_args_str <- getToolSetting "C compiler flags"- cxx_args_str <- getToolSetting "C++ compiler flags"+ cc_args0 <- getFlagsSetting "C compiler flags"+ cxx_args <- getFlagsSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" cpp_prog <- getToolSetting "CPP command"- cpp_args_str <- getToolSetting "CPP flags"+ cpp_args <- map Option <$> getFlagsSetting "CPP flags" hs_cpp_prog <- getToolSetting "Haskell CPP command"- hs_cpp_args_str <- getToolSetting "Haskell CPP flags"+ hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" js_cpp_prog <- getToolSetting "JavaScript CPP command"- js_cpp_args_str <- getToolSetting "JavaScript CPP flags"+ js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" cmmCpp_prog <- getToolSetting "C-- CPP command"- cmmCpp_args_str <- getToolSetting "C-- CPP flags"+ cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else []- cpp_args = map Option (unescapeArgs cpp_args_str)- hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)- js_cpp_args = map Option (unescapeArgs js_cpp_args_str)- cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str)- cc_args = unescapeArgs cc_args_str ++ unreg_cc_args- cxx_args = unescapeArgs cxx_args_str+ cc_args = cc_args0 ++ unreg_cc_args -- The extra flags we need to pass gcc when we invoke it to compile .hc code. --@@ -143,19 +151,19 @@ -- Config.hs one day. - -- Other things being equal, as and ld are simply gcc- cc_link_args_str <- getToolSetting "C compiler link flags"+ -- Other things being equal, 'as' and 'ld' are simply 'gcc'+ cc_link_args <- getFlagsSetting "C compiler link flags" let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog- ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str)+ ld_args = map Option (cc_args ++ cc_link_args) ld_r_prog <- getToolSetting "Merge objects command"- ld_r_args <- getToolSetting "Merge objects flags"+ ld_r_args <- getFlagsSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing- | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)+ | otherwise = Just (ld_r_prog, map Option ld_r_args) - llvmTarget <- getSetting "LLVM target"+ llvmTarget <- getSetting_raw "LLVM target" -- We just assume on command line lc_prog <- getSetting "LLVM llc command"
compiler/GHC/StgToByteCode.hs view
@@ -68,7 +68,7 @@ import GHC.Types.Name.Env (mkNameEnv) import GHC.Types.Tickish -import Data.List ( genericReplicate, genericLength, intersperse+import Data.List ( genericReplicate, intersperse , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad@@ -373,7 +373,7 @@ -- make the arg bitmap bits = argBits platform (reverse (map (idArgRep platform) all_args))- bitmap_size = genericLength bits+ bitmap_size = strictGenericLength bits bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -591,7 +591,7 @@ platform <- targetPlatform <$> getDynFlags let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs]) StgRec xs_n_rhss -> unzip xs_n_rhss- n_binds = genericLength xs+ n_binds = strictGenericLength xs fvss = map (fvsToEnv p') rhss @@ -600,7 +600,7 @@ sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss -- the arity of each rhs- arities = map (genericLength . fst . collect) rhss+ arities = map (strictGenericLength . fst . collect) rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1 word. d' and p' reflect the stack@@ -1700,10 +1700,14 @@ _ -> pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])+maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t)+ | [v] <- args = Just (v, extract_constr_Names t)+ | otherwise+ = pprPanic "StgToByteCode: tagToEnum#"+ $ text "Expected exactly one arg, but actual args are:" <+> ppr args where extract_constr_Names ty | rep_ty <- unwrapType ty@@ -1750,14 +1754,14 @@ :: StackDepth -> Sequel -> BCEnv- -> Id+ -> StgArg -> [Name] -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names = assert (notNull names) $- do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)- labels <- getLabelsBc (genericLength names)+ do (push_arg, arg_bytes) <- pushAtom d p arg+ labels <- getLabelsBc (strictGenericLength names) label_fail <- getLabelBc label_exit <- getLabelBc dflags <- getDynFlags
compiler/GHC/SysTools/Ar.hs view
@@ -168,7 +168,7 @@ putPaddedInt 6 own putPaddedInt 6 grp putPaddedInt 8 mode- putPaddedInt 10 (st_size + pad)+ putPaddedInt 10 st_size putByteString "\x60\x0a" putByteString file when (pad == 1) $
compiler/GHC/SysTools/Process.hs view
@@ -232,7 +232,9 @@ then does_not_exist else throwGhcExceptionIO (ProgramError $ show err) - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))+ does_not_exist =+ throwGhcExceptionIO $+ InstallationError (phase_name ++ ": could not execute: " ++ pgm) builderMainLoop :: Logger -> (String -> String) -> FilePath
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -319,8 +319,9 @@ -> CmdType -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)- = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)+ = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where+ ctxt = ArrowMatchCtxt ArrowCaseAlt tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') }
compiler/GHC/Tc/Gen/Expr.hs view
@@ -457,7 +457,7 @@ ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty- ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty+ ; (mult_co_wrap, matches') <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') } tcExpr (HsIf x pred b1 b2) res_ty
compiler/GHC/Tc/Gen/Head.hs view
@@ -1161,7 +1161,7 @@ AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps- (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc) ATyVar name _ -> failIllegalTyVal name _ -> failWithTc $ TcRnExpectedValueId thing }
compiler/GHC/Tc/Gen/Match.hs view
@@ -122,11 +122,12 @@ do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys , ppr pat_tys $$ ppr rhs_ty ])- ; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }+ ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches } ; return (wrap_fun <.> wrap_mult, r) } where- herald = ExpectedFunTyMatches (NameThing fun_name) matches+ herald = ExpectedFunTyMatches (NameThing fun_name) matches+ mctxt = mkPrefixFunRhs (noLocA fun_name) funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts })@@ -146,10 +147,11 @@ ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->- tcMatches tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches+ tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches ; return (wrapper <.> mult_co_wrap, r) } where+ ctxt = LamAlt lam_variant herald = ExpectedFunTyLam lam_variant e -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify @@ -167,7 +169,8 @@ -} tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))- => TcMatchAltChecker body -- ^ Typecheck the alternative RHSS+ => HsMatchContextRn+ -> TcMatchAltChecker body -- ^ Typecheck the alternative RHSS -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives -> ExpRhoType -- ^ Type of the whole case expression@@ -175,8 +178,8 @@ -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty -tcCaseMatches tc_body (Scaled scrut_mult scrut_ty) matches res_ty- = tcMatches tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches+tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty+ = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType@@ -223,23 +226,30 @@ -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body, Outputable (body GhcTc))- => TcMatchAltChecker body+ => HsMatchContextRn+ -> TcMatchAltChecker body -> [ExpPatType] -- ^ Expected pattern types. -> ExpRhoType -- ^ Expected result-type of the Match. -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches- , mg_ext = origin })+tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches+ , mg_ext = origin }) | null matches -- Deal with case e of {} -- Since there are no branches, no one else will fill in rhs_ty -- when in inference mode, so we must do it ourselves, -- here, using expTypeToType = do { tcEmitBindingUsage bottomUE- ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)+ -- See Note [Pattern types for EmptyCase]+ ; let vis_pat_tys = filter isVisibleExpPatType pat_tys+ ; pat_ty <- case vis_pat_tys of+ [ExpFunPatTy t] -> scaledExpTypeToType t+ [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)+ [] -> panic "tcMatches: no arguments in EmptyCase"+ _t1:(_t2:_ts) -> panic "tcMatches: multiple arguments in EmptyCase" ; rhs_ty <- expTypeToType rhs_ty ; return (idHsWrapper, MG { mg_alts = L l []- , mg_ext = MatchGroupTc pat_tys rhs_ty origin+ , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin }) } | otherwise@@ -261,6 +271,43 @@ where match_fun_pat_ty (ExpFunPatTy t) = Just t match_fun_pat_ty ExpForAllPatTy{} = Nothing++{- Note [Pattern types for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tcMatches, we might encounter an empty list of matches if the user wrote+`case x of {}` or `\case {}`.++* First of all, both `case x of {}` and `\case {}` match on exactly one visible+ argument, which follows from++ checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity+ checkArgCounts (MG { mg_alts = L _ [] })+ = return 1+ ...++ So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise.++ Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it+ must have been rejected earlier in `rnMatchGroup`.++ Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`,+ etc) are not considered here because there is no syntax to construct them with+ an empty list of alternatives.++* With lambda-case, we run the risk of trying to match on a type argument:++ f :: forall (xs :: Type) -> ()+ f = \case {}++ This is not valid and it used to trigger a panic in pmcMatches (#25004).+ We reject it by inspecting the expected pattern type:++ ; pat_ty <- case vis_pat_tys of+ [ExpFunPatTy t] -> ... -- value argument, ok+ [ExpForAllPatTy tvb] -> ... -- type argument, error!++ Test case: typecheck/should_fail/T25004+-} ------------- tcMatch :: (AnnoBody body)
compiler/GHC/Tc/Solver/Dict.hs view
@@ -32,7 +32,7 @@ import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Multiplicity ( scaledThing )-import GHC.Core.Unify ( ruleMatchTyKiX )+import GHC.Core.Unify ( ruleMatchTyKiX , typesAreApart ) import GHC.Types.Name import GHC.Types.Name.Set@@ -105,21 +105,25 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] -- Update /both/ inert_cans /and/ inert_solved_dicts. updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->- inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics- , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }- | otherwise+ inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics+ , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }+ | otherwise -> return () -- Add the new constraint to the inert set ; updInertCans (updDicts (addDict dict_ct)) } where- not_ip_for :: Type -> DictCt -> Bool- not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })- = not (mentionsIP str_ty cls tys)+ -- Does this class constraint or any of its superclasses mention+ -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?+ does_not_mention_ip_for :: Type -> DictCt -> Bool+ does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })+ = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys+ -- See Note [Using typesAreApart when calling mentionsIP]+ -- in GHC.Core.Predicate canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints:@@ -201,7 +205,7 @@ * In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. -* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any+* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any existing [G] (?x :: ty'), regardless of ty'. * Wrinkle (SIP1): we must be careful of superclasses. Consider@@ -221,7 +225,7 @@ An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). But it could happen for `class xx => D xx where ...` and the constraint D (?x :: int). This corner (constraint-kinded variables instantiated with- implicit parameter constraints) is not well explorered.+ implicit parameter constraints) is not well explored. Example in #14218, and #23761
compiler/GHC/Tc/Solver/Monad.hs view
@@ -158,7 +158,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Unify -import GHC.Builtin.Names ( unsatisfiableClassNameKey )+import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep@@ -168,6 +168,7 @@ import GHC.Core.Reduction import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.Unify (typesAreApart) import GHC.Types.Name import GHC.Types.TyThing@@ -177,13 +178,13 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.Set( elementOfUniqSet ) -import GHC.Unit.Module ( HasModule, getModule, extractModule )+import GHC.Unit.Module ( HasModule, getModule, extractModule, primUnit, moduleUnit, ghcInternalUnit, bignumUnit) import qualified GHC.Rename.Env as TcM import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Misc (HasDebugCallStack, (<||>)) import GHC.Data.Bag as Bag import GHC.Data.Pair@@ -478,14 +479,92 @@ updSolvedDicts :: InstanceWhat -> DictCt -> TcS () -- Conditionally add a new item in the solved set of the monad -- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet-updSolvedDicts what dict_ct@(DictCt { di_ev = ev })+updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) | isWanted ev , instanceReturnsDictCon what- = do { traceTcS "updSolvedDicts:" $ ppr dict_ct+ = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName+ ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName+ ; let contains_callstack_or_exceptionCtx =+ mentionsIP+ (const True)+ -- NB: the name of the call-stack IP is irrelevant+ -- e.g (?foo :: CallStack) counts!+ (is_callstack <||> is_exceptionCtx)+ cls tys+ -- See Note [Don't add HasCallStack constraints to the solved set]+ ; unless contains_callstack_or_exceptionCtx $+ do { traceTcS "updSolvedDicts:" $ ppr dict_ct ; updInertSet $ \ ics ->- ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } }+ ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) }+ } } | otherwise = return ()+ where++ -- Return a predicate that decides whether a type is CallStack+ -- or ExceptionContext, accounting for e.g. type family reduction, as+ -- per Note [Using typesAreApart when calling mentionsIP].+ --+ -- See Note [Using isCallStackTy in mentionsIP].+ is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)+ is_tyConTy is_eq tc_name+ = do { mb_tc <- wrapTcS $ do+ mod <- tcg_mod <$> TcM.getGblEnv+ if moduleUnit mod `elem` [primUnit, ghcInternalUnit, bignumUnit]+ then return Nothing+ else Just <$> TcM.tcLookupTyCon tc_name+ ; case mb_tc of+ Just tc ->+ return $ \ ty -> not (typesAreApart ty (mkTyConTy tc))+ Nothing ->+ return is_eq+ }++{- Note [Don't add HasCallStack constraints to the solved set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not add solved Wanted dictionaries that mention HasCallStack constraints+to the solved set, or we might fail to accumulate the proper call stack, as was+reported in #25529.++Recall that HasCallStack constraints (and the related HasExceptionContext+constraints) are implicit parameter constraints, and are accumulated as per+Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence.++When we solve a Wanted that contains a HasCallStack constraint, we don't want+to cache the result, because re-using that solution means re-using the call-stack+in a different context!++See also Note [Shadowing of implicit parameters], which deals with a similar+problem with Given implicit parameter constraints.++Note [Using isCallStackTy in mentionsIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To implement Note [Don't add HasCallStack constraints to the solved set],+we need to check whether a constraint contains a HasCallStack or HasExceptionContext+constraint. We do this using the 'mentionsIP' function, but as per+Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:++ mentionsIP+ (const True) -- (ignore the implicit parameter string)+ (isCallStackTy <||> isExceptionContextTy)++because this does not account for e.g. a type family that reduces to CallStack.+The predicate we want to use instead is:++ \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy)++However, this is made difficult by the fact that CallStack and ExceptionContext+are not wired-in types; they are only known-key. This means we must look them+up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle+of typechecking ghc-internal and these data-types have not been typechecked yet!++In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy'+logic.++Note that it would be somewhat painful to wire-in ExceptionContext: at the time+of writing (March 2025), this would require wiring in the ExceptionAnnotation+class, as well as SomeExceptionAnnotation, which is a data type with existentials.+-} getSolvedDicts :: TcS (DictMap DictCt) getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) }
compiler/GHC/Tc/TyCl.hs view
@@ -4752,6 +4752,8 @@ ; traceTc "Done validity of data con" $ vcat [ ppr con , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)+ , text "Datacon src bangs:" <+> ppr (dataConSrcBangs con)+ , text "Datacon impl bangs:" <+> ppr (dataConImplBangs con) , text "Datacon rep type:" <+> ppr (dataConRepType con) , text "Datacon display type:" <+> ppr data_con_display_type , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
compiler/GHC/Tc/Utils/Env.hs view
@@ -280,7 +280,7 @@ thing <- tcLookupGlobal name case thing of AConLike cl -> return cl- ATyCon tc -> failIllegalTyCon WL_Constructor tc+ ATyCon {} -> failIllegalTyCon WL_Constructor name _ -> wrongThingErr WrongThingConLike (AGlobal thing) name tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent@@ -353,19 +353,20 @@ lookupThing = tcLookupGlobal -- Illegal term-level use of type things-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a+failIllegalTyCon :: WhatLooking -> Name -> TcM a failIllegalTyVal :: Name -> TcM a (failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar) where- fail_tycon what_looking tc = do+ fail_tycon what_looking tc_nm = do gre <- getGlobalRdrEnv- let nm = tyConName tc- pprov = case lookupGRE_Name gre nm of+ let mb_gre = lookupGRE_Name gre tc_nm+ pprov = case mb_gre of Just gre -> nest 2 (pprNameProvenance gre) Nothing -> empty- err | isClassTyCon tc = ClassTE- | otherwise = TyConTE- fail_with_msg what_looking dataName nm pprov err+ err = case greInfo <$> mb_gre of+ Just (IAmTyCon ClassFlavour) -> ClassTE+ _ -> TyConTE+ fail_with_msg what_looking dataName tc_nm pprov err fail_tyvar nm = let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.10.2.20250515+version: 9.10.3.20250912 license: BSD-3-Clause license-file: LICENSE category: Development@@ -104,7 +104,7 @@ semaphore-compat, rts, hpc >= 0.6 && < 0.8,- ghc-lib-parser == 9.10.2.20250515+ ghc-lib-parser == 9.10.3.20250912 build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2 other-extensions: BangPatterns
ghc-lib/stage0/lib/settings view
@@ -17,14 +17,14 @@ ,("ld supports filelist", "YES") ,("ld supports single module", "NO") ,("ld is GNU ld", "NO")-,("Merge objects command", "/usr/bin/ld")+,("Merge objects command", "/usr/local/anaconda3/bin/ld") ,("Merge objects flags", "-r") ,("Merge objects supports response files", "YES")-,("ar command", "/usr/bin/ar")+,("ar command", "/usr/local/anaconda3/bin/ar") ,("ar flags", "qcls") ,("ar supports at file", "NO") ,("ar supports -L", "NO")-,("ranlib command", "/usr/bin/ranlib")+,("ranlib command", "/usr/local/anaconda3/bin/ranlib") ,("otool command", "otool") ,("install_name_tool command", "install_name_tool") ,("windres command", "/bin/false")