diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -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) } diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -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 } diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs --- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Asm.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs --- a/compiler/GHC/CmmToAsm/Wasm/Types.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Types.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -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]) diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -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) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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) diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -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 } diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -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" {- diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -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 diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -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 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -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 } diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -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) + diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -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" diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -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 diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs --- a/compiler/GHC/SysTools/Ar.hs +++ b/compiler/GHC/SysTools/Ar.hs @@ -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) $ diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -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') } diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -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 } diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -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) diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs --- a/compiler/GHC/Tc/Solver/Dict.hs +++ b/compiler/GHC/Tc/Solver/Dict.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -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) } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -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)) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -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)) diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -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")