diff --git a/compiler/Bytecodes.h b/compiler/Bytecodes.h --- a/compiler/Bytecodes.h +++ b/compiler/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/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/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/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/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/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/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/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs --- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs +++ b/compiler/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/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/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/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/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/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs --- a/compiler/GHC/StgToJS/Linker/Utils.hs +++ b/compiler/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/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs --- a/compiler/GHC/StgToJS/Prim.hs +++ b/compiler/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/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/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/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/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/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/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/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/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-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib -version: 9.6.1.20230312 +version: 9.6.2.20230523 license: BSD3 license-file: LICENSE category: Development @@ -90,7 +90,7 @@ stm, rts, hpc == 0.6.*, - ghc-lib-parser == 9.6.1.20230312 + ghc-lib-parser == 9.6.2.20230523 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24 -#define OFFSET_Capability_lock 1216 +#define OFFSET_Capability_lock 1224 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists] -#define OFFSET_Capability_context_switch 1184 +#define OFFSET_Capability_context_switch 1192 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch] -#define OFFSET_Capability_interrupt 1188 +#define OFFSET_Capability_interrupt 1196 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt] -#define OFFSET_Capability_sparks 1320 +#define OFFSET_Capability_sparks 1328 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks] -#define OFFSET_Capability_total_allocated 1192 +#define OFFSET_Capability_total_allocated 1200 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated] -#define OFFSET_Capability_weak_ptr_list_hd 1168 +#define OFFSET_Capability_weak_ptr_list_hd 1176 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd] -#define OFFSET_Capability_weak_ptr_list_tl 1176 +#define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0