diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -360,6 +360,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -561,7 +562,12 @@ initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir - = do { env <- liftIO $ + = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds. + -- So we can't use assertM here. + -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why. + !keep_cafs <- liftIO $ c_keepCAFsForGHCi + ; massert keep_cafs + ; env <- liftIO $ do { top_dir <- findTopDir mb_top_dir ; mySettings <- initSysTools top_dir ; myLlvmConfig <- lazyInitLlvmConfig top_dir @@ -607,7 +613,6 @@ arch = platformArch platform tablesNextToCode = platformTablesNextToCode platform - -- %************************************************************************ -- %* * -- Flags & settings @@ -1994,3 +1999,6 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +foreign import ccall unsafe "keepCAFsForGHCi" + c_keepCAFsForGHCi :: IO Bool diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs --- a/GHC/ByteCode/Types.hs +++ b/GHC/ByteCode/Types.hs @@ -22,12 +22,10 @@ import GHC.Data.FastString import GHC.Data.SizedSeq -import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps -import GHC.Core.Type import GHC.Types.SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes @@ -40,10 +38,10 @@ import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.Maybe (catMaybes) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) +import GHC.Iface.Syntax -- ----------------------------------------------------------------------------- -- Compiled Byte Code @@ -163,18 +161,22 @@ rnf x = x `seq` () -- | Information about a breakpoint that we know at code-generation time +-- In order to be used, this needs to be hydrated relative to the current HscEnv by +-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for +-- preventing space leaks (see #22530) data CgBreakInfo = CgBreakInfo - { cgb_vars :: [Maybe (Id,Word16)] - , cgb_resty :: Type + { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint + , cgb_vars :: ![Maybe (IfaceIdBndr, Word16)] + , cgb_resty :: !IfaceType } -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval --- Not a real NFData instance because we can't rnf Id or Type seqCgBreakInfo :: CgBreakInfo -> () seqCgBreakInfo CgBreakInfo{..} = - rnf (map snd (catMaybes (cgb_vars))) `seq` - seqType cgb_resty + rnf cgb_tyvars `seq` + rnf cgb_vars `seq` + rnf cgb_resty instance Outputable UnlinkedBCO where ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -385,7 +385,7 @@ , (0,alex_action_20) ] -{-# LINE 133 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 133 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs --- a/GHC/CmmToAsm.hs +++ b/GHC/CmmToAsm.hs @@ -808,6 +808,19 @@ -- ----------------------------------------------------------------------------- -- Shortcut branches +-- Note [No asm-shortcutting on Darwin] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Asm-shortcutting may produce relative references to symbols defined in +-- other compilation units. This is not something that MachO relocations +-- support (see #21972). For this reason we disable the optimisation on Darwin. +-- We do so in the backend without a warning since this flag is enabled by +-- `-O2`. +-- +-- Another way to address this issue would be to rather implement a +-- PLT-relocatable jump-table strategy. However, this would only benefit Darwin +-- and does not seem worth the effort as this optimisation generally doesn't +-- offer terribly great benefits. + shortcutBranches :: forall statics instr jumpDest. (Outputable jumpDest) => NCGConfig @@ -818,6 +831,8 @@ shortcutBranches config ncgImpl tops weights | ncgEnableShortcutting config + -- See Note [No asm-shortcutting on Darwin] + , not $ osMachOTarget $ platformOS $ ncgPlatform config = ( map (apply_mapping ncgImpl mapping) tops' , shortcutWeightMap mappingBid <$!> weights ) | otherwise diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr @@ -771,12 +770,12 @@ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) -- 3. Logic &&, || - CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) r' = getRegisterReg plat reg - CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) r' = getRegisterReg plat reg @@ -965,19 +964,6 @@ isNbitEncodeable :: Int -> Integer -> Bool isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) - -- This needs to check if n can be encoded as a bitmask immediate: - -- - -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly - -- - isBitMaskImmediate :: Integer -> Bool - isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000 - ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000 - ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000 - ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000 - ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000 - ,0b0011_1111, 0b0111_1110, 0b1111_1100 - ,0b0111_1111, 0b1111_1110 - ,0b1111_1111] -- N.B. MUL does not set the overflow flag. do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register @@ -1019,6 +1005,39 @@ mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL` CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL` CSET (OpReg w dst) NE) + +-- | Is a given number encodable as a bitmask immediate? +-- +-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly +isAArch64Bitmask :: Integer -> Bool +-- N.B. zero and ~0 are not encodable as bitmask immediates +isAArch64Bitmask 0 = False +isAArch64Bitmask n + | n == bit 64 - 1 = False +isAArch64Bitmask n = + check 64 || check 32 || check 16 || check 8 + where + -- Check whether @n@ can be represented as a subpattern of the given + -- width. + check width + | hasOneRun subpat = + let n' = fromIntegral (mkPat width subpat) + in n == n' + | otherwise = False + where + subpat :: Word64 + subpat = fromIntegral (n .&. (bit width - 1)) + + -- Construct a bit-pattern from a repeated subpatterns the given width. + mkPat :: Int -> Word64 -> Word64 + mkPat width subpat = + foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ] + + -- Does the given number's bit representation match the regular expression + -- @0*1*0*@? + hasOneRun :: Word64 -> Bool + hasOneRun m = + 64 == popCount m + countLeadingZeros m + countTrailingZeros m -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@. diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -72,6 +72,12 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of ANN _ i -> regUsageOfInstr platform i + COMMENT{} -> usage ([], []) + MULTILINE_COMMENT{} -> usage ([], []) + PUSH_STACK_FRAME -> usage ([], []) + POP_STACK_FRAME -> usage ([], []) + DELTA{} -> usage ([], []) + -- 1. Arithmetic Instructions ------------------------------------------------ ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) CMN l r -> usage (regOp l ++ regOp r, []) @@ -136,7 +142,7 @@ FCVTZS dst src -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst) - _ -> panic "regUsageOfInstr" + _ -> panic $ "regUsageOfInstr: " ++ instrCon instr where -- filtering the usage is necessary, otherwise the register @@ -200,7 +206,12 @@ patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr instr env = case instr of -- 0. Meta Instructions - ANN d i -> ANN d (patchRegsOfInstr i env) + ANN d i -> ANN d (patchRegsOfInstr i env) + COMMENT{} -> instr + MULTILINE_COMMENT{} -> instr + PUSH_STACK_FRAME -> instr + POP_STACK_FRAME -> instr + DELTA{} -> instr -- 1. Arithmetic Instructions ---------------------------------------------- ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) @@ -266,8 +277,7 @@ SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) - - _ -> pprPanic "patchRegsOfInstr" (text $ show instr) + _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r) @@ -323,7 +333,7 @@ B (TBlock bid) -> B (TBlock (patchF bid)) BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) - _ -> pprPanic "patchJumpInstr" (text $ show instr) + _ -> panic $ "patchJumpInstr: " ++ instrCon instr -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads] @@ -635,10 +645,69 @@ -- Float ABSolute value | FABS Operand Operand -instance Show Instr where - show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2 - show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2 - show _ = "missing" +instrCon :: Instr -> String +instrCon i = + case i of + COMMENT{} -> "COMMENT" + MULTILINE_COMMENT{} -> "COMMENT" + ANN{} -> "ANN" + LOCATION{} -> "LOCATION" + LDATA{} -> "LDATA" + NEWBLOCK{} -> "NEWBLOCK" + DELTA{} -> "DELTA" + SXTB{} -> "SXTB" + UXTB{} -> "UXTB" + SXTH{} -> "SXTH" + UXTH{} -> "UXTH" + PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME" + POP_STACK_FRAME{} -> "POP_STACK_FRAME" + ADD{} -> "ADD" + CMN{} -> "CMN" + CMP{} -> "CMP" + MSUB{} -> "MSUB" + MUL{} -> "MUL" + NEG{} -> "NEG" + SDIV{} -> "SDIV" + SMULH{} -> "SMULH" + SMULL{} -> "SMULL" + SUB{} -> "SUB" + UDIV{} -> "UDIV" + SBFM{} -> "SBFM" + UBFM{} -> "UBFM" + SBFX{} -> "SBFX" + UBFX{} -> "UBFX" + AND{} -> "AND" + ANDS{} -> "ANDS" + ASR{} -> "ASR" + BIC{} -> "BIC" + BICS{} -> "BICS" + EON{} -> "EON" + EOR{} -> "EOR" + LSL{} -> "LSL" + LSR{} -> "LSR" + MOV{} -> "MOV" + MOVK{} -> "MOVK" + MVN{} -> "MVN" + ORN{} -> "ORN" + ORR{} -> "ORR" + ROR{} -> "ROR" + TST{} -> "TST" + STR{} -> "STR" + LDR{} -> "LDR" + STP{} -> "STP" + LDP{} -> "LDP" + CSET{} -> "CSET" + CBZ{} -> "CBZ" + CBNZ{} -> "CBNZ" + J{} -> "J" + B{} -> "B" + BL{} -> "BL" + BCOND{} -> "BCOND" + DMBSY{} -> "DMBSY" + FCVT{} -> "FCVT" + SCVTF{} -> "SCVTF" + FCVTZS{} -> "FCVTZS" + FABS{} -> "FABS" data Target = TBlock BlockId @@ -766,11 +835,11 @@ opRegUExt W32 r = OpRegExt W32 r EUXTW 0 opRegUExt W16 r = OpRegExt W16 r EUXTH 0 opRegUExt W8 r = OpRegExt W8 r EUXTB 0 -opRegUExt w _r = pprPanic "opRegUExt" (text $ show w) +opRegUExt w _r = pprPanic "opRegUExt" (ppr w) opRegSExt :: Width -> Reg -> Operand opRegSExt W64 r = OpRegExt W64 r ESXTX 0 opRegSExt W32 r = OpRegExt W32 r ESXTW 0 opRegSExt W16 r = OpRegExt W16 r ESXTH 0 opRegSExt W8 r = OpRegExt W8 r ESXTB 0 -opRegSExt w _r = pprPanic "opRegSExt" (text $ show w) +opRegSExt w _r = pprPanic "opRegSExt" (ppr w) diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -109,10 +109,8 @@ ArchPPC -> 16 ArchPPC_64 _ -> 15 ArchARM _ _ _ -> panic "trivColorable ArchARM" - -- We should be able to allocate *a lot* more in princple. - -- essentially all 32 - SP, so 31, we'd trash the link reg - -- as well as the platform and all others though. - ArchAArch64 -> 18 + -- N.B. x18 is reserved by the platform on AArch64/Darwin + ArchAArch64 -> 17 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -3951,7 +3951,7 @@ code <- assignMem_IntCode (intFormat width) addr val let needs_fence = case mord of MemOrderSeqCst -> True - MemOrderRelease -> True + MemOrderRelease -> False MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty MemOrderRelaxed -> False return $ if needs_fence then code `snocOL` MFENCE else code diff --git a/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -368,14 +368,70 @@ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The right hand sides of all top-level and recursive @let@s -/must/ be of lifted type (see "Type#type_classification" for -the meaning of /lifted/ vs. /unlifted/). +The Core letrec invariant: -There is one exception to this rule, top-level @let@s are -allowed to bind primitive string literals: see -Note [Core top-level string literals]. + The right hand sides of all + /top-level/ or /recursive/ + bindings must be of lifted type + There is one exception to this rule, top-level @let@s are + allowed to bind primitive string literals: see + Note [Core top-level string literals]. + +See "Type#type_classification" in GHC.Core.Type +for the meaning of "lifted" vs. "unlifted"). + +For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. + +Note [Core let-can-float invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let-can-float invariant: + + The right hand side of a /non-top-level/, /non-recursive/ binding + may be of unlifted type, but only if + the expression is ok-for-speculation + or the 'Let' is for a join point. + + (For top-level or recursive lets see Note [Core letrec invariant].) + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make. + +For discussion of some implications of the let-can-float invariant primops see +Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps. + +Historical Note [The let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules +to the argument of an application, as well as to the RHS of a let. This made some +kind of sense, because 'let' can always be encoded as application: + let x=rhs in b = (\x.b) rhs + +But the let/app invariant got in the way of RULES; see #19313. For example + up :: Int# -> Int# + {-# RULES "up/down" forall x. up (down x) = x #-} +The LHS of this rule doesn't satisfy the let/app invariant. + +Indeed RULES is a big reason that GHC doesn't use ANF, where the argument of an +application is always a variable or a constant. To allow RULES to work nicely +we need to allow lots of things in the arguments of a call. + +TL;DR: we relaxed the let/app invariant to become the let-can-float invariant. + Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted, @@ -414,6 +470,8 @@ Note [Core top-level string literals]. Core-to-core passes may introduce new top-level string literals. + See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString + * In STG, top-level string literals are explicitly represented in the syntax tree. @@ -421,14 +479,9 @@ in the object file, the content of the exported literal is given a label with the _bytes suffix. -Note [Core let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The let/app invariant - the right hand side of a non-recursive 'Let', and - the argument of an 'App', - /may/ be of unlifted type, but only if - the expression is ok-for-speculation - or the 'Let' is for a join point. +Note [NON-BOTTOM-DICTS invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is a global invariant (not checkable by Lint) that This means that the let can be floated around without difficulty. For example, this is OK: @@ -448,8 +501,24 @@ The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in GHC.Core.Make. -For discussion of some implications of the let/app invariant primops see -Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps. +* A superclass selection from some other dictionary. This is harder to guarantee: + see Note [Recursive superclasses] and Note [Solving superclass constraints] + in GHC.Tc.TyCl.Instance. + +A bad Core-to-Core pass could invalidate this reasoning, but that's too bad. +It's still an invariant of Core programs generated by GHC from Haskell, and +Core-to-Core passes maintain it. + +Why is it useful to know that dictionaries are non-bottom? + +1. It justifies the use of `-XDictsStrict`; + see `GHC.Core.Types.Demand.strictifyDictDmd` + +2. It means that (eq_sel d) is ok-for-speculation and thus + case (eq_sel d) of _ -> blah + can be discarded by the Simplifier. See these Notes: + Note [exprOkForSpeculation and type classes] in GHC.Core.Utils + Note[Speculative evaluation] in GHC.CoreToStg.Prep Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs --- a/GHC/Core/Opt/ConstantFold.hs +++ b/GHC/Core/Opt/ConstantFold.hs @@ -1112,16 +1112,11 @@ -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) - = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy] - [ Lit (mkLitINT64 (toInteger m)) + = Just $ mkCoreUbxTup [int64PrimTy, intPrimTy] + [ Lit (mkLitInt64Wrap (toInteger m)) , mkIntVal platform (toInteger e) ] where platform = roPlatform env - (iNT64Ty, mkLitINT64) - | platformWordSizeInBits platform < 64 - = (int64PrimTy, mkLitInt64Wrap) - | otherwise - = (intPrimTy , mkLitIntWrap platform) doubleDecodeOp _ _ = Nothing diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs --- a/GHC/Core/Opt/DmdAnal.hs +++ b/GHC/Core/Opt/DmdAnal.hs @@ -281,7 +281,8 @@ -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) where - WithDmdType body_ty body' = anal_body env + WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) + -- See Note [Bringing a new variable into scope] WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id -- See Note [Finalising boxity for demand signatures] @@ -415,7 +416,8 @@ dmdAnal' env dmd (Lam var body) | isTyVar var = let - WithDmdType body_ty body' = dmdAnal env dmd body + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body + -- See Note [Bringing a new variable into scope] in WithDmdType body_ty (Lam var body') @@ -423,7 +425,8 @@ = let (n, body_dmd) = peelCallDmd dmd -- body_dmd: a demand to analyze the body - WithDmdType body_ty body' = dmdAnal env body_dmd body + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body + -- See Note [Bringing a new variable into scope] WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var new_dmd_type = multDmdType n lam_ty in @@ -435,7 +438,9 @@ -- can consider its field demands when analysing the scrutinee. | want_precise_field_dmds alt = let - WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs + rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd @@ -564,7 +569,9 @@ dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType CoreAlt dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs + | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on case-alternative binders] @@ -2042,7 +2049,7 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv --- | Extend an environment with the strictness IDs attached to the id +-- | Extend an environment with the strictness sigs attached to the Ids extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs top_lvl env vars = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } @@ -2061,6 +2068,12 @@ lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id +addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv +addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } + +addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv +addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } + nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -2099,7 +2112,18 @@ fam_envs = ae_fam_envs env -{- Note [Making dictionary parameters strict] +{- Note [Bringing a new variable into scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = blah + g = ...(\f. ...f...)... + +In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`, +not the top-level `f` (which will be in `ae_sigs`). So it's very important +to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`. +Otherwise chaos results (#22718). + +Note [Making dictionary parameters strict] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? diff --git a/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs --- a/GHC/Core/Opt/FloatIn.hs +++ b/GHC/Core/Opt/FloatIn.hs @@ -34,9 +34,12 @@ import GHC.Types.Var.Set import GHC.Utils.Misc -import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable + +import Data.List ( mapAccumL ) + {- Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. @@ -123,7 +126,7 @@ ************************************************************************ -} -type FreeVarSet = DIdSet +type FreeVarSet = DVarSet type BoundVarSet = DIdSet data FloatInBind = FB BoundVarSet FreeVarSet FloatBind @@ -131,11 +134,17 @@ -- of recursive bindings, the set doesn't include the bound -- variables. -type FloatInBinds = [FloatInBind] - -- In reverse dependency order (innermost binder first) +type FloatInBinds = [FloatInBind] -- In normal dependency order + -- (outermost binder first) +type RevFloatInBinds = [FloatInBind] -- In reverse dependency order + -- (innermost binder first) +instance Outputable FloatInBind where + ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs + , text "fvs =" <+> ppr fvs ]) + fiExpr :: Platform - -> FloatInBinds -- Binds we're trying to drop + -> RevFloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result @@ -146,13 +155,12 @@ fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) - = wrapFloats (drop_here ++ co_drop) $ + = wrapFloats drop_here $ Cast (fiExpr platform e_drop expr) co where - [drop_here, e_drop, co_drop] - = sepBindsByDropPoint platform False - [freeVarsOf expr, freeVarsOfAnn co_ann] - to_drop + (drop_here, [e_drop]) + = sepBindsByDropPoint platform False to_drop + (freeVarsOfAnn co_ann) [freeVarsOf expr] {- Applications: we do float inside applications, mainly because we @@ -161,7 +169,7 @@ -} fiExpr platform to_drop ann_expr@(_,AnnApp {}) - = wrapFloats drop_here $ wrapFloats extra_drop $ + = wrapFloats drop_here $ mkTicks ticks $ mkApps (fiExpr platform fun_drop ann_fun) (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args) @@ -169,21 +177,19 @@ -- length ann_args = length arg_fvs = length arg_drops where (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr - fun_ty = exprType (deAnnotate ann_fun) fun_fvs = freeVarsOf ann_fun - arg_fvs = map freeVarsOf ann_args - (drop_here : extra_drop : fun_drop : arg_drops) - = sepBindsByDropPoint platform False - (extra_fvs : fun_fvs : arg_fvs) - to_drop + (drop_here, fun_drop : arg_drops) + = sepBindsByDropPoint platform False to_drop + here_fvs (fun_fvs : arg_fvs) + -- Shortcut behaviour: if to_drop is empty, -- sepBindsByDropPoint returns a suitable bunch of empty -- lists without evaluating extra_fvs, and hence without -- peering into each argument - (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args - extra_fvs0 = case ann_fun of + (here_fvs, arg_fvs) = mapAccumL add_arg here_fvs0 ann_args + here_fvs0 = case ann_fun of (_, AnnVar _) -> fun_fvs _ -> emptyDVarSet -- Don't float the binding for f into f x y z; see Note [Join points] @@ -191,17 +197,14 @@ -- join point, floating it in isn't especially harmful but it's -- useless since the simplifier will immediately float it back out.) - add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet) - add_arg (fun_ty, extra_fvs) (_, AnnType ty) - = (piResultTy fun_ty ty, extra_fvs) - - add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg arg_ty - = (res_ty, extra_fvs `unionDVarSet` arg_fvs) - | otherwise - = (res_ty, extra_fvs) + add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet) + add_arg here_fvs (arg_fvs, AnnType _) + = (here_fvs, arg_fvs) + add_arg here_fvs (arg_fvs, arg) + | noFloatIntoArg arg arg_ty = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet) + | otherwise = (here_fvs, arg_fvs) where - (_, arg_ty, res_ty) = splitFunTy fun_ty + arg_ty = exprType $ deAnnotate' arg {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -283,7 +286,6 @@ Urk! if all are tyvars, and we don't float in, we may miss an opportunity to float inside a nested case branch - Note [Floating coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~ We could, in principle, have a coercion binding like @@ -303,6 +305,36 @@ bind a coercion variable mentioned in any of the types, that binder must be dropped right away. +Note [Shadowing and name capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = y+1 in + case p of + (y:ys) -> ...x... + [] -> blah +It is obviously bogus for FloatIn to transform to + case p of + (y:ys) -> ...(let x = y+1 in x)... + [] -> blah +because the y is captured. This doesn't happen much, because shadowing is +rare, but it did happen in #22662. + +One solution would be to clone as we go. But a simpler one is this: + + at a binding site (like that for (y:ys) above), abandon float-in for + any floating bindings that mention the binders (y, ys in this case) + +We achieve that by calling sepBindsByDropPoint with the binders in +the "used-here" set: + +* In fiExpr (AnnLam ...). For the body there is no need to delete + the lambda-binders from the body_fvs, because any bindings that + mention these binders will be dropped here anyway. + +* In fiExpr (AnnCase ...). Remember to include the case_bndr in the + binders. Again, no need to delete the alt binders from the rhs + free vars, beause any bindings mentioning them will be dropped + here unconditionally. -} fiExpr platform to_drop lam@(_, AnnLam _ _) @@ -311,11 +343,18 @@ = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) | otherwise -- Float inside - = mkLams bndrs (fiExpr platform to_drop body) + = wrapFloats drop_here $ + mkLams bndrs (fiExpr platform body_drop body) where (bndrs, body) = collectAnnBndrs lam + body_fvs = freeVarsOf body + -- Why sepBindsByDropPoint? Because of potential capture + -- See Note [Shadowing and name capture] + (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop + (mkDVarSet bndrs) [body_fvs] + {- We don't float lets inwards past an SCC. ToDo: keep info on current cc, and when passing @@ -454,16 +493,16 @@ = wrapFloats shared_binds $ fiExpr platform (case_float : rhs_binds) rhs where - case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs + case_float = FB all_bndrs scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) scrut' = fiExpr platform scrut_binds scrut - rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) - scrut_fvs = freeVarsOf scrut + rhs_fvs = freeVarsOf rhs -- No need to delete alt_bndrs + scrut_fvs = freeVarsOf scrut -- See Note [Shadowing and name capture] + all_bndrs = mkDVarSet alt_bndrs `extendDVarSet` case_bndr - [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint platform False - [scrut_fvs, rhs_fvs] - to_drop + (shared_binds, [scrut_binds, rhs_binds]) + = sepBindsByDropPoint platform False to_drop + all_bndrs [scrut_fvs, rhs_fvs] fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ @@ -473,39 +512,43 @@ -- use zipWithEqual, we should have length alts_drops_s = length alts where -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint platform False - [scrut_fvs, all_alts_fvs] - to_drop + (drop_here1, [scrut_drops, alts_drops]) + = sepBindsByDropPoint platform False to_drop + all_alt_bndrs [scrut_fvs, all_alt_fvs] + -- all_alt_bndrs: see Note [Shadowing and name capture] -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) - | [ _ ] <- alts = [] : [alts_drops] - | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops + (drop_here2, alts_drops_s) + = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs - scrut_fvs = freeVarsOf scrut - alts_fvs = map alt_fvs alts - all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (AnnAlt _con args rhs) - = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) - -- Delete case_bndr and args from free vars of rhs - -- to get free vars of alt + scrut_fvs = freeVarsOf scrut + all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts + ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs + + alts_fvs :: [DVarSet] + alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts] + -- No need to delete binders + -- See Note [Shadowing and name capture] + + all_alt_fvs :: DVarSet + all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs + fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform - -> FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreBindWithFVs -- Input binding - -> DVarSet -- Free in scope of binding - -> ( FloatInBinds -- Land these before - , FloatInBind -- The binding itself - , FloatInBinds) -- Land these after + -> RevFloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreBindWithFVs -- Input binding + -> DVarSet -- Free in scope of binding + -> ( RevFloatInBinds -- Land these before + , FloatInBind -- The binding itself + , RevFloatInBinds) -- Land these after fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs - = ( extra_binds ++ shared_binds -- Land these before - -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] + = ( shared_binds -- Land these before + -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] , FB (unitDVarSet id) rhs_fvs' -- The new binding itself (FloatLet (NonRec id rhs')) , body_binds ) -- Land these after @@ -523,10 +566,9 @@ -- We *can't* float into ok-for-speculation unlifted RHSs -- But do float into join points - [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint platform False - [extra_fvs, rhs_fvs, body_fvs2] - to_drop + (shared_binds, [rhs_binds, body_binds]) + = sepBindsByDropPoint platform False to_drop + extra_fvs [rhs_fvs, body_fvs2] -- Push rhs_binds into the right hand side of the binding rhs' = fiRhs platform rhs_binds id ann_rhs @@ -534,7 +576,7 @@ -- Don't forget the rule_fvs; the binding mentions them! fiBind platform to_drop (AnnRec bindings) body_fvs - = ( extra_binds ++ shared_binds + = ( shared_binds , FB (mkDVarSet ids) rhs_fvs' (FloatLet (Rec (fi_bind rhss_binds bindings))) , body_binds ) @@ -548,17 +590,16 @@ unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings , noFloatIntoRhs Recursive bndr rhs ] - (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint platform False - (extra_fvs:body_fvs:rhss_fvs) - to_drop + (shared_binds, body_binds:rhss_binds) + = sepBindsByDropPoint platform False to_drop + extra_fvs (body_fvs:rhss_fvs) rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + fi_bind :: [RevFloatInBinds] -- One per "drop pt" conjured w/ fvs_of_rhss -> [(Id, CoreExprWithFVs)] -> [(Id, CoreExpr)] @@ -567,7 +608,7 @@ | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] ------------------ -fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs | Just join_arity <- isJoinId_maybe bndr , let (bndrs, body) = collectNAnnBndrs join_arity rhs @@ -667,68 +708,84 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: FloatInBinds -> SDoc +-- pprFIB :: RevFloatInBinds -> SDoc -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] sepBindsByDropPoint :: Platform - -> Bool -- True <=> is case expression - -> [FreeVarSet] -- One set of FVs per drop point - -- Always at least two long! - -> FloatInBinds -- Candidate floaters - -> [FloatInBinds] -- FIRST one is bindings which must not be floated - -- inside any drop point; the rest correspond - -- one-to-one with the input list of FV sets + -> Bool -- True <=> is case expression + -> RevFloatInBinds -- Candidate floaters + -> FreeVarSet -- here_fvs: if these vars are free in a binding, + -- don't float that binding inside any drop point + -> [FreeVarSet] -- fork_fvs: one set of FVs per drop point + -> ( RevFloatInBinds -- Bindings which must not be floated inside + , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets -- Every input floater is returned somewhere in the result; -- none are dropped, not even ones which don't seem to be -- free in *any* of the drop-point fvs. Why? Because, for example, -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B. +-- +-- The here_fvs argument is used for two things: +-- * Avoid shadowing bugs: see Note [Shadowing and name capture] +-- * Drop some of the bindings at the top, e.g. of an application type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint platform is_case drop_pts floaters +dropBoxFloats :: DropBox -> RevFloatInBinds +dropBoxFloats (_, floats) = reverse floats + +usedInDropBox :: DIdSet -> DropBox -> Bool +usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs + +initDropBox :: DVarSet -> DropBox +initDropBox fvs = (fvs, []) + +sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs | null floaters -- Shortcut common case - = [] : [[] | _ <- drop_pts] + = ([], [[] | _ <- fork_fvs]) | otherwise - = assert (drop_pts `lengthAtLeast` 2) $ - go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) + = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs) where - n_alts = length drop_pts + n_alts = length fork_fvs - go :: FloatInBinds -> [DropBox] -> [FloatInBinds] - -- The *first* one in the argument list is the drop_here set - -- The FloatInBinds in the lists are in the reverse of - -- the normal FloatInBinds order; that is, they are the right way round! + go :: RevFloatInBinds -> DropBox -> [DropBox] + -> (RevFloatInBinds, [RevFloatInBinds]) + -- The *first* one in the pair is the drop_here set - go [] drop_boxes = map (reverse . snd) drop_boxes + go [] here_box fork_boxes + = (dropBoxFloats here_box, map dropBoxFloats fork_boxes) - go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) - = go binds new_boxes + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes + | drop_here = go binds (insert here_box) fork_boxes + | otherwise = go binds here_box new_fork_boxes where -- "here" means the group of bindings dropped at the top of the fork - (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs - | (fvs, _) <- drop_boxes] + used_here = bndrs `usedInDropBox` here_box + used_in_flags = case fork_boxes of + [] -> [] + [_] -> [True] -- Push all bindings into a single branch + -- No need to look at its free vars + _ -> map (bndrs `usedInDropBox`) fork_boxes + -- Short-cut for the singleton case; + -- used for lambdas and singleton cases drop_here = used_here || cant_push n_used_alts = count id used_in_flags -- returns number of Trues in list. cant_push - | is_case = n_used_alts == n_alts -- Used in all, don't push - -- Remember n_alts > 1 + | is_case = (n_alts > 1 && n_used_alts == n_alts) + -- Used in all, muliple branches, don't push || (n_used_alts > 1 && not (floatIsDupable platform bind)) -- floatIsDupable: see Note [Duplicating floats] | otherwise = floatIsCase bind || n_used_alts > 1 -- floatIsCase: see Note [Floating primops] - new_boxes | drop_here = (insert here_box : fork_boxes) - | otherwise = (here_box : new_fork_boxes) - new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags @@ -738,9 +795,7 @@ insert_maybe box True = insert box insert_maybe box False = box - go _ _ = panic "sepBindsByDropPoint/go" - {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For case expressions we duplicate the binding if it is reasonably @@ -756,14 +811,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs :: RevFloatInBinds -> FreeVarSet floatedBindsFVs binds = mapUnionDVarSet fbFVs binds fbFVs :: FloatInBind -> DVarSet fbFVs (FB _ fvs _) = fvs -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr --- Remember FloatInBinds is in *reverse* dependency order +wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr +-- Remember RevFloatInBinds is in *reverse* dependency order wrapFloats [] e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -1812,7 +1812,8 @@ occAnalLam env (Lam bndr expr) | isTyVar bndr - = let (WithUsageDetails usage expr') = occAnalLam env expr + = let env1 = addOneInScope env bndr + WithUsageDetails usage expr' = occAnalLam env1 expr in WithUsageDetails usage (Lam bndr expr') -- Important: Keep the 'env' unchanged so that with a RHS like -- \(@ x) -> K @x (f @x) @@ -2458,9 +2459,10 @@ -- then please replace x by (y |> sym mco) -- Invariant of course: idType x = exprType (y |> sym mco) , occ_bs_env :: !(VarEnv (OutId, MCoercion)) - , occ_bs_rng :: !VarSet -- Vars free in the range of occ_bs_env -- Domain is Global and Local Ids -- Range is just Local Ids + , occ_bs_rng :: !VarSet + -- Vars (TyVars and Ids) free in the range of occ_bs_env } @@ -2537,14 +2539,15 @@ _ -> False addOneInScope :: OccEnv -> CoreBndr -> OccEnv +-- Needed for all Vars not just Ids +-- See Note [The binder-swap substitution] (BS3) addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } | otherwise = env { occ_bs_env = swap_env `delVarEnv` bndr } addInScope :: OccEnv -> [Var] -> OccEnv --- See Note [The binder-swap substitution] --- It's only neccessary to call this on in-scope Ids, --- but harmless to include TyVars too +-- Needed for all Vars not just Ids +-- See Note [The binder-swap substitution] (BS3) addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs } @@ -2703,25 +2706,29 @@ (BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, and we encounter: - - \x. blah - Here we want to delete the x-binding from occ_bs_env + (i) \x. blah + Here we want to delete the x-binding from occ_bs_env - - \b. blah - This is harder: we really want to delete all bindings that - have 'b' free in the range. That is a bit tiresome to implement, - so we compromise. We keep occ_bs_rng, which is the set of - free vars of rng(occc_bs_env). If a binder shadows any of these - variables, we discard all of occ_bs_env. Safe, if a bit - brutal. NB, however: the simplifer de-shadows the code, so the - next time around this won't happen. + (ii) \b. blah + This is harder: we really want to delete all bindings that + have 'b' free in the range. That is a bit tiresome to implement, + so we compromise. We keep occ_bs_rng, which is the set of + free vars of rng(occc_bs_env). If a binder shadows any of these + variables, we discard all of occ_bs_env. Safe, if a bit + brutal. NB, however: the simplifer de-shadows the code, so the + next time around this won't happen. These checks are implemented in addInScope. + (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623) + because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we + must not replace `x` by `...a...` under /\a. ...x..., or similarly + under a case pattern match that binds `a`. - The occurrence analyser itself does /not/ do cloning. It could, in - principle, but it'd make it a bit more complicated and there is no - great benefit. The simplifer uses cloning to get a no-shadowing - situation, the care-when-shadowing behaviour above isn't needed for - long. + An alternative would be for the occurrence analyser to do cloning as + it goes. In principle it could do so, but it'd make it a bit more + complicated and there is no great benefit. The simplifer uses + cloning to get a no-shadowing situation, the care-when-shadowing + behaviour above isn't needed for long. (BS4) The domain of occ_bs_env can include GlobaIds. Eg case M.foo of b { alts } diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs --- a/GHC/Core/Opt/Simplify.hs +++ b/GHC/Core/Opt/Simplify.hs @@ -3557,8 +3557,8 @@ -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs --- a/GHC/Core/Opt/SpecConstr.hs +++ b/GHC/Core/Opt/SpecConstr.hs @@ -45,6 +45,7 @@ import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name @@ -1741,24 +1742,13 @@ -- return () -- And build the results - ; let spec_body_ty = exprType spec_body - (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1) - = calcSpecInfo fn call_pat extra_bndrs - -- Annotate the variables with the strictness information from - -- the function (see Note [Strictness information in worker binders]) - add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1 - (spec_lam_args, spec_call_args, spec_arity, spec_join_arity) - | add_void_arg - -- See Note [SpecConst needs to add void args first] - , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 [] - -- needsVoidWorkerArg: usual w/w hack to avoid generating - -- a spec_rhs of unlifted type and no args. - , !spec_arity <- spec_arity1 + 1 - , !spec_join_arity <- fmap (+ 1) spec_join_arity1 - = (spec_lam_args, spec_call_args, spec_arity, spec_join_arity) - | otherwise - = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) + ; let spec_body_ty = exprType spec_body + (spec_lam_args, spec_call_args, spec_sig) + = calcSpecInfo fn arg_bndrs call_pat extra_bndrs + spec_arity = count isId spec_lam_args + spec_join_arity | isJoinId fn = Just (length spec_call_args) + | otherwise = Nothing spec_id = asWorkerLikeId $ mkLocalId spec_name Many (mkLamTypes spec_lam_args spec_body_ty) @@ -1768,13 +1758,9 @@ `setIdArity` spec_arity `asJoinId_maybe` spec_join_arity - -- Conditionally use result of new worker-wrapper transform - spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body) - rule_rhs = mkVarApps (Var spec_id) $ - -- This will give us all the arguments we quantify over - -- in the rule plus the void argument if present - -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args` - dropTail (length extra_bndrs) spec_call_args + -- Conditionally use result of new worker-wrapper transform + spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body) + rule_rhs = mkVarApps (Var spec_id) spec_call_args inline_act = idInlineActivation fn this_mod = sc_module env rule = mkRule this_mod True {- Auto -} True {- Local -} @@ -1814,73 +1800,129 @@ = rhs -{- Note [SpecConst needs to add void args first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [SpecConstr void argument insertion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function + f :: Bool -> forall t. blah f start @t = e We want to specialize for a partially applied call `f True`. See also Note [SpecConstr call patterns], second Wrinkle. Naively we would expect to get + $sf :: forall t. blah $sf @t = $se RULE: f True = $sf -The specialized function only takes a single type argument -so we add a void argument to prevent it from turning into -a thunk. See Note [Protecting the last value argument] for details -why. Normally we would add the void argument after the -type argument giving us: +The specialized function only takes a single type argument so we add a +void argument to prevent it from turning into a thunk. See Note +[Protecting the last value argument] for details why. Normally we +would add the void argument after the type argument giving us: + $sf :: forall t. Void# -> bla $sf @t void = $se RULE: f True = $sf void# (wrong) -But if you look closely this wouldn't typecheck! -If we substitute `f True` with `$sf void#` we expect the type argument to be applied first -but we apply void# first. -The easist fix seems to be just to add the void argument to the front of the arguments. -Now we get: + +But if you look closely this wouldn't typecheck! If we substitute `f +True` with `$sf void#` we expect the type argument to be applied first +but we apply void# first. The easiest fix seems to be just to add the +void argument to the front of the arguments. Now we get: + $sf :: Void# -> forall t. bla $sf void @t = $se RULE: f True = $sf void# + And now we can substitute `f True` with `$sf void#` with everything working out nicely! + +More precisely, in `calcSpecInfo` +(i) we need the void arg to /precede/ the `extra_bndrs`, but +(ii) it must still /follow/ `qvar_bndrs`. + +Example to illustrate (ii): + f :: forall r (a :: TYPE r). Bool -> a + f = /\r. /\(a::TYPE r). \b. body + + {- Specialise for f _ _ True -} + + $sf :: forall r (a :: TYPE r). Void# -> a + $sf = /\r. /\(a::TYPE r). \v. body[True/b] + RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void# + +The void argument must follow the foralls, lest the forall be +ill-kinded. See Note [Worker/wrapper needs to add void arg last] in +GHC.Core.Opt.WorkWrap.Utils. + +Note [generaliseDictPats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two rules (#21831, item 2): + RULE "SPEC:foo" forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1 + RULE "SC:foo" forall a. foo @Int @a $fNumInteger = $sfoo2 @a +The former comes from the type class specialiser, the latter from SpecConstr. +Note that $fNumInteger is a top-level binding for Num Integer. + +The trouble is that neither is more general than the other. In a call + (foo @Int @Integer $fNumInteger d) +it isn't clear which rule to fire. + +The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger, +but actually /could/ fire regardless. That is, it could be + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +Now, it is clear that SPEC:foo is more specific. But GHC can't tell +that, because SpecConstr doesn't know that dictionary arguments are +singleton types! So generaliseDictPats teaches it this fact. It +spots such patterns (using typeDeterminesValue), and quantifies over +the dictionary. Now we get + + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new +"SC:foo" to match the (prefix of) "SPEC:foo". -} -calcSpecInfo :: Id -- The original function - -> CallPat -- Call pattern - -> [Var] -- Extra bndrs - -> ( [Var] -- Demand-decorated binders - , DmdSig -- Strictness of specialised thing - , Arity, Maybe JoinArity ) -- Arities of specialised thing --- Calcuate bits of IdInfo for the specialised function +calcSpecInfo :: Id -- The original function + -> [InVar] -- Lambda binders of original RHS + -> CallPat -- Call pattern + -> [Var] -- Extra bndrs + -> ( [Var] -- Demand-decorated lambda binders + -- for RHS of specialised function + , [Var] -- Args for call site + , DmdSig ) -- Strictness of specialised thing +-- Calculate bits of IdInfo for the specialised function -- See Note [Transfer strictness] -- See Note [Strictness information in worker binders] -calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs - | isJoinId fn -- Join points have strictness and arity for LHS only - = ( bndrs_w_dmds - , mkClosedDmdSig qvar_dmds div - , count isId qvars - , Just (length qvars) ) - | otherwise - = ( bndrs_w_dmds - , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div - , count isId qvars + count isId extra_bndrs - , Nothing ) +calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs + = ( spec_lam_bndrs_w_dmds + , spec_call_args + , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div ) where DmdSig (DmdType _ fn_dmds div) = idDmdSig fn - val_pats = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop - -- from the original functions demand and for setting up dmd_env. + val_pats = filterOut isTypeArg pats + -- Value args at call sites, used to determine how many demands to drop + -- from the original functions demand and for setting up dmd_env. + dmd_env = go emptyVarEnv fn_dmds val_pats qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] extra_dmds = dropList val_pats fn_dmds - bndrs_w_dmds = set_dmds qvars qvar_dmds - ++ set_dmds extra_bndrs extra_dmds + -- Annotate the variables with the strictness information from + -- the function (see Note [Strictness information in worker binders]) + qvars_w_dmds = set_dmds qvars qvar_dmds + extras_w_dmds = set_dmds extra_bndrs extra_dmds + spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds + (final_qvars_w_dmds, spec_call_args) + | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs) + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted or ill-kinded type and no args. + -- See Note [SpecConstr void argument insertion] + = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] ) + | otherwise + = ( qvars_w_dmds, qvars ) + set_dmds :: [Var] -> [Demand] -> [Var] set_dmds [] _ = [] set_dmds vs [] = vs -- Run out of demands set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds | otherwise = setIdDemandInfo v d : set_dmds vs ds' - dmd_env = go emptyVarEnv fn_dmds val_pats - go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv -- We've filtered out all the type patterns already go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats @@ -1893,7 +1935,6 @@ , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though... = go env ds args go_one env _ _ = env - {- Note [spec_usg includes rhs_usg] diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -29,7 +29,8 @@ import GHC.Core.Unfold.Make import GHC.Core import GHC.Core.Rules -import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe +import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable + , getIdFromTrivialExpr_maybe , mkCast, exprType ) import GHC.Core.FVs import GHC.Core.TyCo.Rep (TyCoBinder (..)) @@ -1321,7 +1322,10 @@ = [mkDB $ NonRec b r | (b,r) <- pairs] ++ bagToList dump_dbs - ; if float_all then + can_float_this_one = exprIsTopLevelBindable rhs (idType fn) + -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] + + ; if float_all && can_float_this_one then -- Rather than discard the calls mentioning the bound variables -- we float this (dictionary) binding along with the others return ([], free_uds `snocDictBinds` final_binds) @@ -1658,6 +1662,28 @@ even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to preserve laziness. + +Note [Care with unlifted bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#22998) + f x = let x::ByteArray# = + n::Natural = NB x + in wombat @192827 (n |> co) +where + co :: Natural ~ KnownNat 192827 + wombat :: forall (n:Nat). KnownNat n => blah + +Left to itself, the specialiser would float the bindings for `x` and `n` to top +level, so we can specialise `wombat`. But we can't have a top-level ByteArray# +(see Note [Core letrec invariant] in GHC.Core). Boo. + +This is pretty exotic, so we take a simple way out: in specBind (the NonRec +case) do not float the binding itself unless it satisfies exprIsTopLevelBindable. +This is conservative: maybe the RHS of `x` has a free var that would stop it +floating to top level anyway; but that is hard to spot (since we don't know what +the non-top-level in-scope binders are) and rare (since the binding must satisfy +Note [Core let-can-float invariant] in GHC.Core). + Note [Specialising Calls] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs --- a/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/GHC/Core/Opt/WorkWrap/Utils.hs @@ -9,7 +9,7 @@ module GHC.Core.Opt.WorkWrap.Utils ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one - , needsVoidWorkerArg, addVoidWorkerArg + , needsVoidWorkerArg , DataConPatContext(..) , UnboxingDecision(..), wantToUnboxArg , findTypeShape, IsRecDataConResult(..), isRecDataCon @@ -387,25 +387,34 @@ -- Note [Preserving float barriers]. needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool needsVoidWorkerArg fn_id wrap_args work_args - = not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument] - || needs_float_barrier -- See Note [Preserving float barriers] + = thunk_problem -- See Note [Protecting the last value argument] + || needs_float_barrier -- See Note [Preserving float barriers] where - no_value_arg = all (not . isId) work_args + -- thunk_problem: see Note [Protecting the last value argument] + -- For join points we are only worried about (4), not (1-4). + -- And (4) can't happen if (null work_args) + -- (We could be more clever, by looking at the result type, but + -- this approach is simple and conservative.) + thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args) + | otherwise = no_value_arg + no_value_arg = not (any isId work_args) + + -- needs_float_barrier: see Note [Preserving float barriers] + needs_float_barrier = wrap_had_barrier && not work_has_barrier is_float_barrier v = isId v && hasNoOneShotInfo (idOneShotInfo v) wrap_had_barrier = any is_float_barrier wrap_args work_has_barrier = any is_float_barrier work_args - needs_float_barrier = wrap_had_barrier && not work_has_barrier --- | Inserts a `Void#` arg before the first argument. --- --- Why as the first argument? See Note [SpecConst needs to add void args first] --- in SpecConstr. +-- | Inserts a `Void#` arg as the last argument. +-- Why last? See Note [Worker/wrapper needs to add void arg last] addVoidWorkerArg :: [Var] -> [StrictnessMark] - -> ([Var], -- Lambda bound args - [Var], -- Args at call site - [StrictnessMark]) -- cbv semantics for the worker args. -addVoidWorkerArg work_args cbv_marks - = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks) + -> ( [Var] -- Lambda bound args + , [Var] -- Args at call site + , [StrictnessMark]) -- str semantics for the worker args +addVoidWorkerArg work_args str_marks + = ( work_args ++ [voidArgId] + , work_args ++ [voidPrimId] + , str_marks ++ [NotMarkedStrict] ) {- Note [Protecting the last value argument] @@ -413,8 +422,8 @@ If the user writes (\_ -> E), they might be intentionally disallowing the sharing of E. Since absence analysis and worker-wrapper are keen to remove such unused arguments, we add in a void argument to prevent -the function from becoming a thunk. Three reasons why turning a function -into a thunk might be bad: +the function from becoming a thunk. Here are several reasons why turning +a function into a thunk might be bad: 1) It can create a space leak. e.g. f x = let y () = [1..x] @@ -433,8 +442,20 @@ g = \x. 30# Removing the \x would leave an unlifted binding. -NB: none of these apply to a join point. +4) It can create a worker of ill-kinded type (#22275). Consider + f :: forall r (a :: TYPE r). () -> a + f x = f x + Here `x` is absent, but if we simply drop it we'd end up with + $wf :: forall r (a :: TYPE r). a + But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a) + is (TYPE r), which mentions the bound variable `r`. See also + Note [Worker/wrapper needs to add void arg last] +See also Note [Preserving float barriers] + +NB: Of these, only (1-3) don't apply to a join point, which can be +unlifted even if the RHS is not ok-for-speculation. + Note [Preserving float barriers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -467,7 +488,7 @@ * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)... Wrapper arg `a` was the only float barrier and had been dropped. Hence Void# - * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c... +p * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c... Worker arg `c` is a float barrier. * \a.\b{Abs}.\c{os}... ==> \a.\c{os}... Worker arg `a` is a float barrier. @@ -478,6 +499,27 @@ enough to subsume Note [Protecting the last value argument]. Executable examples in T21150. + +Note [Worker/wrapper needs to add void arg last] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider point (4) of Note [Protecting the last value argument] + + f :: forall r (a :: TYPE r). () -> a + f x = f x + +As pointed out in (4) we need to add a void argument. But if we add +it /first/ we'd get + + $wf :: Void# -> forall r (a :: TYPE r). a + $wf = ... + +But alas $wf's type is /still/ still-kinded, just as before in (4). +Solution is simple: put the void argument /last/: + + $wf :: forall r (a :: TYPE r). Void# -> a + $wf = ... + +c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -49,7 +49,7 @@ mkSpecForAllTy, mkSpecForAllTys, mkVisForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, - splitForAllTyCoVars, + splitForAllTyCoVars, splitForAllTyVars, splitForAllReqTVBinders, splitForAllInvisTVBinders, splitForAllTyCoVarBinders, splitForAllTyCoVar_maybe, splitForAllTyCoVar, diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} {-# LANGUAGE DeriveFunctor #-} @@ -50,6 +50,7 @@ import GHC.Types.Unique.Set import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot ) +import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -1045,6 +1046,59 @@ (legitimately) have different numbers of arguments. They are surelyApart, so we can report that without looking any further (see #15704). + +Note [Unifying type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unifying type applications is quite subtle, as we found +in #23134 and #22647, when type families are involved. + +Suppose + type family F a :: Type -> Type + type family G k :: k = r | r -> k + +and consider these examples: + +* F Int ~ F Char, where F is injective + Since F is injective, we can reduce this to Int ~ Char, + therefore SurelyApart. + +* F Int ~ F Char, where F is not injective + Without injectivity, return MaybeApart. + +* G Type ~ G (Type -> Type) Int + Even though G is injective and the arguments to G are different, + we cannot deduce apartness because the RHS is oversaturated. + For example, G might be defined as + G Type = Maybe Int + G (Type -> Type) = Maybe + So we return MaybeApart. + +* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char) + F Int Bool ~ Maybe a -- MaybeApart + F Int Bool ~ a b -- MaybeApart + F Int Bool ~ Char -> Bool -- MaybeApart + An oversaturated type family can match an application, + whether it's a TyConApp, AppTy or FunTy. Decompose. + +* F Int ~ a b + We cannot decompose a saturated, or under-saturated + type family application. We return MaybeApart. + +To handle all those conditions, unify_ty goes through +the following checks in sequence, where Fn is a type family +of arity n: + +* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n + A saturated application. + Here we can unify arguments in which Fn is injective. +* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n + A saturated type family can match anything - we return MaybeApart. +* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n + An oversaturated type family can be decomposed. +* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n + If we couldn't decompose in the previous step, we return SurelyApart. + +Afterwards, the rest of the code doesn't have to worry about type families. -} -------------- unify_ty: the main workhorse ----------- @@ -1093,43 +1147,63 @@ = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco - -- NB: This keeps Constraint and Type distinct, as it should for use in the - -- type-checker. - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 + -- Handle non-oversaturated type families first + -- See Note [Unifying type applications] + -- + -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T + -- Note that both sides must not be oversaturated + | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1 + , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2 , tc1 == tc2 - = if isInjectiveTyCon tc1 Nominal - then unify_tys env tys1 tys2 - else do { let inj | isTypeFamilyTyCon tc1 - = case tyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - | otherwise - = repeat False + = do { let inj = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } + | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application + = maybeApart MARTypeFamily -- behaves like a type variable; might match + + | Just _ <- isSatTyFamApp mb_tc_app2 -- (C2) A (not-over-saturated) type-family application + -- behaves like a type variable; might unify + -- but doesn't match (as in the TyVarTy case) + = if um_unif env then maybeApart MARTypeFamily else surelyApart + + -- Handle oversaturated type families. + -- + -- They can match an application (TyConApp/FunTy/AppTy), this is handled + -- the same way as in the AppTy case below. + -- + -- If there is no application, an oversaturated type family can only + -- match a type variable or a saturated type family, + -- both of which we handled earlier. So we can say surelyApart. | Just (tc1, _) <- mb_tc_app1 - , not (isGenerativeTyCon tc1 Nominal) - -- E.g. unify_ty (F ty1) b = MaybeApart - -- because the (F ty1) behaves like a variable - -- NB: if unifying, we have already dealt - -- with the 'ty2 = variable' case - = maybeApart MARTypeFamily + , isTypeFamilyTyCon tc1 + = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) | Just (tc2, _) <- mb_tc_app2 - , not (isGenerativeTyCon tc2 Nominal) - , um_unif env - -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) - -- because the (F ty2) behaves like a variable - -- NB: we have already dealt with the 'ty1 = variable' case - = maybeApart MARTypeFamily + , isTypeFamilyTyCon tc2 + = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) + -- At this point, neither tc1 nor tc2 can be a type family. + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 + = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1) + ; unify_tys env tys1 tys2 + } + where mb_tc_app1 = tcSplitTyConApp_maybe ty1 mb_tc_app2 = tcSplitTyConApp_maybe ty2 @@ -1215,6 +1289,17 @@ go _ _ = surelyApart -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] + +isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type]) +-- Return the argument if we have a saturated type family application +-- If it is /over/ saturated then we return False. E.g. +-- unify_ty (F a b) (c d) where F has arity 1 +-- we definitely want to decompose that type application! (#22647) +isSatTyFamApp tapp@(Just (tc, tys)) + | isTypeFamilyTyCon tc + && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated + = tapp +isSatTyFamApp _ = Nothing --------------------------------- uVar :: UMEnv diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -166,7 +166,7 @@ coreAltsType (alt:_) = coreAltType alt coreAltsType [] = panic "coreAltsType" -mkLamType :: Var -> Type -> Type +mkLamType :: HasDebugCallStack => Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda. diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs --- a/GHC/CoreToIface.hs +++ b/GHC/CoreToIface.hs @@ -42,12 +42,18 @@ , toIfaceVar -- * Other stuff , toIfaceLFInfo + -- * CgBreakInfo + , dehydrateCgBreakInfo ) where import GHC.Prelude +import Data.Word + import GHC.StgToCmm.Types +import GHC.ByteCode.Types + import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -657,6 +663,16 @@ IfLFUnlifted LFLetNoEscape -> panic "toIfaceLFInfo: LFLetNoEscape" + +-- Dehydrating CgBreakInfo + +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> Type -> CgBreakInfo +dehydrateCgBreakInfo ty_vars idOffSets tick_ty = + CgBreakInfo + { cgb_tyvars = map toIfaceTvBndr ty_vars + , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets + , cgb_resty = toIfaceType tick_ty + } {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Driver/Errors/Ppr.hs b/GHC/Driver/Errors/Ppr.hs --- a/GHC/Driver/Errors/Ppr.hs +++ b/GHC/Driver/Errors/Ppr.hs @@ -76,28 +76,29 @@ -> diagnosticMessage m DriverPsHeaderMessage m -> diagnosticMessage m - DriverMissingHomeModules missing buildingCabalPackage + DriverMissingHomeModules uid missing buildingCabalPackage -> let msg | buildingCabalPackage == YesBuildingCabalPackage = hang - (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules for" <+> quotes (ppr uid) <+> text ":") 4 (sep (map ppr missing)) | otherwise = hang - (text "Modules are not listed in command line but needed for compilation: ") + (text "Modules are not listed in options for" + <+> quotes (ppr uid) <+> text "but needed for compilation:") 4 (sep (map ppr missing)) in mkSimpleDecorated msg - DriverUnknownHiddenModules missing + DriverUnknownHiddenModules uid missing -> let msg = hang - (text "Modules are listened as hidden but not part of the unit: ") + (text "Modules are listed as hidden in options for" <+> quotes (ppr uid) <+> text "but not part of the unit:") 4 (sep (map ppr missing)) in mkSimpleDecorated msg - DriverUnknownReexportedModules missing + DriverUnknownReexportedModules uid missing -> let msg = hang - (text "Modules are listened as reexported but can't be found in any dependency: ") + (text "Modules are listed as reexported in options for" <+> quotes (ppr uid) <+> text "but can't be found in any dependency:") 4 (sep (map ppr missing)) in mkSimpleDecorated msg diff --git a/GHC/Driver/Errors/Types.hs b/GHC/Driver/Errors/Types.hs --- a/GHC/Driver/Errors/Types.hs +++ b/GHC/Driver/Errors/Types.hs @@ -126,17 +126,17 @@ Test case: warnings/should_compile/MissingMod -} - DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage + DriverMissingHomeModules :: UnitId -> [ModuleName] -> !BuildingCabalPackage -> DriverMessage {-| DriverUnknown is a warning that arises when a user tries to reexport a module which isn't part of that unit. -} - DriverUnknownReexportedModules :: [ModuleName] -> DriverMessage + DriverUnknownReexportedModules :: UnitId -> [ModuleName] -> DriverMessage {-| DriverUnknownHiddenModules is a warning that arises when a user tries to hide a module which isn't part of that unit. -} - DriverUnknownHiddenModules :: [ModuleName] -> DriverMessage + DriverUnknownHiddenModules :: UnitId -> [ModuleName] -> DriverMessage {-| DriverUnusedPackages occurs when when package is requested on command line, but was never needed during compilation. Activated by -Wunused-packages. diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -778,6 +778,12 @@ msg $ UpToDate return $ HscUpToDate checked_iface Nothing -- Do need linkable + backend + | not (backendProducesObject backend) + , IsBoot <- isBootSummary mod_summary + -> do + msg $ UpToDate + return $ HscUpToDate checked_iface Nothing _ -> do -- Check to see whether the expected build products already exist. -- If they don't exists then we trigger recompilation. @@ -1303,19 +1309,20 @@ -- restore old errors logDiagnostics oldErrs - case (isEmptyMessages safeErrs) of - -- Failed safe check - False -> liftIO . throwErrors $ safeErrs + diag_opts <- initDiagOpts <$> getDynFlags + logger <- getLogger - -- Passed safe check - True -> do - let infPassed = isEmptyMessages infErrs - tcg_env' <- case (not infPassed) of - True -> markUnsafeInfer tcg_env infErrs - False -> return tcg_env - when (packageTrustOn dflags) $ checkPkgTrust pkgReqs - let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed - return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + -- Will throw if failed safe check + liftIO $ printOrThrowDiagnostics logger diag_opts safeErrs + + -- No fatal warnings or errors: passed safe check + let infPassed = isEmptyMessages infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } where impInfo = tcg_imports tcg_env -- ImportAvails diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -105,7 +105,6 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc -import GHC.Types.Unique.FM import GHC.Types.PkgQual import GHC.Unit @@ -343,7 +342,7 @@ TargetFile target_file _ | Just mod_file <- ml_hs_file (ms_location mod) -> - target_file == mod_file || + augmentByWorkingDirectory dflags target_file == mod_file || -- Don't warn on B.hs-boot if B.hs is specified (#16551) addBootSuffix target_file == mod_file || @@ -362,7 +361,7 @@ (mgModSummaries mod_graph)) warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan - $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags) + $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags) -- Check that any modules we want to reexport or hide are actually in the package. warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages @@ -390,14 +389,14 @@ _ -> return True - warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan - $ flag mod + warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ diagnostic final_msgs hidden_warns reexported_warns = unionManyMessages $ - [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)] - ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)] + [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)] + ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)] -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -445,6 +444,9 @@ data CachedIface = CachedIface { cached_modiface :: !ModIface , cached_linkable :: !(Maybe Linkable) } +instance Outputable CachedIface where + ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln] + noIfaceCache :: Maybe ModIfaceCache noIfaceCache = Nothing @@ -815,15 +817,19 @@ , cached_linkable = linkable }) = HomeModInfo iface emptyModDetails linkable' where - modl = moduleName (mi_module iface) + modl = miKey iface linkable' - | Just ms <- lookupUFM ms_map modl + | Just ms <- M.lookup modl ms_map , mi_src_hash iface /= ms_hs_hash ms = Nothing | otherwise = linkable - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error. + ms_map = M.fromListWith + (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2)) + ms2) + [(msKey ms, ms) | ms <- summ] -- --------------------------------------------------------------------------- -- @@ -1490,11 +1496,13 @@ logger = hsc_logger hsc_env roots = hsc_targets hsc_env - -- A cache from file paths to the already summarised modules. + -- A cache from file paths to the already summarised modules. The same file + -- can be used in multiple units so the map is also keyed by which unit the + -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map FilePath ModSummary - old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries] + old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary) getRootSummary Target { targetId = TargetFile file mb_phase @@ -1809,7 +1817,7 @@ summariseFile :: HscEnv -> HomeUnit - -> M.Map FilePath ModSummary -- old summaries + -> M.Map (UnitId, FilePath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -1817,9 +1825,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- M.lookup src_fn old_summaries + -- source file hasn't changed, + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries = do let location = ms_location $ old_summary @@ -1928,7 +1935,7 @@ summariseModule :: HscEnv -> HomeUnit - -> M.Map FilePath ModSummary + -> M.Map (UnitId, FilePath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -1989,7 +1996,7 @@ Right ms -> FoundHome ms new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup src_fn old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/GHC/Driver/Pipeline/Execute.hs @@ -478,21 +478,33 @@ next_phase = hscPostBackendPhase src_flavour (backend dflags) case result of HscUpdate iface -> - do - case src_flavour of - HsigFile -> do - -- We need to create a REAL but empty .o file - -- because we are going to attempt to put it in a library - let input_fn = expectJust "runPhase" (ml_hs_file location) - basename = dropExtension input_fn - compileEmptyStub dflags hsc_env basename location mod_name + if | NoBackend <- backend dflags -> + panic "HscUpdate not relevant for NoBackend" + | Interpreter <- backend dflags -> do + -- In Interpreter way, there is just no linkable for hs-boot files + -- and we don't want to write an empty `o-boot` file when we're not + -- supposed to be writing any .o files (#22669) + return ([], iface, Nothing, o_file) + | otherwise -> do + case src_flavour of + HsigFile -> do + -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + compileEmptyStub dflags hsc_env basename location mod_name - -- In the case of hs-boot files, generate a dummy .o-boot - -- stamp file for the benefit of Make - HsBootFile -> touchObjectFile logger dflags o_file - HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + HsBootFile -> touchObjectFile logger dflags o_file + HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" - return ([], iface, Nothing, o_file) + -- MP: I wonder if there are any lurking bugs here because we + -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a + -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and + -- then will carry around the linkable if we're doing + -- recompilation. + return ([], iface, Nothing, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location, hscs_partial_iface = partial_iface, diff --git a/GHC/Hs/Utils.hs b/GHC/Hs/Utils.hs --- a/GHC/Hs/Utils.hs +++ b/GHC/Hs/Utils.hs @@ -912,7 +912,7 @@ emptyLocalBinds] -- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: LIdP p -> HsMatchContext p +mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_fixity = Prefix , mc_strictness = NoSrcStrict } diff --git a/GHC/HsToCore/Usage.hs b/GHC/HsToCore/Usage.hs --- a/GHC/HsToCore/Usage.hs +++ b/GHC/HsToCore/Usage.hs @@ -35,6 +35,7 @@ import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -173,7 +174,7 @@ case miface of Nothing -> pprPanic "mkObjectUsage" (ppr m) Just iface -> - return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface)) + return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash (mi_final_exts iface)) librarySpecToUsage :: LibrarySpec -> IO [Usage] librarySpecToUsage (Objects os) = traverse (fing Nothing) os @@ -193,6 +194,7 @@ hpt = hsc_HUG hsc_env dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env + home_unit_ids = hsc_all_home_unit_ids hsc_env used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports @@ -238,7 +240,7 @@ -- things in *this* module = Nothing - | not (isHomeModule home_unit mod) + | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } @@ -256,6 +258,7 @@ | otherwise = Just UsageHomeModule { usg_mod_name = moduleName mod, + usg_unit_id = toUnitId (moduleUnit mod), usg_mod_hash = mod_hash, usg_exports = export_hash, usg_entities = Map.toList ent_hashs, diff --git a/GHC/Iface/Ext/Ast.hs b/GHC/Iface/Ext/Ast.hs --- a/GHC/Iface/Ext/Ast.hs +++ b/GHC/Iface/Ext/Ast.hs @@ -943,7 +943,7 @@ name' :: LocatedN Name name' = case hiePass @p of HieRn -> name - HieTc -> mapLoc varName name + HieTc -> name toHie (StmtCtxt a) = toHie a toHie _ = pure [] diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs --- a/GHC/Iface/Load.hs +++ b/GHC/Iface/Load.hs @@ -1164,7 +1164,7 @@ pprUsage usage@UsagePackageModule{} = pprUsageImport usage usg_mod pprUsage usage@UsageHomeModule{} - = pprUsageImport usage usg_mod_name $$ + = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$ nest 2 ( maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] @@ -1176,7 +1176,9 @@ pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsage usage@UsageHomeModuleInterface{} - = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)] + = hsep [text "implementation", ppr (usg_mod_name usage) + , ppr (usg_unit_id usage) + , ppr (usg_iface_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs --- a/GHC/Iface/Recomp.hs +++ b/GHC/Iface/Recomp.hs @@ -399,7 +399,7 @@ when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { ; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) } } - ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u + ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u | u <- mi_usages iface] ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { ; return $ UpToDateItem iface @@ -679,7 +679,7 @@ = do -- Load the imported interface if possible logger <- getLogger let doc_str = sep [text doc_msg, ppr mod] - liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod) + liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod)) mb_iface <- loadInterface doc_str mod ImportBySystem -- Load the interface, but don't complain on failure; @@ -698,8 +698,8 @@ -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired -checkModUsage _ _this_pkg UsagePackageModule{ +checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired +checkModUsage _ UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do logger <- getLogger @@ -711,25 +711,28 @@ -- recompile. This is safe but may entail more recompilation when -- a dependent package has changed. -checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChangedRaw (moduleName mod) checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) -checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do - let mod = mkModule this_pkg mod_name +checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name + , usg_unit_id = uid + , usg_iface_hash = old_mod_hash } = do + let mod = mkModule (RealUnit (Definite uid)) mod_name logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChangedIface mod_name checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) -checkModUsage _ this_pkg UsageHomeModule{ +checkModUsage _ UsageHomeModule{ usg_mod_name = mod_name, + usg_unit_id = uid, usg_mod_hash = old_mod_hash, usg_exports = maybe_old_export_hash, usg_entities = old_decl_hash } = do - let mod = mkModule this_pkg mod_name + let mod = mkModule (RealUnit (Definite uid)) mod_name logger <- getLogger needInterface mod $ \iface -> do let @@ -754,9 +757,9 @@ , up_to_date logger (text " Great! The bits I use are up to date") ] -checkModUsage fc _this_pkg UsageFile{ usg_file_path = file, - usg_file_hash = old_hash, - usg_file_label = mlabel } = +checkModUsage fc UsageFile{ usg_file_path = file, + usg_file_hash = old_hash, + usg_file_label = mlabel } = liftIO $ handleIO handler $ do new_hash <- lookupFileCache fc file diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs --- a/GHC/Iface/Tidy.hs +++ b/GHC/Iface/Tidy.hs @@ -1073,7 +1073,8 @@ -- we have to update the name cache in a nice atomic fashion | local && internal = do uniq <- takeUniqFromNameCache name_cache - let new_local_name = mkInternalName uniq occ' loc + -- See #19619 + let new_local_name = occ' `seq` mkInternalName uniq occ' loc return (occ_env', new_local_name) -- Even local, internal names must get a unique occurrence, because -- if we do -split-objs we externalise the name later, in the code generator diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs --- a/GHC/IfaceToCore.hs +++ b/GHC/IfaceToCore.hs @@ -11,6 +11,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module GHC.IfaceToCore ( tcLookupImported_maybe, @@ -22,11 +24,16 @@ tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, - tcIfaceOneShot + tcIfaceOneShot, + hydrateCgBreakInfo ) where import GHC.Prelude +import GHC.ByteCode.Types + +import Data.Word + import GHC.Driver.Env import GHC.Driver.Session @@ -2069,3 +2076,12 @@ bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside = bind_tv tv $ \tv' -> thing_inside (Bndr tv' vis) + +-- CgBreakInfo + +hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type) +hydrateCgBreakInfo CgBreakInfo{..} = do + bindIfaceTyVars cgb_tyvars $ \_ -> do + result_ty <- tcIfaceType cgb_resty + mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars + return (mbVars, result_ty) diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 87 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -609,7 +609,7 @@ , (0,alex_action_84) ] -{-# LINE 700 "_build/source-dist/ghc-9.4.4-src/ghc-9.4.4/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 700 "_build/source-dist/ghc-9.4.5-src/ghc-9.4.5/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs --- a/GHC/Rename/Bind.hs +++ b/GHC/Rename/Bind.hs @@ -875,17 +875,15 @@ -- Rename the pragmas and signatures -- Annoyingly the type variables /are/ in scope for signatures, but - -- /are not/ in scope in the SPECIALISE instance pramas; e.g. - -- instance Eq a => Eq (T a) where - -- (==) :: a -> a -> a - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs + -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas. + -- See Note [Type variable scoping in SPECIALISE pragmas]. + ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') sig_ctxt | is_cls_decl = ClsDeclCtxt cls | otherwise = InstDeclCtxt bound_nms - ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags - ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $ - renameSigs sig_ctxt other_sigs + ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags + ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $ + renameSigs sig_ctxt other_sigs -- Rename the bindings RHSs. Again there's an issue about whether the -- type variables from the class/instance head are in scope. @@ -896,8 +894,47 @@ emptyFVs binds_w_dus ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } - ; return ( binds'', spec_inst_prags' ++ other_sigs' - , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } + ; return ( binds'', spec_prags' ++ other_sigs' + , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) } + +{- Note [Type variable scoping in SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming the methods of a class or instance declaration, we must be careful +with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance +pragmas: the type variables from the class/instance header DO NOT scope over these, +unlike class/instance method type signatures. + +Examples: + + 1. SPECIALISE + + class C a where + meth :: a + instance C (Maybe a) where + meth = Nothing + {-# SPECIALISE INLINE meth :: Maybe [a] #-} + + 2. SPECIALISE instance + + instance Eq a => Eq (T a) where + (==) :: a -> a -> a + {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + + In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same + as the type variable `a` from the instance header. + For example, the SPECIALISE instance pragma above is a shorthand for + + {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-} + + which is alpha-equivalent to + + {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-} + + This shows that the type variables are not bound in the header. + + Getting this scoping wrong can lead to out-of-scope type variable errors from + Core Lint, see e.g. #22913. +-} rnMethodBindLHS :: Bool -> Name -> LHsBindLR GhcPs GhcPs diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs --- a/GHC/Runtime/Eval.hs +++ b/GHC/Runtime/Eval.hs @@ -136,6 +136,7 @@ import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon) import GHC.Unit.Env +import GHC.IfaceToCore -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -562,11 +563,18 @@ breaks = getModBreaks hmi info = expectJust "bindLocalsAtBreakpoint2" $ IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - mbVars = cgb_vars info - result_ty = cgb_resty info occs = modBreaks_vars breaks ! breakInfo_number span = modBreaks_locs breaks ! breakInfo_number decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number + + -- Rehydrate to understand the breakpoint info relative to the current environment. + -- This design is critical to preventing leaks (#22530) + (mbVars, result_ty) <- initIfaceLoad hsc_env + $ initIfaceLcl breakInfo_module (text "debugger") NotBoot + $ hydrateCgBreakInfo info + + + let -- Filter out any unboxed ids by changing them to Nothings; -- we can't bind these at the prompt diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -90,6 +90,7 @@ import GHC.Stg.Syntax import qualified Data.IntSet as IntSet +import GHC.CoreToIface -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -371,10 +372,8 @@ this_mod <- moduleName <$> getCurrentModule platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs - let breakInfo = CgBreakInfo - { cgb_vars = idOffSets - , cgb_resty = tick_ty - } + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty newBreakInfo tick_no breakInfo hsc_env <- getHscEnv let cc | Just interp <- hsc_interp hsc_env diff --git a/GHC/Tc/Gen/Arrow.hs b/GHC/Tc/Gen/Arrow.hs --- a/GHC/Tc/Gen/Arrow.hs +++ b/GHC/Tc/Gen/Arrow.hs @@ -172,7 +172,7 @@ tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty = addErrCtxt (cmdCtxt cmd) do { let match_ctxt = ArrowLamCaseAlt lc_variant - ; checkPatCounts (ArrowMatchCtxt match_ctxt) match + ; checkArgCounts (ArrowMatchCtxt match_ctxt) match ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) } diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs --- a/GHC/Tc/Gen/Bind.hs +++ b/GHC/Tc/Gen/Bind.hs @@ -75,7 +75,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) -import GHC.Tc.Validity (checkValidType) +import GHC.Tc.Validity (checkValidType, checkEscapingKind) import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set @@ -615,7 +615,7 @@ -- See Note [Relevant bindings and the binder stack] setSrcSpanA bind_loc $ - tcMatchesFun (L nm_loc mono_id) matches + tcMatchesFun (L nm_loc (idName mono_id)) matches (mkCheckExpType rho_ty) -- We make a funny AbsBinds, abstracting over nothing, @@ -844,7 +844,8 @@ , ppr inferred_poly_ty]) ; unless insoluble $ addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ - checkValidType (InfSigCtxt poly_name) inferred_poly_ty + do { checkEscapingKind inferred_poly_ty + ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty } -- See Note [Validity of inferred types] -- If we found an insoluble error in the function definition, don't -- do this check; otherwise (#14000) we may report an ambiguity @@ -1182,18 +1183,14 @@ | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature = setSrcSpanA b_loc $ - do { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) -> - -- See Note [fixM for rhs_ty in tcMonoBinds] - do { mono_id <- newLetBndr no_gen name Many rhs_ty - ; (matches', rhs_ty') - <- tcInfer $ \ exp_ty -> + do { ((co_fn, matches'), rhs_ty') + <- tcInfer $ \ exp_ty -> tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun (L nm_loc mono_id) matches exp_ty - ; return (matches', mono_id, rhs_ty') - } + tcMatchesFun (L nm_loc name) matches exp_ty + ; mono_id <- newLetBndr no_gen name Many rhs_ty' ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, @@ -1307,19 +1304,6 @@ type. There seems to be no way to do this. So currently we only switch to inference when we have no signature for any of the binders. -Note [fixM for rhs_ty in tcMonoBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to create mono_id we need rhs_ty but we don't have it yet, -we only get it from tcMatchesFun later (which needs mono_id to put -into HsMatchContext for pretty printing). To solve this, create -a thunk of rhs_ty with fixM that we fill in later. - -This is fine only because neither newLetBndr or tcMatchesFun look -at the varType field of the Id. tcMatchesFun only looks at idName -of mono_id. - -Also see #20415 for the bigger picture of why tcMatchesFun needs -mono_id in the first place. -} @@ -1447,7 +1431,7 @@ = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id) + ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id)) matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' diff --git a/GHC/Tc/Gen/Match.hs b/GHC/Tc/Gen/Match.hs --- a/GHC/Tc/Gen/Match.hs +++ b/GHC/Tc/Gen/Match.hs @@ -31,7 +31,7 @@ , tcBody , tcDoStmt , tcGuardStmt - , checkPatCounts + , checkArgCounts ) where @@ -93,12 +93,12 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: LocatedN Id -- MatchContext Id +tcMatchesFun :: LocatedN Name -- MatchContext Id -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tcMatchesFun fun_id matches exp_ty +tcMatchesFun fun_name matches exp_ty = do { -- Check that they all have the same no of arguments -- Location is in the monad, set the caller so that -- any inter-equation error messages get some vaguely @@ -106,9 +106,7 @@ -- ann-grabbing, because we don't always have annotations in -- hand when we call tcMatchesFun... traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - -- We can't easily call checkPatCounts here because fun_id can be an - -- unfilled thunk - ; checkArgCounts fun_name matches + ; checkArgCounts what matches ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but @@ -122,17 +120,11 @@ -- a multiplicity argument, and scale accordingly. tcMatches match_ctxt pat_tys rhs_ty matches } where - fun_name = idName (unLoc fun_id) arity = matchGroupArity matches - herald = ExpectedFunTyMatches (NameThing fun_name) matches + herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True -- But that's wrong for f :: Int -> forall a. blah - what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness } - -- Careful: this fun_id could be an unfilled - -- thunk from fixM in tcMonoBinds, so we're - -- not allowed to look at it, except for - -- idName. - -- See Note [fixM for rhs_ty in tcMonoBinds] + what = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness } match_ctxt = MC { mc_what = what, mc_body = tcBody } strictness | [L _ match] <- unLoc $ mg_alts matches @@ -164,7 +156,7 @@ -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty - = do { checkPatCounts (mc_what match_ctxt) match + = do { checkArgCounts (mc_what match_ctxt) match ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do -- checking argument counts since this is also used for \cases tcMatches match_ctxt pat_tys rhs_ty match } @@ -1136,39 +1128,28 @@ \subsection{Errors and contexts} * * ************************************************************************ - -@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. -} +-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same +-- number of args are used in each equation. checkArgCounts :: AnnoBody body - => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () -checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr - --- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same --- number of patterns are used in each alternative -checkPatCounts :: AnnoBody body - => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () -checkPatCounts = check_match_pats . pprMatchContextNouns - -check_match_pats :: AnnoBody body - => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () -check_match_pats _ (MG { mg_alts = L _ [] }) - = return () -check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches + => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM () +checkArgCounts _ (MG { mg_alts = L _ [] }) = return () - | otherwise +checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) + | not (null bad_matches) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ (vcat [ err_msg <+> text "have different numbers of arguments" , nest 2 (ppr (getLocA match1)) , nest 2 (ppr (getLocA (head bad_matches)))]) + | otherwise + = return () where n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] + err_msg = pprMatchContextNouns matchContext args_in_match :: (LocatedA (Match GhcRn body1) -> Int) args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/GHC/Tc/Gen/Match.hs-boot b/GHC/Tc/Gen/Match.hs-boot --- a/GHC/Tc/Gen/Match.hs-boot +++ b/GHC/Tc/Gen/Match.hs-boot @@ -5,13 +5,13 @@ import GHC.Tc.Types ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN ) -import GHC.Types.Id (Id) +import GHC.Types.Name (Name) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Id +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/GHC/Tc/Solver/Interact.hs b/GHC/Tc/Solver/Interact.hs --- a/GHC/Tc/Solver/Interact.hs +++ b/GHC/Tc/Solver/Interact.hs @@ -442,8 +442,8 @@ ppr KeepInert = text "keep inert" ppr KeepWork = text "keep work-item" -solveOneFromTheOther :: CtEvidence -- Inert (Dict or Irred) - -> CtEvidence -- WorkItem (same predicate as inert) +solveOneFromTheOther :: Ct -- Inert (Dict or Irred) + -> Ct -- WorkItem (same predicate as inert) -> TcS InteractResult -- Precondition: -- * inert and work item represent evidence for the /same/ predicate @@ -453,24 +453,41 @@ -- although we don't rewrite wanteds with wanteds, we can combine -- two wanteds into one by solving one from the other -solveOneFromTheOther ev_i ev_w +solveOneFromTheOther ct_i ct_w | CtWanted { ctev_loc = loc_w } <- ev_w , prohibitedSuperClassSolve loc_i loc_w - = -- inert must be Given + = -- Inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork } | CtWanted {} <- ev_w - -- Inert is Given or Wanted - = return $ case ev_i of - CtWanted {} -> choose_better_loc - -- both are Wanted; choice of which to keep is - -- arbitrary. So we look at the context to choose - -- which would make a better error message + = -- Inert is Given or Wanted + case ev_i of + CtGiven {} -> return KeepInert + -- work is Wanted; inert is Given: easy choice. - _ -> KeepInert - -- work is Wanted; inert is Given: easy choice. + CtWanted {} -- Both are Wanted + -- If only one has no pending superclasses, use it + -- Otherwise we can get infinite superclass expansion (#22516) + -- in silly cases like class C T b => C a b where ... + | not is_psc_i, is_psc_w -> return KeepInert + | is_psc_i, not is_psc_w -> return KeepWork + -- If only one is a WantedSuperclassOrigin (arising from expanding + -- a Wanted class constraint), keep the other: wanted superclasses + -- may be unexpected by users + | not is_wsc_orig_i, is_wsc_orig_w -> return KeepInert + | is_wsc_orig_i, not is_wsc_orig_w -> return KeepWork + + -- otherwise, just choose the lower span + -- reason: if we have something like (abs 1) (where the + -- Num constraint cannot be satisfied), it's better to + -- get an error about abs than about 1. + -- This test might become more elaborate if we see an + -- opportunity to improve the error messages + | ((<) `on` ctLocSpan) loc_i loc_w -> return KeepInert + | otherwise -> return KeepWork + -- From here on the work-item is Given | CtWanted { ctev_loc = loc_i } <- ev_i @@ -492,31 +509,21 @@ | otherwise -- Both are Given, levels differ = return different_level_strategy where + ev_i = ctEvidence ct_i + ev_w = ctEvidence ct_w + pred = ctEvPred ev_i + loc_i = ctEvLoc ev_i loc_w = ctEvLoc ev_w lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w - choose_better_loc - -- if only one is a WantedSuperclassOrigin (arising from expanding - -- a Wanted class constraint), keep the other: wanted superclasses - -- may be unexpected by users - | is_wanted_superclass_loc loc_i - , not (is_wanted_superclass_loc loc_w) = KeepWork - - | not (is_wanted_superclass_loc loc_i) - , is_wanted_superclass_loc loc_w = KeepInert - - -- otherwise, just choose the lower span - -- reason: if we have something like (abs 1) (where the - -- Num constraint cannot be satisfied), it's better to - -- get an error about abs than about 1. - -- This test might become more elaborate if we see an - -- opportunity to improve the error messages - | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert - | otherwise = KeepWork + is_psc_w = isPendingScDict ct_w + is_psc_i = isPendingScDict ct_i + is_wsc_orig_i = is_wanted_superclass_loc loc_i + is_wsc_orig_w = is_wanted_superclass_loc loc_w is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin different_level_strategy -- Both Given @@ -644,28 +651,28 @@ -- mean that (ty1 ~ ty2) interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) +interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) | isInsolubleReason reason -- For insolubles, don't allow the constraint to be dropped -- which can happen with solveOneFromTheOther, so that -- we get distinct error messages with -fdefer-type-errors - = continueWith workItem + = continueWith ct_w | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w , ((ct_i, swap) : _rest) <- bagToList matching_irreds -- See Note [Multiple matching irreds] , let ev_i = ctEvidence ct_i - = do { what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) + = do { what_next <- solveOneFromTheOther ct_i ct_w + ; traceTcS "iteractIrred" (ppr ct_w $$ ppr what_next $$ ppr ct_i) ; case what_next of KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) ; updInertIrreds (\_ -> others) - ; continueWith workItem } } + ; continueWith ct_w } } | otherwise - = continueWith workItem + = continueWith ct_w where swap_me :: SwapFlag -> CtEvidence -> EvTerm @@ -995,7 +1002,7 @@ -} interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) +interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys , let ev_i = ctEvidence ct_i = -- There is a matching dictionary in the inert set @@ -1009,22 +1016,22 @@ do { -- Ths short-cut solver didn't fire, so we -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ev_i ev_w + what_next <- solveOneFromTheOther ct_i ct_w ; traceTcS "lookupInertDict" (ppr what_next) ; case what_next of KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith workItem } } } + ; continueWith ct_w } } } | cls `hasKey` ipClassKey , isGiven ev_w - = interactGivenIP inerts workItem + = interactGivenIP inerts ct_w | otherwise = do { addFunDepWork inerts ev_w cls - ; continueWith workItem } + ; continueWith ct_w } interactDict _ wi = pprPanic "interactDict" (ppr wi) diff --git a/GHC/Tc/Solver/Monad.hs b/GHC/Tc/Solver/Monad.hs --- a/GHC/Tc/Solver/Monad.hs +++ b/GHC/Tc/Solver/Monad.hs @@ -538,7 +538,7 @@ get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True -- but flipping the flag get_pending dict dicts - | Just dict' <- isPendingScDict dict + | Just dict' <- pendingScDict_maybe dict , belongs_to_this_level (ctEvidence dict) = dict' : dicts | otherwise @@ -551,7 +551,7 @@ get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- isPendingScInst qci + | Just qci' <- pendingScInst_maybe qci , belongs_to_this_level ev = (CQuantCan qci' : cts, qci') | otherwise diff --git a/GHC/Tc/Solver/Types.hs b/GHC/Tc/Solver/Types.hs --- a/GHC/Tc/Solver/Types.hs +++ b/GHC/Tc/Solver/Types.hs @@ -275,21 +275,29 @@ | debugIsOn = case ct of CEqCan { cc_lhs = TyVarLHS tv } -> - let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv - shares_lhs _other = False - in - assert (all shares_lhs old_eqs) $ - assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs - , ct2 <- ct : old_eqs - , let { fr1 = ctFlavourRole ct1 - ; fr2 = ctFlavourRole ct2 } - , fr1 `eqCanRewriteFR` fr2 ])) $ + assert (all (shares_lhs tv) old_eqs) $ + assertPpr (null bad_prs) + (vcat [ text "bad_prs" <+> ppr bad_prs + , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $ (ct : old_eqs) _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct) | otherwise = ct : old_eqs + where + shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv + shares_lhs _ _ = False + bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs)) + is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2 + +distinctPairs :: [a] -> [(a,a)] +-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...] +-- where i /= j +-- NB: does not return pairs (xi,xi), which would be stupid in the +-- context of addToEqualCtList (#22645) +distinctPairs [] = [] +distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs -- returns Nothing when the new list is empty, to keep the environments smaller filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/GHC/Tc/TyCl.hs @@ -4384,10 +4384,7 @@ -- e.g. reject this: MkT :: T (forall a. a->a) -- Reason: it's really the argument of an equality constraint ; checkValidMonoType orig_res_ty - - -- Check for an escaping result kind - -- See Note [Check for escaping result kind] - ; checkEscapingKind con + ; checkEscapingKind (dataConWrapperType con) -- For /data/ types check that each argument has a fixed runtime rep -- If we are dealing with a /newtype/, we allow representation @@ -4557,46 +4554,6 @@ ok_mult One = True ok_mult _ = False - --- | Reject nullary data constructors where a type variables --- would escape through the result kind --- See Note [Check for escaping result kind] -checkEscapingKind :: DataCon -> TcM () -checkEscapingKind data_con - | null eq_spec, null theta, null arg_tys - , let tau_kind = tcTypeKind res_ty - , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind - -- Ensure that none of the tvs occur in the kind of the forall - -- /after/ expanding type synonyms. - -- See Note [Phantom type variables in kinds] in GHC.Core.Type - = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind - | otherwise - = return () - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) - = dataConFullSig data_con - -{- Note [Check for escaping result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - type T :: TYPE (BoxedRep l) - data T = MkT -This is not OK: we get - MkT :: forall l. T @l :: TYPE (BoxedRep l) -which is ill-kinded. - -For ordinary type signatures f :: blah, we make this check as part of kind-checking -the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType. -But for data constructors we check the type piecemeal, and there is no very -convenient place to do it. For example, note that it only applies for /nullary/ -constructors. If we had - data T = MkT Int -then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine. - -So we make the check in checkValidDataCon. - -Historical note: we used to do the check in checkValidType (#20929 discusses). --} ------------------------------- checkValidClass :: Class -> TcM () diff --git a/GHC/Tc/TyCl/PatSyn.hs b/GHC/Tc/TyCl/PatSyn.hs --- a/GHC/Tc/TyCl/PatSyn.hs +++ b/GHC/Tc/TyCl/PatSyn.hs @@ -840,7 +840,7 @@ , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) [] + match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (EmptyLocalBinds noExtField) diff --git a/GHC/Tc/Types/Constraint.hs b/GHC/Tc/Types/Constraint.hs --- a/GHC/Tc/Types/Constraint.hs +++ b/GHC/Tc/Types/Constraint.hs @@ -9,14 +9,15 @@ -- in the type-checker and constraint solver. module GHC.Tc.Types.Constraint ( -- QCInst - QCInst(..), isPendingScInst, + QCInst(..), pendingScInst_maybe, -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, isEmptyCts, - isPendingScDict, superClassesMightHelp, getPendingWantedScs, + isPendingScDict, pendingScDict_maybe, + superClassesMightHelp, getPendingWantedScs, isWantedCt, isGivenCt, isUserTypeError, getUserTypeErrorMsg, ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, @@ -899,18 +900,24 @@ Just _ -> True _ -> False -isPendingScDict :: Ct -> Maybe Ct +isPendingScDict :: Ct -> Bool +isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc +-- Says whether this is a CDictCan with cc_pend_sc is True; +-- i.e. pending un-expanded superclasses +isPendingScDict _ = False + +pendingScDict_maybe :: Ct -> Maybe Ct -- Says whether this is a CDictCan with cc_pend_sc is True, -- AND if so flips the flag -isPendingScDict ct@(CDictCan { cc_pend_sc = True }) - = Just (ct { cc_pend_sc = False }) -isPendingScDict _ = Nothing +pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True }) + = Just (ct { cc_pend_sc = False }) +pendingScDict_maybe _ = Nothing -isPendingScInst :: QCInst -> Maybe QCInst +pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts -isPendingScInst qci@(QCI { qci_pend_sc = True }) - = Just (qci { qci_pend_sc = False }) -isPendingScInst _ = Nothing +pendingScInst_maybe qci@(QCI { qci_pend_sc = True }) + = Just (qci { qci_pend_sc = False }) +pendingScInst_maybe _ = Nothing superClassesMightHelp :: WantedConstraints -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps @@ -932,7 +939,7 @@ getPendingWantedScs simples = mapAccumBagL get [] simples where - get acc ct | Just ct' <- isPendingScDict ct + get acc ct | Just ct' <- pendingScDict_maybe ct = (ct':acc, ct') | otherwise = (acc, ct) diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs --- a/GHC/Tc/Validity.hs +++ b/GHC/Tc/Validity.hs @@ -13,7 +13,7 @@ Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType, checkValidTheta, checkValidInstance, checkValidInstHead, validDerivPred, - checkTySynRhs, + checkTySynRhs, checkEscapingKind, checkValidCoAxiom, checkValidCoAxBranch, checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, arityErr, @@ -460,6 +460,53 @@ where actual_kind = tcTypeKind ty +{- Note [Check for escaping result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + type T :: TYPE (BoxedRep l) + data T = MkT +This is not OK: we get + MkT :: forall l. T @l :: TYPE (BoxedRep l) +which is ill-kinded. + +For ordinary /user-written type signatures f :: blah, we make this +check as part of kind-checking the type signature in tcHsSigType; see +Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType. + +But in two other places we need to check for an escaping result kind: + +* For data constructors we check the type piecemeal, and there is no + very convenient place to do it. For example, note that it only + applies for /nullary/ constructors. If we had + data T = MkT Int + then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine. + + So we make the check in checkValidDataCon. + +* When inferring the type of a function, there is no user-written type + that we are checking. Forgetting this led to #22743. Now we call + checkEscapingKind in GHC.Tc.Gen.Bind.mkInferredPolyId + +Historical note: we used to do the escaping-kind check in +checkValidType (#20929 discusses), but that is now redundant. +-} + +checkEscapingKind :: Type -> TcM () +-- Give a sigma-type (forall a1 .. an. ty), where (ty :: ki), +-- check that `ki` does not mention any of the binders a1..an. +-- Otherwise the type is ill-kinded +-- See Note [Check for escaping result kind] +checkEscapingKind poly_ty + | (tvs, tau) <- splitForAllTyVars poly_ty + , let tau_kind = typeKind tau + , Nothing <- occCheckExpand tvs tau_kind + -- Ensure that none of the tvs occur in the kind of the forall + -- /after/ expanding type synonyms. + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + = failWithTc $ TcRnForAllEscapeError poly_ty tau_kind + | otherwise + = return () + funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) funArgResRank other_rank = (other_rank, other_rank) @@ -757,6 +804,9 @@ ; check_type (ve{ve_tidy_env = env'}) tau -- Allow foralls to right of arrow + -- Note: skolem-escape in types (e.g. forall r (a::r). a) is handled + -- by tcHsSigType and the constraint solver, so no need to + -- check it here; c.f. #20929 } where (tvbs, phi) = tcSplitForAllTyVarBinders ty diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -1537,7 +1537,7 @@ cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs) cvtSigTypeKind ty_str ty = do ty' <- cvtTypeKind ty_str ty - pure $ hsTypeToHsSigType ty' + pure $ hsTypeToHsSigType $ parenthesizeHsType sigPrec ty' cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty diff --git a/GHC/Types/Name.hs b/GHC/Types/Name.hs --- a/GHC/Types/Name.hs +++ b/GHC/Types/Name.hs @@ -151,7 +151,7 @@ ppr System = text "system" instance NFData Name where - rnf Name{..} = rnf n_sort + rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc instance NFData NameSort where rnf (External m) = rnf m diff --git a/GHC/Unit/Env.hs b/GHC/Unit/Env.hs --- a/GHC/Unit/Env.hs +++ b/GHC/Unit/Env.hs @@ -12,6 +12,7 @@ , ue_setUnits , ue_setUnitFlags , ue_unit_dbs + , ue_all_home_unit_ids , ue_setUnitDbs , ue_hpt , ue_homeUnit @@ -417,7 +418,8 @@ ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env - +ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit -- ------------------------------------------------------- @@ -436,6 +438,7 @@ ue_currentUnit :: UnitEnv -> UnitId ue_currentUnit = ue_current_unit + -- ------------------------------------------------------- -- Operations on arbitrary elements of the home unit graph diff --git a/GHC/Unit/Finder.hs b/GHC/Unit/Finder.hs --- a/GHC/Unit/Finder.hs +++ b/GHC/Unit/Finder.hs @@ -180,7 +180,10 @@ | otherwise = findHomePackageModule fc opts uid mod_name - any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts) + -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as + -- that is not the same!! home_import is first because we need to look within ourselves + -- first before looking at the packages in order. + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg diff --git a/GHC/Unit/Module/Deps.hs b/GHC/Unit/Module/Deps.hs --- a/GHC/Unit/Module/Deps.hs +++ b/GHC/Unit/Module/Deps.hs @@ -256,6 +256,8 @@ | UsageHomeModule { usg_mod_name :: ModuleName, -- ^ Name of the module + usg_unit_id :: UnitId, + -- ^ UnitId of the HomeUnit the module is from usg_mod_hash :: Fingerprint, -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash). -- This may be out dated after recompilation was avoided, but is @@ -292,6 +294,8 @@ | UsageHomeModuleInterface { usg_mod_name :: ModuleName -- ^ Name of the module + , usg_unit_id :: UnitId + -- ^ UnitId of the HomeUnit the module is from , usg_iface_hash :: Fingerprint -- ^ The *interface* hash of the module, not the ABI hash. -- This changes when anything about the interface (and hence the @@ -331,6 +335,7 @@ put_ bh usg@UsageHomeModule{} = do putByte bh 1 put_ bh (usg_mod_name usg) + put_ bh (usg_unit_id usg) put_ bh (usg_mod_hash usg) put_ bh (usg_exports usg) put_ bh (usg_entities usg) @@ -350,6 +355,7 @@ put_ bh usg@UsageHomeModuleInterface{} = do putByte bh 4 put_ bh (usg_mod_name usg) + put_ bh (usg_unit_id usg) put_ bh (usg_iface_hash usg) get bh = do @@ -362,11 +368,12 @@ return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } 1 -> do nm <- get bh + uid <- get bh mod <- get bh exps <- get bh ents <- get bh safe <- get bh - return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_unit_id = uid, usg_exports = exps, usg_entities = ents, usg_safe = safe } 2 -> do fp <- get bh @@ -379,8 +386,9 @@ return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } 4 -> do mod <- get bh + uid <- get bh hash <- get bh - return UsageHomeModuleInterface { usg_mod_name = mod, usg_iface_hash = hash } + return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) diff --git a/GHC/Unit/Module/Graph.hs b/GHC/Unit/Module/Graph.hs --- a/GHC/Unit/Module/Graph.hs +++ b/GHC/Unit/Module/Graph.hs @@ -99,7 +99,7 @@ instance Outputable ModuleGraphNode where ppr = \case InstantiationNode _ iuid -> ppr iuid - ModuleNode nks ms -> ppr (ms_mnwib ms) <+> ppr nks + ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks LinkNode uid _ -> text "LN:" <+> ppr uid instance Eq ModuleGraphNode where @@ -126,8 +126,8 @@ nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk nodeKeyUnitId (NodeKey_Link uid) = uid -data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot - , mnkUnitId :: UnitId } deriving (Eq, Ord) +data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot + , mnkUnitId :: !UnitId } deriving (Eq, Ord) instance Outputable ModNodeKeyWithUid where ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib diff --git a/Language/Haskell/Syntax/Expr.hs b/Language/Haskell/Syntax/Expr.hs --- a/Language/Haskell/Syntax/Expr.hs +++ b/Language/Haskell/Syntax/Expr.hs @@ -1680,7 +1680,10 @@ = FunRhs -- ^ A pattern matching on an argument of a -- function binding - { mc_fun :: LIdP p -- ^ function binder of @f@ + { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@ + -- See Note [mc_fun field of FunRhs] + -- See #20415 for a long discussion about + -- this field and why it uses NoGhcTc. , mc_fixity :: LexicalFixity -- ^ fixing of @f@ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? -- See Note [FunBind vs PatBind] @@ -1707,6 +1710,21 @@ | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration +{- +Note [mc_fun field of FunRhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be +a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a +`Name` in `GhcTc` -- not an `Id`. See Note [NoGhcTc] in GHC.Hs.Extension. + +Why a `Name` in the typechecker phase? Because: +* A `Name` is all we need, as it turns out. +* Using an `Id` involves knot-tying in the monad, which led to #22695. + +See #20415 for a long discussion. + +-} + isPatSynCtxt :: HsMatchContext p -> Bool isPatSynCtxt ctxt = case ctxt of @@ -1801,7 +1819,7 @@ matchSeparator ThPatQuote = panic "unused" matchSeparator PatSyn = panic "unused" -pprMatchContext :: (Outputable (IdP p), UnXRec p) +pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContext ctxt | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt @@ -1812,10 +1830,10 @@ want_an (ArrowMatchCtxt KappaExpr) = True want_an _ = False -pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p) +pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" - <+> quotes (ppr (unXRec @p fun)) + <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) pprMatchContextNoun CaseAlt = text "case alternative" pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant <+> text "alternative" @@ -1831,10 +1849,10 @@ $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration" -pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p) +pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" - <+> quotes (ppr (unXRec @p fun)) + <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) pprMatchContextNouns PatBindGuards = text "pattern binding guards" pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" @@ -1855,7 +1873,7 @@ pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' ----------------- -pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p) +pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsStmtContext p -> SDoc pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt diff --git a/cbits/keepCAFsForGHCi.c b/cbits/keepCAFsForGHCi.c --- a/cbits/keepCAFsForGHCi.c +++ b/cbits/keepCAFsForGHCi.c @@ -1,15 +1,35 @@ #include +#include +// Note [keepCAFsForGHCi] +// ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main()) // which sets the keepCAFs flag in the RTS, before any Haskell code is run. // This is required so that GHCi can use dynamic libraries instead of HSxyz.o // files. +// +// For static builds we have to guarantee that the linker loads this object file +// to ensure the constructor gets run and not discarded. If the object is part of +// an archive and not otherwise referenced the linker would ignore the object. +// To avoid this: +// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been +// enabled by calling keepCAFsForGHCi. +// * This causes the GHC module from the ghc package to carry a reference to this object +// file. +// * Which in turn ensures the linker doesn't discard this object file, causing +// the constructor to be run, allowing the assertion to succeed in the first place +// as keepCAFs will have been set already during initialization of constructors. -static void keepCAFsForGHCi(void) __attribute__((constructor)); -static void keepCAFsForGHCi(void) + +bool keepCAFsForGHCi(void) __attribute__((constructor)); + +bool keepCAFsForGHCi(void) { - keepCAFs = 1; + bool was_set = keepCAFs; + setKeepCAFs(); + return was_set; } + diff --git a/ghc-llvm-version.h b/ghc-llvm-version.h --- a/ghc-llvm-version.h +++ b/ghc-llvm-version.h @@ -3,7 +3,7 @@ #define __GHC_LLVM_VERSION_H__ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (14) +#define sUPPORTED_LLVM_VERSION_MAX (15) /* The minimum supported LLVM version number */ #define sUPPORTED_LLVM_VERSION_MIN (10) diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.4.4 +Version: 9.4.5 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -91,9 +91,9 @@ transformers == 0.5.*, exceptions == 0.10.*, stm, - ghc-boot == 9.4.4, - ghc-heap == 9.4.4, - ghci == 9.4.4 + ghc-boot == 9.4.5, + ghc-heap == 9.4.5, + ghci == 9.4.5 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13