ghc 9.6.1 → 9.6.2
raw patch · 33 files changed
+931/−513 lines, 33 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-boot, ghc-heap, ghci
API changes (from Hackage documentation)
- GHC.ByteCode.Instr: PUSH_ALTS_UNLIFTED :: ProtoBCO Name -> ArgRep -> BCInstr
- GHC.ByteCode.Instr: RETURN_UNLIFTED :: ArgRep -> BCInstr
+ GHC.Core.Opt.Simplify.Utils: FromBeta :: OutType -> FromWhat
+ GHC.Core.Opt.Simplify.Utils: FromLet :: FromWhat
+ GHC.Core.Opt.Simplify.Utils: [sc_from] :: SimplCont -> FromWhat
+ GHC.Core.Opt.Simplify.Utils: data FromWhat
+ GHC.Platform: OSGhcjs :: OS
+ GHC.Tc.TyCl.Class: substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])
- GHC.ByteCode.Instr: PUSH_ALTS :: ProtoBCO Name -> BCInstr
+ GHC.ByteCode.Instr: PUSH_ALTS :: ProtoBCO Name -> ArgRep -> BCInstr
- GHC.ByteCode.Instr: RETURN :: BCInstr
+ GHC.ByteCode.Instr: RETURN :: ArgRep -> BCInstr
- GHC.Core.Coercion: setNominalRole_maybe :: Role -> Coercion -> Maybe Coercion
+ GHC.Core.Coercion: setNominalRole_maybe :: Role -> Coercion -> Maybe CoercionN
- GHC.Core.Opt.Simplify.Utils: StrictBind :: DupFlag -> InId -> InExpr -> StaticEnv -> SimplCont -> SimplCont
+ GHC.Core.Opt.Simplify.Utils: StrictBind :: DupFlag -> InId -> FromWhat -> InExpr -> StaticEnv -> SimplCont -> SimplCont
- GHC.Core.Type: applyTysX :: [TyVar] -> Type -> [Type] -> Type
+ GHC.Core.Type: applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
- GHC.Plugins: applyTysX :: [TyVar] -> Type -> [Type] -> Type
+ GHC.Plugins: applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
- GHC.Plugins: setNominalRole_maybe :: Role -> Coercion -> Maybe Coercion
+ GHC.Plugins: setNominalRole_maybe :: Role -> Coercion -> Maybe CoercionN
Files
- Bytecodes.h +0/−2
- GHC/ByteCode/Asm.hs +12/−16
- GHC/ByteCode/Instr.hs +14/−15
- GHC/Cmm/Lexer.hs +2/−2
- GHC/CmmToAsm/AArch64/CodeGen.hs +35/−16
- GHC/Core.hs +44/−18
- GHC/Core/Coercion.hs +12/−3
- GHC/Core/Opt/Arity.hs +9/−2
- GHC/Core/Opt/OccurAnal.hs +11/−0
- GHC/Core/Opt/Simplify/Env.hs +1/−1
- GHC/Core/Opt/Simplify/Iteration.hs +172/−141
- GHC/Core/Opt/Simplify/Utils.hs +5/−2
- GHC/Core/Opt/Specialise.hs +78/−41
- GHC/Core/Rules.hs +13/−7
- GHC/Core/Type.hs +1/−1
- GHC/Core/Unify.hs +113/−27
- GHC/Core/Utils.hs +2/−2
- GHC/HsToCore/Foreign/JavaScript.hs +1/−1
- GHC/Parser/HaddockLex.hs +2/−2
- GHC/Parser/Lexer.hs +2/−2
- GHC/Platform.hs +1/−0
- GHC/StgToByteCode.hs +103/−86
- GHC/StgToCmm/Closure.hs +1/−2
- GHC/StgToJS/Linker/Utils.hs +2/−2
- GHC/StgToJS/Prim.hs +1/−1
- GHC/Tc/Deriv/Generate.hs +3/−2
- GHC/Tc/TyCl.hs +26/−17
- GHC/Tc/TyCl/Build.hs +14/−6
- GHC/Tc/TyCl/Class.hs +66/−7
- GHC/Tc/Utils/TcType.hs +34/−19
- GHC/Types/Id.hs +8/−6
- GHC/Types/Id/Make.hs +139/−60
- ghc.cabal +4/−4
Bytecodes.h view
@@ -34,7 +34,6 @@ #define bci_PUSH16_W 9 #define bci_PUSH32_W 10 #define bci_PUSH_G 11-#define bci_PUSH_ALTS 12 #define bci_PUSH_ALTS_P 13 #define bci_PUSH_ALTS_N 14 #define bci_PUSH_ALTS_F 15@@ -81,7 +80,6 @@ #define bci_CCALL 56 #define bci_SWIZZLE 57 #define bci_ENTER 58-#define bci_RETURN 59 #define bci_RETURN_P 60 #define bci_RETURN_N 61 #define bci_RETURN_F 62
GHC/ByteCode/Asm.hs view
@@ -395,10 +395,7 @@ PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit bci_PUSH_G [Op p]- PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto- p <- ioptr (liftM BCOPtrBCO ul_bco)- emit bci_PUSH_ALTS [Op p]- PUSH_ALTS_UNLIFTED proto pk+ PUSH_ALTS proto pk -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit (push_alts pk) [Op p]@@ -504,8 +501,7 @@ SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] JMP l -> emit bci_JMP [LabelOp l] ENTER -> emit bci_ENTER []- RETURN -> emit bci_RETURN []- RETURN_UNLIFTED rep -> emit (return_unlifted rep) []+ RETURN rep -> emit (return_non_tuple rep) [] RETURN_TUPLE -> emit bci_RETURN_T [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i]@@ -574,16 +570,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_unlifted :: ArgRep -> Word16-return_unlifted V = bci_RETURN_V-return_unlifted P = bci_RETURN_P-return_unlifted N = bci_RETURN_N-return_unlifted L = bci_RETURN_L-return_unlifted F = bci_RETURN_F-return_unlifted D = bci_RETURN_D-return_unlifted V16 = error "return_unlifted: vector"-return_unlifted V32 = error "return_unlifted: vector"-return_unlifted V64 = error "return_unlifted: vector"+return_non_tuple :: ArgRep -> Word16+return_non_tuple V = bci_RETURN_V+return_non_tuple P = bci_RETURN_P+return_non_tuple N = bci_RETURN_N+return_non_tuple L = bci_RETURN_L+return_non_tuple F = bci_RETURN_F+return_non_tuple D = bci_RETURN_D+return_non_tuple V16 = error "return_non_tuple: vector"+return_non_tuple V32 = error "return_non_tuple: vector"+return_non_tuple V64 = error "return_non_tuple: vector" {- we can only handle up to a fixed number of words on the stack,
GHC/ByteCode/Instr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006@@ -87,8 +88,7 @@ | PUSH_BCO (ProtoBCO Name) -- Push an alt continuation- | PUSH_ALTS (ProtoBCO Name)- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+ | PUSH_ALTS (ProtoBCO Name) ArgRep | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation !NativeCallInfo (ProtoBCO Name) -- tuple return BCO@@ -196,9 +196,10 @@ -- To Infinity And Beyond | ENTER- | RETURN -- return a lifted value- | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep- | RETURN_TUPLE -- return an unboxed tuple (info already on stack)+ | RETURN ArgRep -- return a non-tuple value, here's its rep; see+ -- Note [Return convention for non-tuple values] in GHC.StgToByteCode+ | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see+ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre)@@ -273,8 +274,7 @@ <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)- ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)+ ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco) ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) = hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info) 2@@ -351,10 +351,12 @@ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER"- ppr RETURN = text "RETURN"- ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk+ ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE"- ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"+ ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"+ where mb_uniq = sdocOption sdocSuppressUniques $ \case+ True -> text "<uniq>"+ False -> ppr uniq @@ -385,10 +387,8 @@ bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 bciStackUse PUSH_BCO{} = 1-bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} ++bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + 3 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +- 4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) = -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) -- tuple@@ -448,8 +448,7 @@ bciStackUse CASEFAIL{} = 0 bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0-bciStackUse RETURN{} = 0-bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall
GHC/Cmm/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where@@ -385,7 +385,7 @@ , (0,alex_action_20) ] -{-# LINE 133 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 133 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot
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@@ -773,12 +772,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@@ -963,19 +962,6 @@ where 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@@ -1017,6 +1003,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'@.
GHC/Core.hs view
@@ -1301,16 +1301,19 @@ df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, } -- in positional order - | CoreUnfolding { -- An unfolding for an Id with no pragma,- -- or perhaps a NOINLINE pragma- -- (For NOINLINE, the phase, if any, is in the- -- InlinePragInfo for this Id.)- uf_tmpl :: CoreExpr, -- Template; occurrence info is correct- uf_src :: UnfoldingSource, -- Where the unfolding came from- uf_is_top :: Bool, -- True <=> top level binding- uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr- -- See Note [Tying the 'CoreUnfolding' knot]- uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.+ | CoreUnfolding { -- An unfolding for an Id with no pragma,+ -- or perhaps a NOINLINE pragma+ -- (For NOINLINE, the phase, if any, is in the+ -- InlinePragInfo for this Id.)+ uf_tmpl :: CoreExpr, -- The unfolding itself (aka "template")+ -- Always occ-analysed;+ -- See Note [OccInfo in unfoldings and rules]++ uf_src :: UnfoldingSource, -- Where the unfolding came from+ uf_is_top :: Bool, -- True <=> top level binding+ uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr+ -- See Note [Tying the 'CoreUnfolding' knot]+ uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. } -- ^ An unfolding with redundant cached information. Parameters: --@@ -1638,14 +1641,37 @@ Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In unfoldings and rules, we guarantee that the template is occ-analysed,-so that the occurrence info on the binders is correct. This is important,-because the Simplifier does not re-analyse the template when using it. If-the occurrence info is wrong- - We may get more simplifier iterations than necessary, because- once-occ info isn't there- - More seriously, we may get an infinite loop if there's a Rec- without a loop breaker marked+In unfoldings and rules, we guarantee that the template is occ-analysed, so+that the occurrence info on the binders is correct. That way, when the+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.+(The Simplifier is designed to simplify occ-analysed expressions.)++Given this decision it's vital that we do *always* do it.++* If we don't, we may get more simplifier iterations than necessary,+ because once-occ info isn't there++* More seriously, we may get an infinite loop if there's a Rec without a+ loop breaker marked.++* Or we may get code that mentions variables not in scope: #22761+ e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3+ Then the pre-simplifier occ-anal will occ-anal the unfolding+ (redundantly perhaps, but we need its free vars); this will not report+ the use of `p`; so p's binding will be discarded, and yet `p` is still+ mentioned.++ Better to occ-anal the unfolding at birth, which will drop the+ z-binding as dead code. (Remember, it's the occurrence analyser that+ drops dead code.)++* Another example is #8892:+ \x -> letrec { f = ...g...; g* = f } in body+ where g* is (for some strange reason) the loop breaker. If we don't+ occ-anal it when reading it in, we won't mark g as a loop breaker, and we+ may inline g entirely in body, dropping its binding, and leaving the+ occurrence in f out of scope. This happened in #8892, where the unfolding+ in question was a DFun unfolding. ************************************************************************
GHC/Core/Coercion.hs view
@@ -1355,7 +1355,7 @@ -- | Converts a coercion to be nominal, if possible. -- See Note [Role twiddling functions] setNominalRole_maybe :: Role -- of input coercion- -> Coercion -> Maybe Coercion+ -> Coercion -> Maybe CoercionN setNominalRole_maybe r co | r == Nominal = Just co | otherwise = setNominalRole_maybe_helper co@@ -1380,10 +1380,19 @@ = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 setNominalRole_maybe_helper (ForAllCo tv kind_co co) = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co- setNominalRole_maybe_helper (SelCo n co)+ setNominalRole_maybe_helper (SelCo cs co) = -- NB, this case recurses via setNominalRole_maybe, not -- setNominalRole_maybe_helper!- = SelCo n <$> setNominalRole_maybe (coercionRole co) co+ case cs of+ SelTyCon n _r ->+ -- Remember to update the role in SelTyCon to nominal;+ -- not doing this caused #23362.+ -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.+ SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co+ SelFun fs ->+ SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co+ SelForAll ->+ pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co) setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg setNominalRole_maybe_helper (UnivCo prov _ co1 co2)
GHC/Core/Opt/Arity.hs view
@@ -3085,8 +3085,15 @@ | need_args < 0 = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) | otherwise- = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args- , ru_rhs = new_rhs }+ = rule { ru_bndrs = bndrs ++ new_bndrs+ , ru_args = args ++ new_args+ , ru_rhs = new_rhs }+ -- new_rhs really ought to be occ-analysed (see GHC.Core Note+ -- [OccInfo in unfoldings and rules]), but it makes a module loop to+ -- do so; it doesn't happen often; and it doesn't really matter if+ -- the outer binders have bogus occurrence info; and new_rhs won't+ -- have dead code if rhs didn't.+ where need_args = join_arity - length args (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs
GHC/Core/Opt/OccurAnal.hs view
@@ -2046,6 +2046,17 @@ empty. This just saves a bit of allocation and reconstruction; not a big deal. +This fast path exposes a tricky cornder, though (#22761). Supose we have+ Unfolding = \x. let y = foo in x+1+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+the unfolding and produce /no/ occurrences of `foo` (since `y` is+dead). But if we discard the occ-analysed syntax tree (which we do on+our fast path), and use the old one, we still /have/ an occurrence of+`foo` -- and that can lead to out-of-scope variables (#22761).++Solution: always keep occ-analysed trees in unfoldings and rules, so they+have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.+ Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an rhsCtxt for the RHS of a binding. This tells the
GHC/Core/Opt/Simplify/Env.hs view
@@ -1065,7 +1065,7 @@ -- See Note [Bangs in the Simplifier] !id1 = uniqAway in_scope old_id !id2 = substIdType env id1- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding -- and fragile OccInfo !new_id = adjust_type id3
GHC/Core/Opt/Simplify/Iteration.hs view
@@ -318,14 +318,14 @@ -> TopLevelFlag -> RecFlag -> InId -> OutId -- Binder, both pre-and post simpl -- Not a JoinId- -- The OutId has IdInfo, except arity, unfolding+ -- The OutId has IdInfo (notably RULES),+ -- except arity, unfolding -- Ids only, no TyVars -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM (SimplFloats, SimplEnv) -- Precondition: the OutId is already in the InScopeSet of the incoming 'env' -- Precondition: not a JoinId -- Precondition: rhs obeys the let-can-float invariant--- NOT used for JoinIds simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se = assert (isId bndr ) assertPpr (not (isJoinId bndr)) (ppr bndr) $@@ -397,48 +397,45 @@ ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } ---------------------------simplNonRecX :: SimplEnv+simplAuxBind :: SimplEnv -> InId -- Old binder; not a JoinId -> OutExpr -- Simplified RHS -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon. It uses case-binding where necessary.+-- A specialised variant of completeBindX used to construct non-recursive+-- auxiliary bindings, notably in knownCon. --+-- The binder comes from a case expression (case binder or alternative)+-- and so does not have rules, inline pragmas etc.+-- -- Precondition: rhs satisfies the let-can-float invariant -simplNonRecX env bndr new_rhs- | assertPpr (not (isJoinId bndr)) (ppr bndr) $+simplAuxBind env bndr new_rhs+ | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } = return (emptyFloats env, env) -- Here c is dead, and we avoid- -- creating the binding c = (a,b)-- | Coercion co <- new_rhs- = return (emptyFloats env, extendCvSubst env bndr co)+ -- creating the binding c = (a,b) + -- The cases would be inlined unconditionally by completeBind:+ -- but it seems not uncommon, and avoids faff to do it here+ -- This is safe because it's only used for auxiliary bindings, which+ -- have no NOLINE pragmas, nor RULEs | exprIsTrivial new_rhs -- Short-cut for let x = y in ...- -- This case would ultimately land in postInlineUnconditionally- -- but it seems not uncommon, and avoids a lot of faff to do it here- = return (emptyFloats env- , extendIdSubst env bndr (DoneEx new_rhs Nothing))+ = return ( emptyFloats env+ , case new_rhs of+ Coercion co -> extendCvSubst env bndr co+ _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) ) | otherwise- = do { (env1, new_bndr) <- simplBinder env bndr- ; let is_strict = isStrictId new_bndr- -- isStrictId: use new_bndr because the InId bndr might not have- -- a fixed runtime representation, which isStrictId doesn't expect- -- c.f. Note [Dark corner with representation polymorphism]-- ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict- new_bndr (emptyFloats env) new_rhs- -- NB: it makes a surprisingly big difference (5% in compiler allocation- -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',- -- because this is simplNonRecX, so bndr is not in scope in the RHS.+ = do { -- ANF-ise the RHS+ let !occ_fs = getOccFS bndr+ ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs+ ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)+ ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats - ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)- (BC_Let NotTopLevel NonRecursive)+ -- Simplify the binder and complete the binding+ ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr+ ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive) bndr new_bndr rhs1- -- Must pass env1 to completeBind in case simplBinder had to clone,- -- and extended the substitution with [bndr :-> new_bndr] ; return (rhs_floats `addFloats` bind_float, env2) } @@ -760,49 +757,54 @@ -- x = Just a -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0- = do { (_is_exp, floats, rhs1) <- go 0 rhs0- ; return (floats, rhs1) }+ | is_expandable = anfise rhs0+ | otherwise = return (emptyLetFloats, rhs0) where- go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)- go n_val_args (Cast rhs co)- = do { (is_exp, floats, rhs') <- go n_val_args rhs- ; return (is_exp, floats, Cast rhs' co) }- go n_val_args (App fun (Type ty))- = do { (is_exp, floats, rhs') <- go n_val_args fun- ; return (is_exp, floats, App rhs' (Type ty)) }- go n_val_args (App fun arg)- = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun- ; if is_exp- then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg- ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }- else return (False, emptyLetFloats, App fun arg)- }- go n_val_args (Var fun)- = return (is_exp, emptyLetFloats, Var fun)- where- is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP- -- See Note [CONLIKE pragma] in GHC.Types.Basic- -- The definition of is_exp should match that in- -- 'GHC.Core.Opt.OccurAnal.occAnalApp'+ -- We can' use exprIsExpandable because the WHOLE POINT is that+ -- we want to treat (K <big>) as expandable, because we are just+ -- about "anfise" the <big> expression. exprIsExpandable would+ -- just say no!+ is_expandable = go rhs0 0+ where+ go (Var fun) n_val_args = isExpandableApp fun n_val_args+ go (App fun arg) n_val_args+ | isTypeArg arg = go fun n_val_args+ | otherwise = go fun (n_val_args + 1)+ go (Cast rhs _) n_val_args = go rhs n_val_args+ go (Tick _ rhs) n_val_args = go rhs n_val_args+ go _ _ = False - go n_val_args (Tick t rhs)+ anfise :: OutExpr -> SimplM (LetFloats, OutExpr)+ anfise (Cast rhs co)+ = do { (floats, rhs') <- anfise rhs+ ; return (floats, Cast rhs' co) }+ anfise (App fun (Type ty))+ = do { (floats, rhs') <- anfise fun+ ; return (floats, App rhs' (Type ty)) }+ anfise (App fun arg)+ = do { (floats1, fun') <- anfise fun+ ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+ ; return (floats1 `addLetFlts` floats2, App fun' arg') }+ anfise (Var fun)+ = return (emptyLetFloats, Var fun)++ anfise (Tick t rhs) -- We want to be able to float bindings past this -- tick. Non-scoping ticks don't care. | tickishScoped t == NoScope- = do { (is_exp, floats, rhs') <- go n_val_args rhs- ; return (is_exp, floats, Tick t rhs') }+ = do { (floats, rhs') <- anfise rhs+ ; return (floats, Tick t rhs') } -- On the other hand, for scoping ticks we need to be able to -- copy them on the floats, which in turn is only allowed if -- we can obtain non-counting ticks. | (not (tickishCounts t) || tickishCanSplit t)- = do { (is_exp, floats, rhs') <- go n_val_args rhs+ = do { (floats, rhs') <- anfise rhs ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) floats' = mapLetFloats floats tickIt- ; return (is_exp, floats', Tick t rhs') }+ ; return (floats', Tick t rhs') } - go _ other- = return (False, emptyLetFloats, other)+ anfise other = return (emptyLetFloats, other) makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })@@ -1243,7 +1245,7 @@ | otherwise = {-#SCC "simplNonRecE" #-}- simplNonRecE env False bndr (rhs, env) body cont+ simplNonRecE env FromLet bndr (rhs, env) body cont {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1504,8 +1506,9 @@ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } -> rebuildCall env (addValArgTo fun expr fun_ty ) cont - StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }- -> completeBindX (se `setInScopeFromE` env) b expr body cont+ StrictBind { sc_bndr = b, sc_body = body, sc_env = se+ , sc_cont = cont, sc_from = from_what }+ -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont ApplyToTy { sc_arg_ty = ty, sc_cont = cont} -> rebuild env (App expr (Type ty)) cont@@ -1517,26 +1520,49 @@ ; rebuild env (App expr arg') cont } completeBindX :: SimplEnv+ -> FromWhat -> InId -> OutExpr -- Bind this Id to this (simplified) expression -- (the let-can-float invariant may not be satisfied)- -> InExpr -- In this lambda+ -> InExpr -- In this body -> SimplCont -- Consumed by this continuation -> SimplM (SimplFloats, OutExpr)-completeBindX env bndr rhs body cont- | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant- = do { (env1, bndr1) <- simplNonRecBndr env bndr- ; (floats, expr') <- simplLam env1 body cont+completeBindX env from_what bndr rhs body cont+ | FromBeta arg_ty <- from_what+ , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant+ = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules+ ; (floats, expr') <- simplNonRecBody env1 from_what body cont -- Do not float floats past the Case binder below ; let expr'' = wrapFloats floats expr'- ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+ case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] ; return (emptyFloats env, case_expr) } - | otherwise- = do { (floats1, env') <- simplNonRecX env bndr rhs- ; (floats2, expr') <- simplLam env' body cont- ; return (floats1 `addFloats` floats2, expr') }+ | otherwise -- Make a let-binding+ = do { (env1, bndr1) <- simplNonRecBndr env bndr+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; let is_strict = isStrictId bndr2+ -- isStrictId: use simplified binder because the InId bndr might not have+ -- a fixed runtime representation, which isStrictId doesn't expect+ -- c.f. Note [Dark corner with representation polymorphism] + ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+ bndr2 (emptyFloats env) rhs+ -- NB: it makes a surprisingly big difference (5% in compiler allocation+ -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',+ -- because this is simplNonRecX, so bndr is not in scope in the RHS.++ ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)+ (BC_Let NotTopLevel NonRecursive)+ bndr bndr2 rhs1+ -- Must pass env1 to completeBind in case simplBinder had to clone,+ -- and extended the substitution with [bndr :-> new_bndr]++ -- Simplify the body+ ; (body_floats, body') <- simplNonRecBody env2 from_what body cont++ ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats+ ; return ( all_floats, body' ) }+ {- ************************************************************************ * *@@ -1673,6 +1699,14 @@ ************************************************************************ -} +simplNonRecBody :: SimplEnv -> FromWhat+ -> InExpr -> SimplCont+ -> SimplM (SimplFloats, OutExpr)+simplNonRecBody env from_what body cont+ = case from_what of+ FromLet -> simplExprF env body cont+ FromBeta {} -> simplLam env body cont+ simplLam :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -1689,16 +1723,25 @@ -- Value beta-reduction simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_cont = cont, sc_dup = dup })- | isSimplified dup -- Don't re-simplify if we've simplified it once- -- See Note [Avoiding exponential behaviour]+ , sc_cont = cont, sc_dup = dup+ , sc_hole_ty = fun_ty}) = do { tick (BetaReduction bndr)- ; completeBindX env bndr arg body cont }+ ; let arg_ty = funArgTy fun_ty+ ; if | isSimplified dup -- Don't re-simplify if we've simplified it once+ -- Including don't preInlineUnconditionally+ -- See Note [Avoiding exponential behaviour]+ -> completeBindX env (FromBeta arg_ty) bndr arg body cont - | otherwise -- See Note [Avoiding exponential behaviour]- = do { tick (BetaReduction bndr)- ; simplNonRecE env True bndr (arg, arg_se) body cont }+ | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se+ , not (needsCaseBinding arg_ty arg)+ -- Ok to test arg::InExpr in needsCaseBinding because+ -- exprOkForSpeculation is stable under simplification+ -> do { tick (PreInlineUnconditionally bndr)+ ; simplLam env' body cont } + | otherwise+ -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }+ -- Discard a non-counting tick on a lambda. This may change the -- cost attribution slightly (moving the allocation of the -- lambda elsewhere), but we don't care: optimisation changes@@ -1729,8 +1772,7 @@ ------------------ simplNonRecE :: SimplEnv- -> Bool -- True <=> from a lambda- -- False <=> from a let+ -> FromWhat -> InId -- The binder, always an Id -- Never a join point -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)@@ -1739,57 +1781,49 @@ -> SimplM (SimplFloats, OutExpr) -- simplNonRecE is used for--- * non-top-level non-recursive non-join-point lets in expressions--- * beta reduction+-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression+-- * from=FromBeta: a binding arising from a beta reduction ----- simplNonRec env b (rhs, rhs_se) body k+-- simplNonRecE env b (rhs, rhs_se) body k -- = let env in -- cont< let b = rhs_se(rhs) in body > -- -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process. ----- from_lam=False => the RHS satisfies the let-can-float invariant+-- from_what=FromLet => the RHS satisfies the let-can-float invariant -- Otherwise it may or may not satisfy it. -simplNonRecE env from_lam bndr (rhs, rhs_se) body cont- = assert (isId bndr && not (isJoinId bndr) ) $- do { (env1, bndr1) <- simplNonRecBndr env bndr- ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs- -- See Note [Dark corner with representation polymorphism]- -- If from_lam=False then needs_case_binding is False,- -- because the binding started as a let, which must- -- satisfy let-can-float+simplNonRecE env from_what bndr (rhs, rhs_se) body cont+ | assert (isId bndr && not (isJoinId bndr) ) $+ is_strict_bind+ = -- Evaluate RHS strictly+ simplExprF (rhs_se `setInScopeFromE` env) rhs+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+ , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - ; if | from_lam && not needs_case_binding- -- If not from_lam we are coming from a (NonRec bndr rhs) binding- -- and preInlineUnconditionally has been done already;- -- no need to repeat it. But for lambdas we must be careful about- -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk")- -- We must not drop the (error "urk").- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se- -> do { tick (PreInlineUnconditionally bndr)- ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $- simplLam env' body cont }+ | otherwise -- Evaluate RHS lazily+ = do { (env1, bndr1) <- simplNonRecBndr env bndr+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+ ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive+ bndr bndr2 rhs rhs_se+ ; (floats2, expr') <- simplNonRecBody env3 from_what body cont+ ; return (floats1 `addFloats` floats2, expr') } - -- Deal with strict bindings- | isStrictId bndr1 && seCaseCase env- || from_lam && needs_case_binding- -- The important bit here is needs_case_binds; but no need to- -- test it if from_lam is False because then needs_case_binding is False too- -- NB: either way, the RHS may or may not satisfy let-can-float- -- but that's ok for StrictBind.- -> simplExprF (rhs_se `setInScopeFromE` env) rhs- (StrictBind { sc_bndr = bndr, sc_body = body- , sc_env = env, sc_cont = cont, sc_dup = NoDup })+ where+ is_strict_bind = case from_what of+ FromBeta arg_ty | isUnliftedType arg_ty -> True+ -- If we are coming from a beta-reduction (FromBeta) we must+ -- establish the let-can-float invariant, so go via StrictBind+ -- If not, the invariant holds already, and it's optional.+ -- Using arg_ty: see Note [Dark corner with representation polymorphism]+ -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+ -- When we come to `x=arg` we myst choose lazy/strict correctly+ -- It's wrong to err in either directly - -- Deal with lazy bindings- | otherwise- -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)- ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se- ; (floats2, expr') <- simplLam env3 body cont- ; return (floats1 `addFloats` floats2, expr') } }+ _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr) + ------------------ simplRecE :: SimplEnv -> [(InId, InExpr)]@@ -1834,7 +1868,7 @@ One way in which we can get exponential behaviour is if we simplify a big expression, and then re-simplify it -- and then this happens in a deeply-nested way. So we must be jolly careful about re-simplifying-an expression. That is why simplNonRecX does not try+an expression (#13379). That is why simplNonRecX does not try preInlineUnconditionally (unlike simplNonRecE). Example:@@ -2617,15 +2651,10 @@ of the rule firing to simplify it, so occurrence analysis is at most a constant factor. -Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.-+Note, however, that the rule RHS is /already/ occ-analysed; see+Note [OccInfo in unfoldings and rules] in GHC.Core. There is something+unsatisfactory about doing it twice; but the rule RHS is usually very+small, and this is simple. Note [Optimising tagToEnum#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2929,7 +2958,7 @@ where simple_rhs env wfloats case_bndr_rhs bs rhs = assert (null bs) $- do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs+ do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs -- scrut is a constructor application, -- hence satisfies let-can-float invariant ; (floats2, expr') <- simplExprF env' rhs cont@@ -2996,7 +3025,7 @@ | all_dead_bndrs , doCaseToLet scrut case_bndr = do { tick (CaseElim case_bndr)- ; (floats1, env') <- simplNonRecX env case_bndr scrut+ ; (floats1, env') <- simplAuxBind env case_bndr scrut ; (floats2, expr') <- simplExprF env' rhs cont ; return (floats1 `addFloats` floats2, expr') } @@ -3484,12 +3513,11 @@ bind_args env' (b:bs') (arg : args) = assert (isId b) $ do { let b' = zap_occ b- -- Note that the binder might be "dead", because it doesn't- -- occur in the RHS; and simplNonRecX may therefore discard- -- it via postInlineUnconditionally.+ -- zap_occ: the binder might be "dead", because it doesn't+ -- occur in the RHS; and simplAuxBind may therefore discard it. -- Nevertheless we must keep it if the case-binder is alive, -- because it may be used in the con_app. See Note [knownCon occ info]- ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant+ ; (floats1, env2) <- simplAuxBind env' b' arg -- arg satisfies let-can-float invariant ; (floats2, env3) <- bind_args env2 bs' args ; return (floats1 `addFloats` floats2, env3) } @@ -3515,7 +3543,7 @@ ; let con_app = Var (dataConWorkId dc) `mkTyApps` dc_ty_args `mkApps` dc_args- ; simplNonRecX env bndr con_app }+ ; simplAuxBind env bndr con_app } ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont@@ -3622,15 +3650,15 @@ ; return (floats, TickIt t cont') } mkDupableContWithDmds env _- (StrictBind { sc_bndr = bndr, sc_body = body+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what , sc_env = se, sc_cont = cont}) -- See Note [Duplicating StrictBind] -- K[ let x = <> in b ] --> join j x = K[ b ] -- j <> = do { let sb_env = se `setInScopeFromE` env ; (sb_env1, bndr') <- simplBinder sb_env bndr- ; (floats1, join_inner) <- simplLam sb_env1 body cont- -- No need to use mkDupableCont before simplLam; we+ ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont+ -- No need to use mkDupableCont before simplNonRecBody; we -- use cont once here, and then share the result if necessary ; let join_body = wrapFloats floats1 join_inner@@ -3758,6 +3786,7 @@ , StrictBind { sc_bndr = arg_bndr , sc_body = join_rhs , sc_env = zapSubstEnv env+ , sc_from = FromLet -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup , sc_cont = mkBoringStop res_ty } )@@ -4431,7 +4460,9 @@ ; return (rule { ru_bndrs = bndrs' , ru_fn = fn_name' , ru_args = args'- , ru_rhs = rhs' }) }+ , ru_rhs = occurAnalyseExpr rhs' }) }+ -- Remember to occ-analyse, to drop dead code.+ -- See Note [OccInfo in unfoldings and rules] in GHC.Core {- Note [Simplifying the RHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/Simplify/Utils.hs view
@@ -21,7 +21,7 @@ BindContext(..), bindContextLevel, -- The continuation type- SimplCont(..), DupFlag(..), StaticEnv,+ SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs,@@ -191,6 +191,7 @@ -- or, equivalently, = K[ (\x.b) e ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] , sc_bndr :: InId+ , sc_from :: FromWhat , sc_body :: InExpr , sc_env :: StaticEnv -- See Note [StaticEnv invariant] , sc_cont :: SimplCont }@@ -212,6 +213,8 @@ type StaticEnv = SimplEnv -- Just the static part is relevant +data FromWhat = FromLet | FromBeta OutType+ -- See Note [DupFlag invariants] data DupFlag = NoDup -- Unsimplified, might be big | Simplified -- Simplified@@ -549,7 +552,7 @@ countValArgs :: SimplCont -> Int -- Count value arguments only-countValArgs (ApplyToTy { sc_cont = cont }) = 1 + countValArgs cont+countValArgs (ApplyToTy { sc_cont = cont }) = countValArgs cont countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont countValArgs (CastIt _ cont) = countValArgs cont countValArgs _ = 0
GHC/Core/Opt/Specialise.hs view
@@ -48,10 +48,11 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )+import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Error import GHC.Utils.Error ( mkMCDiagnostic )@@ -59,6 +60,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain( assert ) import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts@@ -1748,12 +1750,44 @@ | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs- spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn- = Just (orig_join_arity - join_arity_decr)- | otherwise- = Nothing - ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity+ --------------------------------------+ -- Add a suitable unfolding; see Note [Inline specialisations]+ -- The wrap_unf_body applies the original unfolding to the specialised+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)+ simpl_opts = initSimpleOpts dflags+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body+ rule_lhs_args fn_unf++ --------------------------------------+ -- Adding arity information just propagates it a bit faster+ -- See Note [Arity decrease] in GHC.Core.Opt.Simplify+ -- Copy InlinePragma information from the parent Id.+ -- So if f has INLINE[1] so does spec_fn+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs++ spec_inl_prag+ | not is_local -- See Note [Specialising imported functions]+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal+ = neverInlinePragma+ | otherwise+ = inl_prag++ spec_fn_info+ = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)+ `setInlinePragInfo` spec_inl_prag+ `setUnfoldingInfo` spec_unf++ -- Compute the IdDetails of the specialise Id+ -- See Note [Transfer IdDetails during specialisation]+ spec_fn_details+ = case idDetails fn of+ JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing+ DFunId is_nt -> DFunId is_nt+ _ -> VanillaId++ ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'.@@ -1768,33 +1802,7 @@ herald fn rule_bndrs rule_lhs_args (mkVarApps (Var spec_fn) spec_bndrs) - simpl_opts = initSimpleOpts dflags-- --------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations]- -- The wrap_unf_body applies the original unfolding to the specialised- -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds- spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body- rule_lhs_args fn_unf-- spec_inl_prag- | not is_local -- See Note [Specialising imported functions]- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal- = neverInlinePragma- | otherwise- = inl_prag-- --------------------------------------- -- Adding arity information just propagates it a bit faster- -- See Note [Arity decrease] in GHC.Core.Opt.Simplify- -- Copy InlinePragma information from the parent Id.- -- So if f has INLINE[1] so does spec_fn- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs- spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)- `setInlinePragma` spec_inl_prag- `setIdUnfolding` spec_unf- `asJoinId_maybe` spec_join_arity+ spec_f_w_arity = spec_fn _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty@@ -1824,7 +1832,7 @@ {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-DFuns have a special sort of unfolding (DFunUnfolding), and these are+DFuns have a special sort of unfolding (DFunUnfolding), and it is hard to specialise a DFunUnfolding to give another DFunUnfolding unless the DFun is fully applied (#18120). So, in the case of DFunIds we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,@@ -1833,6 +1841,36 @@ There is an ASSERT that checks this, in the DFunUnfolding case of GHC.Core.Unfold.Make.specUnfolding. +Note [Transfer IdDetails during specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, `newSpecIdSM` comes up with a fresh Id the+specialised RHS will be bound to. It is critical that we get the `IdDetails` of+the specialised Id correct:++* JoinId: We want the specialised Id to be a join point, too. But+ we have to carefully adjust the arity++* DFunId: It is crucial that we also make the new Id a DFunId.+ - First, because it obviously /is/ a DFun, having a DFunUnfolding and+ all that; see Note [Specialising DFuns]++ - Second, DFuns get very delicate special treatment in the demand analyser;+ see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't+ also a DFunId, this special treatment doesn't happen, so the demand+ analyser makes a too-strict DFun, and we get an infinite loop. See Note+ [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.+ #22549 describes the loop, and (lower down) a case where a /specialised/+ DFun caused a loop.++* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come+ up when specialising imports. We must keep them as VanillaIds because WW+ will detect them as WorkerLikeIds again. That is, unless specialisation+ allows unboxing of all previous CBV args, in which case sticking to+ VanillaIds was the only correct choice to begin with.++* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:+ Never specialised.+ Note [Specialisation Must Preserve Sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function:@@ -3439,15 +3477,14 @@ env' = env { se_subst = subst `Core.extendSubstInScope` b' } ; pure (env', b') } -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id -- Give the new Id a similar occurrence name to the old one-newSpecIdSM old_id new_ty join_arity_maybe+newSpecIdSM old_name new_ty details info = do { uniq <- getUniqueM- ; let name = idName old_id- new_occ = mkSpecOcc (nameOccName name)- new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)- `asJoinId_maybe` join_arity_maybe- ; return new_id }+ ; let new_occ = mkSpecOcc (nameOccName old_name)+ new_name = mkInternalName uniq new_occ (getSrcSpan old_name)+ ; return (assert (not (isCoVarType new_ty)) $+ mkLocalVar details new_name ManyTy new_ty info) } {- Old (but interesting) stuff about unboxed bindings
GHC/Core/Rules.hs view
@@ -62,6 +62,7 @@ import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind )@@ -187,13 +188,18 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs- = Rule { ru_name = name, ru_fn = fn, ru_act = act,- ru_bndrs = bndrs, ru_args = args,- ru_rhs = rhs,- ru_rough = roughTopNames args,- ru_origin = this_mod,- ru_orphan = orph,- ru_auto = is_auto, ru_local = is_local }+ = Rule { ru_name = name+ , ru_act = act+ , ru_fn = fn+ , ru_bndrs = bndrs+ , ru_args = args+ , ru_rhs = occurAnalyseExpr rhs+ -- See Note [OccInfo in unfoldings and rules]+ , ru_rough = roughTopNames args+ , ru_origin = this_mod+ , ru_orphan = orph+ , ru_auto = is_auto+ , ru_local = is_local } where -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables
GHC/Core/Type.hs view
@@ -1481,7 +1481,7 @@ -- c.f. #15473 pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) -applyTysX :: [TyVar] -> Type -> [Type] -> Type+applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type -- applyTysX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys
GHC/Core/Unify.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} {-# LANGUAGE DeriveFunctor #-} @@ -47,6 +47,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Exts( oneShot )+import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -994,6 +995,59 @@ (legitimately) have different numbers of arguments. They are surelyApart, so we can report that without looking any further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+ type family F a :: Type -> Type+ type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+ Since F is injective, we can reduce this to Int ~ Char,+ therefore SurelyApart.++* F Int ~ F Char, where F is not injective+ Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+ Even though G is injective and the arguments to G are different,+ we cannot deduce apartness because the RHS is oversaturated.+ For example, G might be defined as+ G Type = Maybe Int+ G (Type -> Type) = Maybe+ So we return MaybeApart.++* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char)+ F Int Bool ~ Maybe a -- MaybeApart+ F Int Bool ~ a b -- MaybeApart+ F Int Bool ~ Char -> Bool -- MaybeApart+ An oversaturated type family can match an application,+ whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+ We cannot decompose a saturated, or under-saturated+ type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+ A saturated application.+ Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+ A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+ An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+ If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families. -} -------------- unify_ty: the main workhorse -----------@@ -1035,32 +1089,64 @@ = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco- | Just (tc1, tys1) <- mb_tc_app1- , Just (tc2, tys2) <- mb_tc_app2++ -- Handle non-oversaturated type families first+ -- See Note [Unifying type applications]+ --+ -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T+ -- Note that both sides must not be oversaturated+ | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1+ , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2 , tc1 == tc2- = if isInjectiveTyCon tc1 Nominal- then unify_tys env tys1 tys2- else do { let inj | isTypeFamilyTyCon tc1- = case tyConInjectivityInfo tc1 of- NotInjective -> repeat False- Injective bs -> bs- | otherwise- = repeat False+ = do { let inj = case tyConInjectivityInfo tc1 of+ NotInjective -> repeat False+ Injective bs -> bs - (inj_tys1, noninj_tys1) = partitionByList inj tys1- (inj_tys2, noninj_tys2) = partitionByList inj tys2+ (inj_tys1, noninj_tys1) = partitionByList inj tys1+ (inj_tys2, noninj_tys2) = partitionByList inj tys2 - ; unify_tys env inj_tys1 inj_tys2- ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]- don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }+ ; unify_tys env inj_tys1 inj_tys2+ ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]+ don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } - | isTyFamApp mb_tc_app1 -- A (not-over-saturated) type-family application- = maybeApart MARTypeFamily -- behaves like a type variable; might match+ | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application+ = maybeApart MARTypeFamily -- behaves like a type variable; might match - | isTyFamApp mb_tc_app2 -- A (not-over-saturated) type-family application- , um_unif env -- behaves like a type variable; might unify- = maybeApart MARTypeFamily+ | Just _ <- isSatTyFamApp mb_tc_app2 -- (C2) A (not-over-saturated) type-family application+ -- behaves like a type variable; might unify+ -- but doesn't match (as in the TyVarTy case)+ = if um_unif env then maybeApart MARTypeFamily else surelyApart + -- Handle oversaturated type families.+ --+ -- They can match an application (TyConApp/FunTy/AppTy), this is handled+ -- the same way as in the AppTy case below.+ --+ -- If there is no application, an oversaturated type family can only+ -- match a type variable or a saturated type family,+ -- both of which we handled earlier. So we can say surelyApart.+ | Just (tc1, _) <- mb_tc_app1+ , isTypeFamilyTyCon tc1+ = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+ , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+ -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3)+ | otherwise -> surelyApart -- (C4)++ | Just (tc2, _) <- mb_tc_app2+ , isTypeFamilyTyCon tc2+ = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+ , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+ -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3)+ | otherwise -> surelyApart -- (C4)++ -- At this point, neither tc1 nor tc2 can be a type family.+ | Just (tc1, tys1) <- mb_tc_app1+ , Just (tc2, tys2) <- mb_tc_app2+ , tc1 == tc2+ = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+ ; unify_tys env tys1 tys2+ }+ -- TYPE and CONSTRAINT are not Apart -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim -- NB: at this point we know that the two TyCons do not match@@ -1160,16 +1246,16 @@ -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] -isTyFamApp :: Maybe (TyCon, [Type]) -> Bool--- True if we have a saturated or under-saturated type family application+isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application -- If it is /over/ saturated then we return False. E.g. -- unify_ty (F a b) (c d) where F has arity 1 -- we definitely want to decompose that type application! (#22647)-isTyFamApp (Just (tc, tys))- = not (isGenerativeTyCon tc Nominal) -- Type family-ish+isSatTyFamApp tapp@(Just (tc, tys))+ | isTypeFamilyTyCon tc && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated-isTyFamApp Nothing- = False+ = tapp+isSatTyFamApp _ = Nothing --------------------------------- uVar :: UMEnv
GHC/Core/Utils.hs view
@@ -515,8 +515,8 @@ -- | Tests whether we have to use a @case@ rather than @let@ binding for this -- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs =- mightBeUnliftedType ty && not (exprOkForSpeculation rhs)+needsCaseBinding ty rhs+ = mightBeUnliftedType ty && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y)
GHC/HsToCore/Foreign/JavaScript.hs view
@@ -639,7 +639,7 @@ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do -- result_id <- newSysLocalDs boolTy ccall_uniq <- newUnique- let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy+ let forceBool e = mkJsCall ccall_uniq "((x) => { return !(!x); })" [e] boolTy return (Just intPrimTy, \e -> forceBool e)
GHC/Parser/HaddockLex.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString
GHC/Parser/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -592,7 +592,7 @@ , (0,alex_action_86) ] -{-# LINE 704 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 704 "_build/source-dist/ghc-9.6.2-src/ghc-9.6.2/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b
GHC/Platform.hs view
@@ -207,6 +207,7 @@ osElfTarget OSAIX = False osElfTarget OSHurd = True osElfTarget OSWasi = False+osElfTarget OSGhcjs = False osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for
GHC/StgToByteCode.hs view
@@ -319,7 +319,7 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO")- emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])+ emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise@@ -480,14 +480,13 @@ non_void VoidRep = False non_void _ = True ret <- case filter non_void reps of- -- use RETURN_UBX for unary representations- [] -> return (unitOL $ RETURN_UNLIFTED V)- [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))+ -- use RETURN for nullary/unary representations+ [] -> return (unitOL $ RETURN V)+ [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) -- otherwise use RETURN_TUPLE with a tuple descriptor nv_reps -> do let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps- args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)+ tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE@@ -527,7 +526,7 @@ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])- | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)+ | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -682,8 +681,8 @@ schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) = generatePrimCall d s p label (Just unit) result_ty args - -- Case 2: Unboxed tuple schemeT d s p (StgConApp con _cn args _tys)+ -- Case 2: Unboxed tuple | isUnboxedTupleDataCon con || isUnboxedSumDataCon con = returnUnboxedTuple d s p args @@ -692,7 +691,7 @@ = do alloc_con <- mkConAppCode d s p con args platform <- profilePlatform <$> getProfile return (alloc_con `appOL`- mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)+ mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -832,14 +831,11 @@ -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. + non_void_arg_reps = non_void (typeArgReps platform bndr_ty) ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 - ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)-- non_void_arg_reps = non_void (typeArgReps platform bndr_ty)- profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp@@ -848,7 +844,8 @@ -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is- -- on top of the itbl.+ -- on top of the itbl; see Note [Return convention for non-tuple values]+ -- for details. ret_frame_size_b :: StackDepth ret_frame_size_b | ubx_tuple_frame = (if profiling then 5 else 4) * wordSize platform@@ -862,7 +859,6 @@ -- The size of the return frame info table pointer if one exists unlifted_itbl_size_b :: StackDepth unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform- | ubx_frame = wordSize platform | otherwise = 0 (bndr_size, call_info, args_offsets)@@ -1050,24 +1046,14 @@ p scrut alt_bco' <- emitBc alt_bco if ubx_tuple_frame- then do- let args_ptrs =- map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))- args_offsets- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)- return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco- `consOL` scrut_code)- else let push_alts- | not ubx_frame- = PUSH_ALTS alt_bco'- | otherwise- = let unlifted_rep =- case non_void_arg_reps of- [] -> V- [rep] -> rep- _ -> panic "schemeE(StgCase).push_alts"- in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep- in return (push_alts `consOL` scrut_code)+ then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)+ return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco+ `consOL` scrut_code)+ else let scrut_rep = case non_void_arg_reps of+ [] -> V+ [rep] -> rep+ _ -> panic "schemeE(StgCase).push_alts"+ in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code) -- -----------------------------------------------------------------------------@@ -1138,21 +1124,38 @@ (orig_stk_params ++ map get_byte_off new_stk_params) ) -{-- We use the plain return convention (ENTER/PUSH_ALTS) for- lifted types and unlifted algebraic types.+{- Note [Return convention for non-tuple values]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RETURN and ENTER instructions are used to return values. RETURN directly+returns the value at the top of the stack while ENTER evaluates it first (so+RETURN is only used when the result is already known to be evaluated), but the+end result is the same: control returns to the enclosing stack frame with the+result at the top of the stack. - Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect- additional data on the stack.- -}-usePlainReturn :: Type -> Bool-usePlainReturn t- | isUnboxedTupleType t || isUnboxedSumType t = False- | otherwise = typePrimRep t == [LiftedRep] ||- (typePrimRep t == [UnliftedRep] && isAlgType t)+The PUSH_ALTS instruction pushes a two-word stack frame that receives a single+lifted value. Its payload is a BCO that is executed when control returns, with+the stack set up as if a RETURN instruction had just been executed: the returned+value is at the top of the stack, and beneath it is the two-word frame being+returned to. It is the continuation BCO’s job to pop its own frame off the+stack, so the simplest possible continuation consists of two instructions: -{- Note [unboxed tuple bytecodes and tuple_BCO]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value+ RETURN P -- return the returned value to our caller++RETURN and PUSH_ALTS are not really instructions but are in fact representation-+polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a+single real instruction, since it is only used to return lifted values, which+are always pointers.++The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned+value has nullary or unary representation. Returning/receiving an unboxed+tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to+unboxed tuples by Unarise) containing two or more results uses the special+RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return+convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.++Note [unboxed tuple bytecodes and tuple_BCO]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to return and receive arbitrary unboxed tuples, respectively. These instructions use the helper data tuple_BCO and call_info.@@ -1247,11 +1250,10 @@ -} -tupleBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name-tupleBCO platform info pointers =+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+tupleBCO platform args_info args = mkProtoBCO platform invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-}- where {- The tuple BCO is never referred to by name, so we can get away@@ -1263,18 +1265,16 @@ -- the first word in the frame is the call_info word, -- which is not a pointer- bitmap_size = trunc16W $ 1 + nativeCallSize info- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $- map ((+1) . fromIntegral . bytesToWords platform . snd)- (filter fst pointers)+ nptrs_prefix = 1+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args+ body_code = mkSlideW 0 1 -- pop frame header `snocOL` RETURN_TUPLE -- and add it again -primCallBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name-primCallBCO platform args_info pointers =+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+primCallBCO platform args_info args = mkProtoBCO platform invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-}- where {- The primcall BCO is never referred to by name, so we can get away@@ -1284,20 +1284,52 @@ -} invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") - -- the first three words in the frame are the BCO describing the- -- pointers in the frame, the call_info word and the pointer- -- to the Cmm function being called. None of these is a pointer that- -- should be followed by the garbage collector- bitmap_size = trunc16W $ 2 + nativeCallSize args_info- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $- map ((+2) . fromIntegral . bytesToWords platform . snd)- (filter fst pointers)+ -- The first two words in the frame (after the BCO) are the call_info word+ -- and the pointer to the Cmm function being called. Neither of these is a+ -- pointer that should be followed by the garbage collector.+ nptrs_prefix = 2+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args+ -- if the primcall BCO is ever run it's a bug, since the BCO should only -- be pushed immediately before running the PRIMCALL bytecode instruction, -- which immediately leaves the interpreter to jump to the stg_primcall_info -- Cmm function body_code = unitOL CASEFAIL +-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by+-- some number of arguments.+mkStackBitmap+ :: Platform+ -> WordOff+ -- ^ The number of nonpointer words that prefix the arguments.+ -> NativeCallInfo+ -> [(PrimRep, ByteOff)]+ -- ^ The stack layout of the arguments, where each offset is relative to the+ -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned,+ -- and the list must be sorted in order of ascending offset (i.e. bottom to top).+ -> (Word16, [StgWord])+mkStackBitmap platform nptrs_prefix args_info args+ = (bitmap_size, bitmap)+ where+ bitmap_size = trunc16W $ nptrs_prefix + arg_bottom+ bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets++ arg_bottom = nativeCallSize args_info+ ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset)+ $ mapMaybe get_ptr_offset args++ get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff+ get_ptr_offset (rep, byte_offset)+ | isFollowableArg (toArgRep platform rep) = Just byte_offset+ | otherwise = Nothing++ convert_arg_offset :: ByteOff -> WordOff+ convert_arg_offset arg_offset =+ -- The argument offsets are relative to `arg_bottom`, but+ -- `intsToReverseBitmap` expects offsets from the top, so we need to flip+ -- them around.+ nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset)+ -- ----------------------------------------------------------------------------- -- Deal with a primitive call to native code. @@ -1325,15 +1357,12 @@ (args_info, args_offsets) = layoutNativeCall profile NativePrimCall- d+ 0 (primRepCmmType platform . argPrimRep) nv_args - args_ptrs :: [(Bool, ByteOff)]- args_ptrs =- map (\(r, off) ->- (isFollowableArg (toArgRep platform . argPrimRep $ r), off))- args_offsets+ prim_args_offsets = mapFst argPrimRep args_offsets+ shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1@@ -1350,8 +1379,8 @@ go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a massert (off == dd + szb) go (dd + szb) (push:pushes) cs- push_args <- go d [] args_offsets- args_bco <- emitBc (primCallBCO platform args_info args_ptrs)+ push_args <- go d [] shifted_args_offsets+ args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets) return $ mconcat push_args `appOL` (push_target `consOL` push_info `consOL`@@ -1562,7 +1591,7 @@ -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)- `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)+ `snocOL` RETURN (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL`@@ -1676,7 +1705,6 @@ The code we generate is this: push arg- push bogus-word TESTEQ_I 0 L1 PUSH_G <lbl for first data con>@@ -1694,13 +1722,6 @@ L_exit: SLIDE 1 n ENTER--The 'bogus-word' push is because TESTEQ_I expects the top of the stack-to have an info-table, and the next word to have the value to be-tested. This is very weird, but it's the way it is right now. See-Interpreter.c. We don't actually need an info-table here; we just-need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See #8383. -} @@ -1726,14 +1747,10 @@ slide_ws = bytesToWords platform (d - s + arg_bytes) return (push_arg- `appOL` unitOL (PUSH_UBX LitNullAddr 1)- -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, LABEL label_exit ]- `appOL` mkSlideW 1 (slide_ws + 1)- -- "+1" to account for bogus word- -- (see Note [Implementing tagToEnum#])+ `appOL` mkSlideW 1 slide_ws `appOL` unitOL ENTER) where mkStep l_exit (my_label, next_label, n, name_for_n)
GHC/StgToCmm/Closure.hs view
@@ -308,8 +308,7 @@ -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the--- tagging strategy. See Note [Data constructor dynamic tags] in--- rts/Interpreter.c+-- tagging strategy; see tagConstr in rts/Interpreter.c. isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
GHC/StgToJS/Linker/Utils.hs view
@@ -115,8 +115,8 @@ -- GHCJS.Prim.JSVal , if profiling- then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"- else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"+ then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"+ else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n" , "#define JSVAL_VAL(x) ((x).d1)\n" -- GHCJS.Prim.JSException
GHC/StgToJS/Prim.hs view
@@ -921,7 +921,7 @@ IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]- ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads"+ ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
GHC/Tc/Deriv/Generate.hs view
@@ -45,6 +45,7 @@ import GHC.Prelude import GHC.Tc.Utils.Monad+import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs import GHC.Types.FieldLabel import GHC.Types.Name.Reader@@ -2097,8 +2098,8 @@ newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc- rep_lhs_tys = substTyVars lhs_subst fam_tvs- rep_rhs_tys = substTyVars rhs_subst fam_tvs+ (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs+ (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
GHC/Tc/TyCl.hs view
@@ -4542,30 +4542,39 @@ -- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig checkNewDataCon con = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags-- ; checkTc (isSingleton arg_tys) $- TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)-- ; checkTc (ok_mult (scaledMult arg_ty1)) $- TcRnIllegalNewtype con show_linear_types IsNonLinear+ ; checkNoErrs $+ -- Fail here if the newtype is invalid: subsequent code in+ -- checkValidDataCon can fall over if it comes across an invalid newtype.+ do { case arg_tys of+ [Scaled arg_mult _] ->+ unless (ok_mult arg_mult) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types IsNonLinear+ _ ->+ addErrTc $+ TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) - ; checkTc (null eq_spec) $- TcRnIllegalNewtype con show_linear_types IsGADT+ -- Add an error if the newtype is a GADt or has existentials.+ --+ -- If the newtype is a GADT, the GADT error is enough;+ -- we don't need to *also* complain about existentials.+ ; if not (null eq_spec)+ then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT+ else unless (null ex_tvs) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types HasExistentialTyVar - ; checkTc (null theta) $+ ; unless (null theta) $+ addErrTc $ TcRnIllegalNewtype con show_linear_types HasConstructorContext - ; checkTc (null ex_tvs) $- TcRnIllegalNewtype con show_linear_types HasExistentialTyVar-- ; checkTc (all ok_bang (dataConSrcBangs con)) $- TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation- }+ ; unless (all ok_bang (dataConSrcBangs con)) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } } where+ (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con-- (arg_ty1 : _) = arg_tys ok_bang (HsSrcBang _ _ SrcStrict) = False ok_bang (HsSrcBang _ _ SrcLazy) = False
GHC/Tc/TyCl/Build.hs view
@@ -18,7 +18,7 @@ import GHC.Prelude import GHC.Iface.Env-import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy )+import GHC.Builtin.Types import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad@@ -65,11 +65,12 @@ tvs = tyConTyVars tycon roles = tyConRoles tycon res_kind = tyConResKind tycon- con_arg_ty = case dataConRepArgTys con of- [arg_ty] -> scaledThing arg_ty- tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)- rhs_ty = substTyWith (dataConUnivTyVars con)- (mkTyVarTys tvs) con_arg_ty+ rhs_ty+ -- Only try if the newtype is actually valid (see "otherwise" below).+ | [Scaled _ arg_ty] <- dataConRepArgTys con+ , null $ dataConExTyCoVars con+ = substTyWith (dataConUnivTyVars con)+ (mkTyVarTys tvs) arg_ty -- Instantiate the newtype's RHS with the -- type variables from the tycon -- NB: a newtype DataCon has a type that must look like@@ -78,6 +79,13 @@ -- the newtype arising from class Foo a => Bar a where {} -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns [].+ | otherwise+ -- If the newtype is invalid (e.g. doesn't have a single argument),+ -- we fake up a type here. The newtype will get rejected once we're+ -- outside the knot-tied loop, in GHC.Tc.TyCl.checkNewDataCon.+ -- See the various test cases in T23308.+ = unitTy -- Might be ill-kinded, but checkNewDataCon should reject this+ -- whole declaration soon enough, before that causes any problems. -- Eta-reduce the newtype -- See Note [Newtype eta] in GHC.Core.TyCon
GHC/Tc/TyCl/Class.hs view
@@ -22,6 +22,7 @@ , instDeclCtxt2 , instDeclCtxt3 , tcATDefault+ , substATBndrs ) where @@ -37,7 +38,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType-import GHC.Core.Type ( piResultTys )+import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin@@ -55,7 +56,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var-import GHC.Types.Var.Env+import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -497,8 +498,7 @@ -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs- = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst- (tyConTyVars fam_tc)+ = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv'@@ -521,14 +521,73 @@ | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] }++-- | Apply a substitution to the type variable binders of an associated type+-- family. This is used to compute default instances for associated type+-- families (see 'tcATDefault') as well as @newtype@-derived associated type+-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate").+--+-- As a concrete example, consider the following class and associated type+-- family:+--+-- @+-- class C k (a :: k) where+-- type F k a (b :: k) :: Type+-- type F j p q = (Proxy @j p, Proxy @j (q :: j))+-- @+--+-- If a user defines this instance:+--+-- @+-- instance C (Type -> Type) Maybe where {}+-- @+--+-- Then in order to typecheck the default @F@ instance, we must apply the+-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which+-- are @[k, a, (b :: k)]@. The result should look like this:+--+-- @+-- type F (Type -> Type) Maybe (b :: Type -> Type) =+-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type))+-- @+--+-- Making this work requires some care. There are two cases:+--+-- 1. If we encounter a type variable in the domain of the substitution (e.g.,+-- @k@ or @a@), then we apply the substitution directly.+--+-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn+-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution+-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@).+--+-- This step is important to do in case there are later occurrences of @b@,+-- which we must ensure have the correct kind. Otherwise, we might end up+-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the+-- default instance, which would be completely wrong.+--+-- Contrast 'substATBndrs' function with similar substitution functions:+--+-- * 'substTyVars' does not substitute into the kinds of each type variable,+-- nor does it extend the substitution. 'substTyVars' is meant for occurrences+-- of type variables, whereas 'substATBndr's is meant for binders.+--+-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution,+-- but it does not apply the substitution to the variables themselves. As+-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of+-- 'Type's.+substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])+substATBndrs = mapAccumL substATBndr where- subst_tv subst tc_tv+ substATBndr :: Subst -> TyVar -> (Subst, Type)+ substATBndr subst tc_tv+ -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty)+ -- Case (2) in the Haddocks | otherwise- = (extendTvSubst subst tc_tv ty', ty')+ = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') where- ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)+ tc_tv' = updateTyVarKind (substTy subst) tc_tv warnMissingAT :: Name -> TcM () warnMissingAT name
GHC/Tc/Utils/TcType.hs view
@@ -2387,22 +2387,32 @@ -} +-- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'?+--+-- See Note [Paterson conditions] in GHC.Tc.Validity. data PatersonSizeFailure- = PSF_TyFam TyCon -- Type family- | PSF_Size -- Too many type constructors/variables- | PSF_TyVar [TyVar] -- These type variables appear more often than in instance head;- -- no duplicates in this list+ -- | Either side contains a type family.+ = PSF_TyFam TyCon+ -- | The size of the LHS is not strictly less than the size of the RHS.+ | PSF_Size+ -- | These type variables appear more often in the LHS than in the RHS.+ | PSF_TyVar [TyVar] -- ^ no duplicates in this list -------------------------------------- -data PatersonSize -- See Note [Paterson conditions] in GHC.Tc.Validity- = PS_TyFam TyCon -- Mentions a type family; infinite size+-- | The Paterson size of a given type, in the sense of+-- Note [Paterson conditions] in GHC.Tc.Validity+--+-- - after expanding synonyms,+-- - ignoring coercions (as they are not user written).+data PatersonSize+ -- | The type mentions a type family, so the size could be anything.+ = PS_TyFam TyCon - | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions;- , ps_size :: Int -- Number of type constructors and variables+ -- | The type does not mention a type family.+ | PS_Vanilla { ps_tvs :: [TyVar] -- ^ free tyvars, including repetitions;+ , ps_size :: Int -- ^ number of type constructors and variables }- -- Always after expanding synonyms- -- Always ignore coercions (not user written) -- ToDo: ignore invisible arguments? See Note [Invisible arguments and termination] instance Outputable PatersonSize where@@ -2415,21 +2425,26 @@ pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 } pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 } -ltPatersonSize :: PatersonSize -- Size of constraint- -> PatersonSize -- Size of instance head; never PS_TyFam+-- | @ltPatersonSize ps1 ps2@ returns:+--+-- - @Nothing@ iff @ps1@ is definitely strictly smaller than @ps2@,+-- - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong.+ltPatersonSize :: PatersonSize+ -> PatersonSize -> Maybe PatersonSizeFailure--- (ps1 `ltPatersonSize` ps2) returns--- Nothing iff ps1 is strictly smaller than p2--- Just ps_fail says what went wrong-ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc) ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) | s1 >= s2 = Just PSF_Size | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs) | otherwise = Nothing -- OK!-ltPatersonSize (PS_Vanilla {}) (PS_TyFam tc)- = pprPanic "ltPSize" (ppr tc)- -- Impossible because we never have a type family in an instance head+ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc)+ltPatersonSize _ (PS_TyFam tc) = Just (PSF_TyFam tc)+ -- NB: this last equation is never taken when checking instances, because+ -- type families are disallowed in instance heads.+ --+ -- However, this function is also used in the logic for solving superclass+ -- constraints (see Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance),+ -- in which case we might well hit this case (see e.g. T23171). noMoreTyVars :: [TyVar] -- Free vars (with repetitions) of the constraint C -> [TyVar] -- Free vars (with repetitions) of the head H
GHC/Types/Id.hs view
@@ -723,12 +723,14 @@ zapIdDmdSig :: Id -> Id zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id --- | This predicate says whether the 'Id' has a strict demand placed on it or--- has a type such that it can always be evaluated strictly (i.e an--- unlifted type, as of GHC 7.6). We need to--- check separately whether the 'Id' has a so-called \"strict type\" because if--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict--- type, we still want @isStrictId id@ to be @True@.+-- | `isStrictId` says whether either+-- (a) the 'Id' has a strict demand placed on it or+-- (b) definitely has a \"strict type\", such that it can always be+-- evaluated strictly (i.e an unlifted type)+-- We need to check (b) as well as (a), because when the demand for the+-- given `id` hasn't been computed yet but `id` has a strict+-- type, we still want `isStrictId id` to be `True`.+-- Returns False if the type is levity polymorphic; False is always safe. isStrictId :: Id -> Bool isStrictId id | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $
GHC/Types/Id/Make.hs view
@@ -1048,8 +1048,7 @@ arg_ty' = case mb_co of { Just redn -> scaledSet arg_ty (reductionReducedType redn) ; Nothing -> arg_ty }- , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')- , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'+ , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty' = if bang_opt_unbox_disable bang_opts then HsStrict True -- Not unpacking because of -O0 -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon@@ -1324,69 +1323,95 @@ mkUbxSumAltTy [ty] = ty mkUbxSumAltTy tys = mkTupleTy Unboxed tys -shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool+shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool -- True if we ought to unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves!-shouldUnpackTy bang_opts prag fam_envs ty- | Just data_cons <- unpackable_type_datacons (scaledThing ty)- = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons+shouldUnpackArgTy bang_opts prag fam_envs arg_ty+ | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)+ , all ok_con data_cons -- Returns True only if we can't get a+ -- loop involving these data cons+ , should_unpack prag arg_ty data_cons -- ...hence the call to dataConArgUnpack in+ -- should_unpack won't loop+ -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff+ = True+ | otherwise = False where- ok_con_args :: NameSet -> DataCon -> Bool- ok_con_args dcs con- | dc_name `elemNameSet` dcs- = False- | otherwise- = all (ok_arg dcs')- (dataConOrigArgTys con `zip` dataConSrcBangs con)- -- NB: dataConSrcBangs gives the *user* request;- -- We'd get a black hole if we used dataConImplBangs+ ok_con :: DataCon -> Bool -- True <=> OK to unpack+ ok_con top_con -- False <=> not safe+ = ok_args emptyNameSet top_con where- dc_name = getName con- dcs' = dcs `extendNameSet` dc_name+ top_con_name = getName top_con - ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool- ok_arg dcs (Scaled _ ty, bang)- = not (attempt_unpack bang) || ok_ty dcs norm_ty- where- norm_ty = topNormaliseType fam_envs ty+ ok_args dcs con+ = all (ok_arg dcs) $+ (dataConOrigArgTys con `zip` dataConSrcBangs con)+ -- NB: dataConSrcBangs gives the *user* request;+ -- We'd get a black hole if we used dataConImplBangs - ok_ty :: NameSet -> Type -> Bool- ok_ty dcs ty- | Just data_cons <- unpackable_type_datacons ty- = all (ok_con_args dcs) data_cons- | otherwise- = True -- NB True here, in contrast to False at top level+ ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool+ ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)+ | strict_field str_prag+ , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)+ , should_unpack_conservative unpack_prag data_cons -- Wrinkle (W3)+ = all (ok_rec_con dcs) data_cons -- of Note [Recursive unboxing]+ | otherwise+ = True -- NB True here, in contrast to False at top level - attempt_unpack :: HsSrcBang -> Bool- attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)- = bang_opt_strict_data bang_opts- attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)- = True- attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)- = True -- Be conservative- attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)- = bang_opt_strict_data bang_opts -- Be conservative- attempt_unpack _ = False+ -- See Note [Recursive unboxing]+ -- * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)+ -- * For the "at the root" comments see Wrinkle (W2)+ ok_rec_con dcs con+ | dc_name == top_con_name = False -- Recursion at the root+ | dc_name `elemNameSet` dcs = True -- Not at the root+ | otherwise = ok_args (dcs `extendNameSet` dc_name) con+ where+ dc_name = getName con - -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not.- should_unpack data_cons =+ strict_field :: SrcStrictness -> Bool+ -- True <=> strict field+ strict_field NoSrcStrict = bang_opt_strict_data bang_opts+ strict_field SrcStrict = True+ strict_field SrcLazy = False++ -- Determine whether we ought to unpack a field,+ -- based on user annotations if present.+ -- A conservative version of should_unpack that doesn't look at how+ -- many fields the field would unpack to... because that leads to a loop.+ -- "Conservative" = err on the side of saying "yes".+ should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool+ should_unpack_conservative SrcNoUnpack _ = False -- {-# NOUNPACK #-}+ should_unpack_conservative SrcUnpack _ = True -- {-# NOUNPACK #-}+ should_unpack_conservative NoSrcUnpack dcs = not (is_sum dcs)+ -- is_sum: we never unpack sums without a pragma; otherwise be conservative++ -- Determine whether we ought to unpack a field,+ -- based on user annotations if present, and heuristics if not.+ should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool+ should_unpack prag arg_ty data_cons = case prag of SrcNoUnpack -> False -- {-# NOUNPACK #-} SrcUnpack -> True -- {-# UNPACK #-} NoSrcUnpack -- No explicit unpack pragma, so use heuristics- | (_:_:_) <- data_cons- -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK.- | otherwise+ | is_sum data_cons+ -> False -- Don't unpack sum types automatically, but they can+ -- be unpacked with an explicit source UNPACK.+ | otherwise -- Wrinkle (W4) of Note [Recursive unboxing] -> bang_opt_unbox_strict bang_opts || (bang_opt_unbox_small bang_opts && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]- where (rep_tys, _) = dataConArgUnpack ty+ where+ (rep_tys, _) = dataConArgUnpack arg_ty + is_sum :: [DataCon] -> Bool+ -- We never unpack sum types automatically+ -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)+ is_sum (_:_:_) = True+ is_sum _ = False -- Given a type already assumed to have been normalized by topNormaliseType, -- unpackable_type_datacons ty = Just datacons@@ -1398,11 +1423,11 @@ unpackable_type_datacons :: Type -> Maybe [DataCon] unpackable_type_datacons ty | Just (tc, _) <- splitTyConApp_maybe ty- , not (isNewTyCon tc)- -- Even though `ty` has been normalised, it could still- -- be a /recursive/ newtype, so we must check for that+ , not (isNewTyCon tc) -- Even though `ty` has been normalised, it could still+ -- be a /recursive/ newtype, so we must check for that , Just cons <- tyConDataCons_maybe tc- , not (null cons)+ , not (null cons) -- Don't upack nullary sums; no need.+ -- They already take zero bits , all (null . dataConExTyCoVars) cons = Just cons -- See Note [Unpacking GADTs and existentials] | otherwise@@ -1458,20 +1483,74 @@ data T = MkT {-# UNPACK #-} !T Int Because then we'd get an infinite number of arguments. -Here is a more complicated case:- data S = MkS {-# UNPACK #-} !T Int- data T = MkT {-# UNPACK #-} !S Int-Each of S and T must decide independently whether to unpack-and they had better not both say yes. So they must both say no.--Also behave conservatively when there is no UNPACK pragma- data T = MkS !T Int-with -funbox-strict-fields or -funbox-small-strict-fields-we need to behave as if there was an UNPACK pragma there.--But it's the *argument* type that matters. This is fine:+Note that it's the *argument* type that matters. This is fine: data S = MkS S !Int because Int is non-recursive.++Wrinkles:++(W1a) We have to be careful that the compiler doesn't go into a loop!+ First, we must not look at the HsImplBang decisions of data constructors+ in the same mutually recursive group. E.g.+ data S = MkS {-# UNPACK #-} !T Int+ data T = MkT {-# UNPACK #-} !S Int+ Each of S and T must decide /independently/ whether to unpack+ and they had better not both say yes. So they must both say no.+ (We could detect when we leave the group, and /then/ we can rely on+ HsImplBangs; but that requires more plumbing.)++(W1b) Here is another way the compiler might go into a loop (test T23307b):+ data data T = MkT !S Int+ data S = MkS !T+ Suppose we call `shouldUnpackArgTy` on the !S arg of `T`. In `should_unpack`+ we ask if the number of fields that `MkS` unpacks to is small enough+ (via rep_tys `lengthAtMost` 1). But how many field /does/ `MkS` unpack+ to? Well it depends on the unpacking decision we make for `MkS`, which+ in turn depends on `MkT`, which we are busy deciding. Black holes beckon.++ So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;+ see `should_unpack_conservative`), and only /then/ call `should_unpack`.+ Tricky!++(W2) As #23307 shows, we /do/ want to unpack the second arg of the Yes+ data constructor in this example, despite the recursion in List:+ data Stream a = Cons a !(Stream a)+ data Unconsed a = Unconsed a !(Stream a)+ data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)+ When looking at+ {-# UNPACK #-} (Unconsed a)+ we can take Unconsed apart, but then get into a loop with Stream.+ That's fine: we can still take Unconsed apart. It's only if we+ have a loop /at the root/ that we must not unpack.++(W3) Moreover (W2) can apply even if there is a recursive loop:+ data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)+ data Unconsed a = Unconsed a !(List a)+ Here there is mutual recursion between `Unconsed` and `List`; and yet+ we can unpack the field of `Cons` because we will not unpack the second+ field of `Unconsed`: we never unpack a sum type without an explicit+ pragma (see should_unpack).++(W4) Consider+ data T = MkT !Wombat+ data Wombat = MkW {-# UNPACK #-} !S Int+ data S = MkS {-# NOUNPACK #-} !Wombat Int+ Suppose we are deciding whether to unpack the first field of MkT, by+ calling (shouldUnpackArgTy Wombat). Then we'll try to unpack the !S field+ of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can+ unpack MkT.++ If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would+ decide not to unpack the Wombat field of MkT.++ But what if there was no pragma in `data S`? Then we /still/ decide not+ to unpack the Wombat field of MkT (at least when auto-unpacking is on),+ because we don't know for sure which decision will be taken for the+ Wombat field of MkS.++ TL;DR when there is no pragma, behave as if there was a UNPACK, at least+ when auto-unpacking is on. See `should_unpack` in `shouldUnpackArgTy`.+ ************************************************************************ * *
ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc-Version: 9.6.1+Version: 9.6.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -86,9 +86,9 @@ transformers >= 0.5 && < 0.7, exceptions == 0.10.*, stm,- ghc-boot == 9.6.1,- ghc-heap == 9.6.1,- ghci == 9.6.1+ ghc-boot == 9.6.2,+ ghc-heap == 9.6.2,+ ghci == 9.6.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14