ghc-lib 9.4.4.20221225 → 9.4.5.20230430
raw patch · 40 files changed
+860/−482 lines, 40 filesdep ~ghc-lib-parserdep ~transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-lib-parser, transformers
API changes (from Hackage documentation)
- GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.Instr
- GHC.Core.Opt.WorkWrap.Utils: addVoidWorkerArg :: [Var] -> [StrictnessMark] -> ([Var], [Var], [StrictnessMark])
- GHC.Tc.Gen.Match: checkPatCounts :: AnnoBody body => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
+ GHC.CmmToAsm.AArch64.Instr: instrCon :: Instr -> String
+ GHC.Core.Opt.FloatIn: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.FloatIn.FloatInBind
+ GHC.Driver.Make: instance GHC.Utils.Outputable.Outputable GHC.Driver.Make.CachedIface
+ GHC.IfaceToCore: hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type)
+ GHC.Plugins: splitForAllTyVars :: Type -> ([TyVar], Type)
+ GHC.Tc.Gen.Match: checkArgCounts :: AnnoBody body => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
+ GHC.Tc.Validity: checkEscapingKind :: Type -> TcM ()
- GHC.Driver.Make: ModNodeKeyWithUid :: ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
+ GHC.Driver.Make: ModNodeKeyWithUid :: !ModuleNameWithIsBoot -> !UnitId -> ModNodeKeyWithUid
- GHC.Driver.Make: [mnkModuleName] :: ModNodeKeyWithUid -> ModuleNameWithIsBoot
+ GHC.Driver.Make: [mnkModuleName] :: ModNodeKeyWithUid -> !ModuleNameWithIsBoot
- GHC.Driver.Make: [mnkUnitId] :: ModNodeKeyWithUid -> UnitId
+ GHC.Driver.Make: [mnkUnitId] :: ModNodeKeyWithUid -> !UnitId
- GHC.Driver.Make: summariseFile :: HscEnv -> HomeUnit -> Map FilePath ModSummary -> FilePath -> Maybe Phase -> Maybe (StringBuffer, UTCTime) -> IO (Either DriverMessages ModSummary)
+ GHC.Driver.Make: summariseFile :: HscEnv -> HomeUnit -> Map (UnitId, FilePath) ModSummary -> FilePath -> Maybe Phase -> Maybe (StringBuffer, UTCTime) -> IO (Either DriverMessages ModSummary)
- GHC.Driver.Make: summariseModule :: HscEnv -> HomeUnit -> Map FilePath ModSummary -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO SummariseResult
+ GHC.Driver.Make: summariseModule :: HscEnv -> HomeUnit -> Map (UnitId, FilePath) ModSummary -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO SummariseResult
- GHC.Tc.Gen.Match: tcMatchesFun :: LocatedN Id -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+ GHC.Tc.Gen.Match: tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
Files
- compiler/GHC.hs +10/−2
- compiler/GHC/CmmToAsm.hs +15/−0
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +35/−16
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +80/−11
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−4
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +1/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +31/−7
- compiler/GHC/Core/Opt/FloatIn.hs +159/−104
- compiler/GHC/Core/Opt/Simplify.hs +2/−2
- compiler/GHC/Core/Opt/SpecConstr.hs +102/−61
- compiler/GHC/Core/Opt/Specialise.hs +28/−2
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +60/−18
- compiler/GHC/Driver/Main.hs +19/−12
- compiler/GHC/Driver/Make.hs +26/−19
- compiler/GHC/Driver/Pipeline/Execute.hs +25/−13
- compiler/GHC/HsToCore/Usage.hs +5/−2
- compiler/GHC/Iface/Ext/Ast.hs +1/−1
- compiler/GHC/Iface/Load.hs +4/−2
- compiler/GHC/Iface/Recomp.hs +15/−12
- compiler/GHC/Iface/Tidy.hs +2/−1
- compiler/GHC/IfaceToCore.hs +17/−1
- compiler/GHC/Rename/Bind.hs +47/−10
- compiler/GHC/Runtime/Eval.hs +10/−2
- compiler/GHC/StgToByteCode.hs +3/−4
- compiler/GHC/Tc/Gen/Arrow.hs +1/−1
- compiler/GHC/Tc/Gen/Bind.hs +9/−25
- compiler/GHC/Tc/Gen/Match.hs +17/−36
- compiler/GHC/Tc/Gen/Match.hs-boot +2/−2
- compiler/GHC/Tc/Solver/Interact.hs +48/−41
- compiler/GHC/Tc/Solver/Monad.hs +2/−2
- compiler/GHC/Tc/TyCl.hs +1/−44
- compiler/GHC/Tc/TyCl/PatSyn.hs +1/−1
- compiler/GHC/Tc/Validity.hs +51/−1
- compiler/GHC/ThToHs.hs +1/−1
- compiler/GHC/Unit/Finder.hs +4/−1
- compiler/ghc-llvm-version.h +1/−1
- ghc-lib.cabal +14/−7
- ghc-lib/stage0/lib/settings +1/−1
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +7/−7
- ghc-lib/stage0/rts/build/include/ghcautoconf.h +1/−4
compiler/GHC.hs view
@@ -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
compiler/GHC/CmmToAsm.hs view
@@ -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
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -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'@.
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -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)
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -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"
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -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
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -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?
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -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)
compiler/GHC/Core/Opt/Simplify.hs view
@@ -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'
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -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]
compiler/GHC/Core/Opt/Specialise.hs view
@@ -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# = <some literal>+ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Driver/Main.hs view
@@ -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
compiler/GHC/Driver/Make.hs view
@@ -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
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -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,
compiler/GHC/HsToCore/Usage.hs view
@@ -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,
compiler/GHC/Iface/Ext/Ast.hs view
@@ -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 []
compiler/GHC/Iface/Load.hs view
@@ -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'
compiler/GHC/Iface/Recomp.hs view
@@ -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
compiler/GHC/Iface/Tidy.hs view
@@ -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
compiler/GHC/IfaceToCore.hs view
@@ -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)
compiler/GHC/Rename/Bind.hs view
@@ -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
compiler/GHC/Runtime/Eval.hs view
@@ -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
compiler/GHC/StgToByteCode.hs view
@@ -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
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -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')) }
compiler/GHC/Tc/Gen/Bind.hs view
@@ -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'
compiler/GHC/Tc/Gen/Match.hs view
@@ -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
compiler/GHC/Tc/Gen/Match.hs-boot view
@@ -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))
compiler/GHC/Tc/Solver/Interact.hs view
@@ -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)
compiler/GHC/Tc/Solver/Monad.hs view
@@ -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
compiler/GHC/Tc/TyCl.hs view
@@ -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 ()
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -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)
compiler/GHC/Tc/Validity.hs view
@@ -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
compiler/GHC/ThToHs.hs view
@@ -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
compiler/GHC/Unit/Finder.hs view
@@ -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
compiler/ghc-llvm-version.h view
@@ -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)
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 9.4.4.20221225+version: 9.4.5.20230430 license: BSD3 license-file: LICENSE category: Development@@ -48,7 +48,10 @@ source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git-+flag threaded-rts+ default: True+ manual: True+ description: Pass -DTHREADED_RTS to the C toolchain library default-language: Haskell2010 exposed: False@@ -57,9 +60,13 @@ ghc-lib/stage0/lib ghc-lib/stage0/compiler/build compiler- ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS- cc-options: -DTHREADED_RTS- cpp-options: -DTHREADED_RTS+ if flag(threaded-rts)+ ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+ cc-options: -DTHREADED_RTS+ cpp-options: -DTHREADED_RTS+ else+ ghc-options: -fobject-code -package=ghc-boot-th+ cpp-options: if !os(windows) build-depends: unix else@@ -78,12 +85,12 @@ array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.5, pretty == 1.1.*,- transformers == 0.5.*,+ transformers >= 0.5 && < 0.7, process >= 1 && < 1.7, stm, rts, hpc == 0.6.*,- ghc-lib-parser == 9.4.4.20221225+ ghc-lib-parser == 9.4.5.20230430 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns
ghc-lib/stage0/lib/settings view
@@ -3,7 +3,7 @@ ,("C compiler flags", "--target=x86_64-apple-darwin ") ,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin ")+,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_lock 1224 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184+#define OFFSET_Capability_context_switch 1192 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188+#define OFFSET_Capability_interrupt 1196 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320+#define OFFSET_Capability_sparks 1328 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192+#define OFFSET_Capability_total_allocated 1200 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168+#define OFFSET_Capability_weak_ptr_list_hd 1176 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176+#define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -204,9 +204,6 @@ /* Define to 1 if the system has the type `long long'. */ #define HAVE_LONG_LONG 1 -/* Define to 1 if you have the mingwex library. */-/* #undef HAVE_MINGWEX */- /* Define to 1 if you have the <minix/config.h> header file. */ /* #undef HAVE_MINIX_CONFIG_H */ @@ -626,7 +623,7 @@ /* #undef pid_t */ /* 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)