diff --git a/Bytecodes.h b/Bytecodes.h --- a/Bytecodes.h +++ b/Bytecodes.h @@ -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 diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs --- a/GHC/ByteCode/Asm.hs +++ b/GHC/ByteCode/Asm.hs @@ -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, diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs --- a/GHC/ByteCode/Instr.hs +++ b/GHC/ByteCode/Instr.hs @@ -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 "" + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "" + where mb_uniq = sdocOption sdocSuppressUniques $ \case + True -> text "" + 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 diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.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 diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr @@ -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'@. diff --git a/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -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. ************************************************************************ diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs --- a/GHC/Core/Coercion.hs +++ b/GHC/Core/Coercion.hs @@ -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) diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -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 diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -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 diff --git a/GHC/Core/Opt/Simplify/Env.hs b/GHC/Core/Opt/Simplify/Env.hs --- a/GHC/Core/Opt/Simplify/Env.hs +++ b/GHC/Core/Opt/Simplify/Env.hs @@ -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 diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs --- a/GHC/Core/Opt/Simplify/Iteration.hs +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -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 ) as expandable, because we are just + -- about "anfise" the 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -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 diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -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 diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs --- a/GHC/Core/Rules.hs +++ b/GHC/Core/Rules.hs @@ -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 diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -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 diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} {-# LANGUAGE DeriveFunctor #-} @@ -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 diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -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) diff --git a/GHC/HsToCore/Foreign/JavaScript.hs b/GHC/HsToCore/Foreign/JavaScript.hs --- a/GHC/HsToCore/Foreign/JavaScript.hs +++ b/GHC/HsToCore/Foreign/JavaScript.hs @@ -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) diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.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 diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.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 diff --git a/GHC/Platform.hs b/GHC/Platform.hs --- a/GHC/Platform.hs +++ b/GHC/Platform.hs @@ -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 diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -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 @@ -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) diff --git a/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs --- a/GHC/StgToCmm/Closure.hs +++ b/GHC/StgToCmm/Closure.hs @@ -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 diff --git a/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs --- a/GHC/StgToJS/Linker/Utils.hs +++ b/GHC/StgToJS/Linker/Utils.hs @@ -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 diff --git a/GHC/StgToJS/Prim.hs b/GHC/StgToJS/Prim.hs --- a/GHC/StgToJS/Prim.hs +++ b/GHC/StgToJS/Prim.hs @@ -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 diff --git a/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs --- a/GHC/Tc/Deriv/Generate.hs +++ b/GHC/Tc/Deriv/Generate.hs @@ -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 diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/GHC/Tc/TyCl.hs @@ -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 diff --git a/GHC/Tc/TyCl/Build.hs b/GHC/Tc/TyCl/Build.hs --- a/GHC/Tc/TyCl/Build.hs +++ b/GHC/Tc/TyCl/Build.hs @@ -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 diff --git a/GHC/Tc/TyCl/Class.hs b/GHC/Tc/TyCl/Class.hs --- a/GHC/Tc/TyCl/Class.hs +++ b/GHC/Tc/TyCl/Class.hs @@ -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 diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs --- a/GHC/Tc/Utils/TcType.hs +++ b/GHC/Tc/Utils/TcType.hs @@ -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 diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs --- a/GHC/Types/Id.hs +++ b/GHC/Types/Id.hs @@ -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) $ diff --git a/GHC/Types/Id/Make.hs b/GHC/Types/Id/Make.hs --- a/GHC/Types/Id/Make.hs +++ b/GHC/Types/Id/Make.hs @@ -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`. + ************************************************************************ * * diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.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