ghc-lib 9.6.1.20230312 → 9.6.2.20230523
raw patch · 16 files changed
+365/−223 lines, 16 filesdep ~ghc-lib-parserPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- GHC.ByteCode.Instr: PUSH_ALTS_UNLIFTED :: ProtoBCO Name -> ArgRep -> BCInstr
- GHC.ByteCode.Instr: RETURN_UNLIFTED :: ArgRep -> BCInstr
+ GHC.Tc.TyCl.Class: substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])
- GHC.ByteCode.Instr: PUSH_ALTS :: ProtoBCO Name -> BCInstr
+ GHC.ByteCode.Instr: PUSH_ALTS :: ProtoBCO Name -> ArgRep -> BCInstr
- GHC.ByteCode.Instr: RETURN :: BCInstr
+ GHC.ByteCode.Instr: RETURN :: ArgRep -> BCInstr
- GHC.Plugins: applyTysX :: [TyVar] -> Type -> [Type] -> Type
+ GHC.Plugins: applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
- GHC.Plugins: setNominalRole_maybe :: Role -> Coercion -> Maybe Coercion
+ GHC.Plugins: setNominalRole_maybe :: Role -> Coercion -> Maybe CoercionN
Files
- compiler/Bytecodes.h +0/−2
- compiler/GHC/ByteCode/Asm.hs +12/−16
- compiler/GHC/ByteCode/Instr.hs +14/−15
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +35/−16
- compiler/GHC/Core/Opt/Specialise.hs +78/−41
- compiler/GHC/HsToCore/Foreign/JavaScript.hs +1/−1
- compiler/GHC/StgToByteCode.hs +103/−86
- compiler/GHC/StgToCmm/Closure.hs +1/−2
- compiler/GHC/StgToJS/Linker/Utils.hs +2/−2
- compiler/GHC/StgToJS/Prim.hs +1/−1
- compiler/GHC/Tc/Deriv/Generate.hs +3/−2
- compiler/GHC/Tc/TyCl.hs +26/−17
- compiler/GHC/Tc/TyCl/Build.hs +14/−6
- compiler/GHC/Tc/TyCl/Class.hs +66/−7
- ghc-lib.cabal +2/−2
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +7/−7
compiler/Bytecodes.h view
@@ -34,7 +34,6 @@ #define bci_PUSH16_W 9 #define bci_PUSH32_W 10 #define bci_PUSH_G 11-#define bci_PUSH_ALTS 12 #define bci_PUSH_ALTS_P 13 #define bci_PUSH_ALTS_N 14 #define bci_PUSH_ALTS_F 15@@ -81,7 +80,6 @@ #define bci_CCALL 56 #define bci_SWIZZLE 57 #define bci_ENTER 58-#define bci_RETURN 59 #define bci_RETURN_P 60 #define bci_RETURN_N 61 #define bci_RETURN_F 62
compiler/GHC/ByteCode/Asm.hs view
@@ -395,10 +395,7 @@ PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit bci_PUSH_G [Op p]- PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto- p <- ioptr (liftM BCOPtrBCO ul_bco)- emit bci_PUSH_ALTS [Op p]- PUSH_ALTS_UNLIFTED proto pk+ PUSH_ALTS proto pk -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit (push_alts pk) [Op p]@@ -504,8 +501,7 @@ SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] JMP l -> emit bci_JMP [LabelOp l] ENTER -> emit bci_ENTER []- RETURN -> emit bci_RETURN []- RETURN_UNLIFTED rep -> emit (return_unlifted rep) []+ RETURN rep -> emit (return_non_tuple rep) [] RETURN_TUPLE -> emit bci_RETURN_T [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i]@@ -574,16 +570,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_unlifted :: ArgRep -> Word16-return_unlifted V = bci_RETURN_V-return_unlifted P = bci_RETURN_P-return_unlifted N = bci_RETURN_N-return_unlifted L = bci_RETURN_L-return_unlifted F = bci_RETURN_F-return_unlifted D = bci_RETURN_D-return_unlifted V16 = error "return_unlifted: vector"-return_unlifted V32 = error "return_unlifted: vector"-return_unlifted V64 = error "return_unlifted: vector"+return_non_tuple :: ArgRep -> Word16+return_non_tuple V = bci_RETURN_V+return_non_tuple P = bci_RETURN_P+return_non_tuple N = bci_RETURN_N+return_non_tuple L = bci_RETURN_L+return_non_tuple F = bci_RETURN_F+return_non_tuple D = bci_RETURN_D+return_non_tuple V16 = error "return_non_tuple: vector"+return_non_tuple V32 = error "return_non_tuple: vector"+return_non_tuple V64 = error "return_non_tuple: vector" {- we can only handle up to a fixed number of words on the stack,
compiler/GHC/ByteCode/Instr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006@@ -87,8 +88,7 @@ | PUSH_BCO (ProtoBCO Name) -- Push an alt continuation- | PUSH_ALTS (ProtoBCO Name)- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+ | PUSH_ALTS (ProtoBCO Name) ArgRep | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation !NativeCallInfo (ProtoBCO Name) -- tuple return BCO@@ -196,9 +196,10 @@ -- To Infinity And Beyond | ENTER- | RETURN -- return a lifted value- | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep- | RETURN_TUPLE -- return an unboxed tuple (info already on stack)+ | RETURN ArgRep -- return a non-tuple value, here's its rep; see+ -- Note [Return convention for non-tuple values] in GHC.StgToByteCode+ | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see+ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre)@@ -273,8 +274,7 @@ <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)- ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)+ ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco) ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) = hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info) 2@@ -351,10 +351,12 @@ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER"- ppr RETURN = text "RETURN"- ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk+ ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE"- ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"+ ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"+ where mb_uniq = sdocOption sdocSuppressUniques $ \case+ True -> text "<uniq>"+ False -> ppr uniq @@ -385,10 +387,8 @@ bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 bciStackUse PUSH_BCO{} = 1-bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} ++bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + 3 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +- 4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) = -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) -- tuple@@ -448,8 +448,7 @@ bciStackUse CASEFAIL{} = 0 bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0-bciStackUse RETURN{} = 0-bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr@@ -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'@.
compiler/GHC/Core/Opt/Specialise.hs view
@@ -48,10 +48,11 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )+import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Error import GHC.Utils.Error ( mkMCDiagnostic )@@ -59,6 +60,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain( assert ) import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts@@ -1748,12 +1750,44 @@ | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs- spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn- = Just (orig_join_arity - join_arity_decr)- | otherwise- = Nothing - ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity+ --------------------------------------+ -- Add a suitable unfolding; see Note [Inline specialisations]+ -- The wrap_unf_body applies the original unfolding to the specialised+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)+ simpl_opts = initSimpleOpts dflags+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body+ rule_lhs_args fn_unf++ --------------------------------------+ -- Adding arity information just propagates it a bit faster+ -- See Note [Arity decrease] in GHC.Core.Opt.Simplify+ -- Copy InlinePragma information from the parent Id.+ -- So if f has INLINE[1] so does spec_fn+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs++ spec_inl_prag+ | not is_local -- See Note [Specialising imported functions]+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal+ = neverInlinePragma+ | otherwise+ = inl_prag++ spec_fn_info+ = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)+ `setInlinePragInfo` spec_inl_prag+ `setUnfoldingInfo` spec_unf++ -- Compute the IdDetails of the specialise Id+ -- See Note [Transfer IdDetails during specialisation]+ spec_fn_details+ = case idDetails fn of+ JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing+ DFunId is_nt -> DFunId is_nt+ _ -> VanillaId++ ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'.@@ -1768,33 +1802,7 @@ herald fn rule_bndrs rule_lhs_args (mkVarApps (Var spec_fn) spec_bndrs) - simpl_opts = initSimpleOpts dflags-- --------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations]- -- The wrap_unf_body applies the original unfolding to the specialised- -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds- spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body- rule_lhs_args fn_unf-- spec_inl_prag- | not is_local -- See Note [Specialising imported functions]- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal- = neverInlinePragma- | otherwise- = inl_prag-- --------------------------------------- -- Adding arity information just propagates it a bit faster- -- See Note [Arity decrease] in GHC.Core.Opt.Simplify- -- Copy InlinePragma information from the parent Id.- -- So if f has INLINE[1] so does spec_fn- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs- spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)- `setInlinePragma` spec_inl_prag- `setIdUnfolding` spec_unf- `asJoinId_maybe` spec_join_arity+ spec_f_w_arity = spec_fn _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty@@ -1824,7 +1832,7 @@ {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-DFuns have a special sort of unfolding (DFunUnfolding), and these are+DFuns have a special sort of unfolding (DFunUnfolding), and it is hard to specialise a DFunUnfolding to give another DFunUnfolding unless the DFun is fully applied (#18120). So, in the case of DFunIds we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,@@ -1833,6 +1841,36 @@ There is an ASSERT that checks this, in the DFunUnfolding case of GHC.Core.Unfold.Make.specUnfolding. +Note [Transfer IdDetails during specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, `newSpecIdSM` comes up with a fresh Id the+specialised RHS will be bound to. It is critical that we get the `IdDetails` of+the specialised Id correct:++* JoinId: We want the specialised Id to be a join point, too. But+ we have to carefully adjust the arity++* DFunId: It is crucial that we also make the new Id a DFunId.+ - First, because it obviously /is/ a DFun, having a DFunUnfolding and+ all that; see Note [Specialising DFuns]++ - Second, DFuns get very delicate special treatment in the demand analyser;+ see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't+ also a DFunId, this special treatment doesn't happen, so the demand+ analyser makes a too-strict DFun, and we get an infinite loop. See Note+ [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.+ #22549 describes the loop, and (lower down) a case where a /specialised/+ DFun caused a loop.++* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come+ up when specialising imports. We must keep them as VanillaIds because WW+ will detect them as WorkerLikeIds again. That is, unless specialisation+ allows unboxing of all previous CBV args, in which case sticking to+ VanillaIds was the only correct choice to begin with.++* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:+ Never specialised.+ Note [Specialisation Must Preserve Sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function:@@ -3439,15 +3477,14 @@ env' = env { se_subst = subst `Core.extendSubstInScope` b' } ; pure (env', b') } -newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id -- Give the new Id a similar occurrence name to the old one-newSpecIdSM old_id new_ty join_arity_maybe+newSpecIdSM old_name new_ty details info = do { uniq <- getUniqueM- ; let name = idName old_id- new_occ = mkSpecOcc (nameOccName name)- new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)- `asJoinId_maybe` join_arity_maybe- ; return new_id }+ ; let new_occ = mkSpecOcc (nameOccName old_name)+ new_name = mkInternalName uniq new_occ (getSrcSpan old_name)+ ; return (assert (not (isCoVarType new_ty)) $+ mkLocalVar details new_name ManyTy new_ty info) } {- Old (but interesting) stuff about unboxed bindings
compiler/GHC/HsToCore/Foreign/JavaScript.hs view
@@ -639,7 +639,7 @@ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do -- result_id <- newSysLocalDs boolTy ccall_uniq <- newUnique- let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy+ let forceBool e = mkJsCall ccall_uniq "((x) => { return !(!x); })" [e] boolTy return (Just intPrimTy, \e -> forceBool e)
compiler/GHC/StgToByteCode.hs view
@@ -319,7 +319,7 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO")- emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])+ emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise@@ -480,14 +480,13 @@ non_void VoidRep = False non_void _ = True ret <- case filter non_void reps of- -- use RETURN_UBX for unary representations- [] -> return (unitOL $ RETURN_UNLIFTED V)- [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))+ -- use RETURN for nullary/unary representations+ [] -> return (unitOL $ RETURN V)+ [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) -- otherwise use RETURN_TUPLE with a tuple descriptor nv_reps -> do let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps- args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)+ tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE@@ -527,7 +526,7 @@ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])- | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)+ | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -682,8 +681,8 @@ schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) = generatePrimCall d s p label (Just unit) result_ty args - -- Case 2: Unboxed tuple schemeT d s p (StgConApp con _cn args _tys)+ -- Case 2: Unboxed tuple | isUnboxedTupleDataCon con || isUnboxedSumDataCon con = returnUnboxedTuple d s p args @@ -692,7 +691,7 @@ = do alloc_con <- mkConAppCode d s p con args platform <- profilePlatform <$> getProfile return (alloc_con `appOL`- mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)+ mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -832,14 +831,11 @@ -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. + non_void_arg_reps = non_void (typeArgReps platform bndr_ty) ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 - ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)-- non_void_arg_reps = non_void (typeArgReps platform bndr_ty)- profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp@@ -848,7 +844,8 @@ -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is- -- on top of the itbl.+ -- on top of the itbl; see Note [Return convention for non-tuple values]+ -- for details. ret_frame_size_b :: StackDepth ret_frame_size_b | ubx_tuple_frame = (if profiling then 5 else 4) * wordSize platform@@ -862,7 +859,6 @@ -- The size of the return frame info table pointer if one exists unlifted_itbl_size_b :: StackDepth unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform- | ubx_frame = wordSize platform | otherwise = 0 (bndr_size, call_info, args_offsets)@@ -1050,24 +1046,14 @@ p scrut alt_bco' <- emitBc alt_bco if ubx_tuple_frame- then do- let args_ptrs =- map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))- args_offsets- tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs)- return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco- `consOL` scrut_code)- else let push_alts- | not ubx_frame- = PUSH_ALTS alt_bco'- | otherwise- = let unlifted_rep =- case non_void_arg_reps of- [] -> V- [rep] -> rep- _ -> panic "schemeE(StgCase).push_alts"- in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep- in return (push_alts `consOL` scrut_code)+ then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)+ return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco+ `consOL` scrut_code)+ else let scrut_rep = case non_void_arg_reps of+ [] -> V+ [rep] -> rep+ _ -> panic "schemeE(StgCase).push_alts"+ in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code) -- -----------------------------------------------------------------------------@@ -1138,21 +1124,38 @@ (orig_stk_params ++ map get_byte_off new_stk_params) ) -{-- We use the plain return convention (ENTER/PUSH_ALTS) for- lifted types and unlifted algebraic types.+{- Note [Return convention for non-tuple values]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RETURN and ENTER instructions are used to return values. RETURN directly+returns the value at the top of the stack while ENTER evaluates it first (so+RETURN is only used when the result is already known to be evaluated), but the+end result is the same: control returns to the enclosing stack frame with the+result at the top of the stack. - Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect- additional data on the stack.- -}-usePlainReturn :: Type -> Bool-usePlainReturn t- | isUnboxedTupleType t || isUnboxedSumType t = False- | otherwise = typePrimRep t == [LiftedRep] ||- (typePrimRep t == [UnliftedRep] && isAlgType t)+The PUSH_ALTS instruction pushes a two-word stack frame that receives a single+lifted value. Its payload is a BCO that is executed when control returns, with+the stack set up as if a RETURN instruction had just been executed: the returned+value is at the top of the stack, and beneath it is the two-word frame being+returned to. It is the continuation BCO’s job to pop its own frame off the+stack, so the simplest possible continuation consists of two instructions: -{- Note [unboxed tuple bytecodes and tuple_BCO]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value+ RETURN P -- return the returned value to our caller++RETURN and PUSH_ALTS are not really instructions but are in fact representation-+polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a+single real instruction, since it is only used to return lifted values, which+are always pointers.++The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned+value has nullary or unary representation. Returning/receiving an unboxed+tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to+unboxed tuples by Unarise) containing two or more results uses the special+RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return+convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.++Note [unboxed tuple bytecodes and tuple_BCO]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to return and receive arbitrary unboxed tuples, respectively. These instructions use the helper data tuple_BCO and call_info.@@ -1247,11 +1250,10 @@ -} -tupleBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name-tupleBCO platform info pointers =+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+tupleBCO platform args_info args = mkProtoBCO platform invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-}- where {- The tuple BCO is never referred to by name, so we can get away@@ -1263,18 +1265,16 @@ -- the first word in the frame is the call_info word, -- which is not a pointer- bitmap_size = trunc16W $ 1 + nativeCallSize info- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $- map ((+1) . fromIntegral . bytesToWords platform . snd)- (filter fst pointers)+ nptrs_prefix = 1+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args+ body_code = mkSlideW 0 1 -- pop frame header `snocOL` RETURN_TUPLE -- and add it again -primCallBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name-primCallBCO platform args_info pointers =+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+primCallBCO platform args_info args = mkProtoBCO platform invented_name body_code (Left []) 0{-no arity-} bitmap_size bitmap False{-is alts-}- where {- The primcall BCO is never referred to by name, so we can get away@@ -1284,20 +1284,52 @@ -} invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") - -- the first three words in the frame are the BCO describing the- -- pointers in the frame, the call_info word and the pointer- -- to the Cmm function being called. None of these is a pointer that- -- should be followed by the garbage collector- bitmap_size = trunc16W $ 2 + nativeCallSize args_info- bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $- map ((+2) . fromIntegral . bytesToWords platform . snd)- (filter fst pointers)+ -- The first two words in the frame (after the BCO) are the call_info word+ -- and the pointer to the Cmm function being called. Neither of these is a+ -- pointer that should be followed by the garbage collector.+ nptrs_prefix = 2+ (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args+ -- if the primcall BCO is ever run it's a bug, since the BCO should only -- be pushed immediately before running the PRIMCALL bytecode instruction, -- which immediately leaves the interpreter to jump to the stg_primcall_info -- Cmm function body_code = unitOL CASEFAIL +-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by+-- some number of arguments.+mkStackBitmap+ :: Platform+ -> WordOff+ -- ^ The number of nonpointer words that prefix the arguments.+ -> NativeCallInfo+ -> [(PrimRep, ByteOff)]+ -- ^ The stack layout of the arguments, where each offset is relative to the+ -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned,+ -- and the list must be sorted in order of ascending offset (i.e. bottom to top).+ -> (Word16, [StgWord])+mkStackBitmap platform nptrs_prefix args_info args+ = (bitmap_size, bitmap)+ where+ bitmap_size = trunc16W $ nptrs_prefix + arg_bottom+ bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets++ arg_bottom = nativeCallSize args_info+ ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset)+ $ mapMaybe get_ptr_offset args++ get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff+ get_ptr_offset (rep, byte_offset)+ | isFollowableArg (toArgRep platform rep) = Just byte_offset+ | otherwise = Nothing++ convert_arg_offset :: ByteOff -> WordOff+ convert_arg_offset arg_offset =+ -- The argument offsets are relative to `arg_bottom`, but+ -- `intsToReverseBitmap` expects offsets from the top, so we need to flip+ -- them around.+ nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset)+ -- ----------------------------------------------------------------------------- -- Deal with a primitive call to native code. @@ -1325,15 +1357,12 @@ (args_info, args_offsets) = layoutNativeCall profile NativePrimCall- d+ 0 (primRepCmmType platform . argPrimRep) nv_args - args_ptrs :: [(Bool, ByteOff)]- args_ptrs =- map (\(r, off) ->- (isFollowableArg (toArgRep platform . argPrimRep $ r), off))- args_offsets+ prim_args_offsets = mapFst argPrimRep args_offsets+ shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1@@ -1350,8 +1379,8 @@ go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a massert (off == dd + szb) go (dd + szb) (push:pushes) cs- push_args <- go d [] args_offsets- args_bco <- emitBc (primCallBCO platform args_info args_ptrs)+ push_args <- go d [] shifted_args_offsets+ args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets) return $ mconcat push_args `appOL` (push_target `consOL` push_info `consOL`@@ -1562,7 +1591,7 @@ -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)- `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)+ `snocOL` RETURN (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL`@@ -1676,7 +1705,6 @@ The code we generate is this: push arg- push bogus-word TESTEQ_I 0 L1 PUSH_G <lbl for first data con>@@ -1694,13 +1722,6 @@ L_exit: SLIDE 1 n ENTER--The 'bogus-word' push is because TESTEQ_I expects the top of the stack-to have an info-table, and the next word to have the value to be-tested. This is very weird, but it's the way it is right now. See-Interpreter.c. We don't actually need an info-table here; we just-need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See #8383. -} @@ -1726,14 +1747,10 @@ slide_ws = bytesToWords platform (d - s + arg_bytes) return (push_arg- `appOL` unitOL (PUSH_UBX LitNullAddr 1)- -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, LABEL label_exit ]- `appOL` mkSlideW 1 (slide_ws + 1)- -- "+1" to account for bogus word- -- (see Note [Implementing tagToEnum#])+ `appOL` mkSlideW 1 slide_ws `appOL` unitOL ENTER) where mkStep l_exit (my_label, next_label, n, name_for_n)
compiler/GHC/StgToCmm/Closure.hs view
@@ -308,8 +308,7 @@ -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the--- tagging strategy. See Note [Data constructor dynamic tags] in--- rts/Interpreter.c+-- tagging strategy; see tagConstr in rts/Interpreter.c. isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
compiler/GHC/StgToJS/Linker/Utils.hs view
@@ -115,8 +115,8 @@ -- GHCJS.Prim.JSVal , if profiling- then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"- else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"+ then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"+ else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n" , "#define JSVAL_VAL(x) ((x).d1)\n" -- GHCJS.Prim.JSException
compiler/GHC/StgToJS/Prim.hs view
@@ -921,7 +921,7 @@ IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]- ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads"+ ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -45,6 +45,7 @@ import GHC.Prelude import GHC.Tc.Utils.Monad+import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs import GHC.Types.FieldLabel import GHC.Types.Name.Reader@@ -2097,8 +2098,8 @@ newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc- rep_lhs_tys = substTyVars lhs_subst fam_tvs- rep_rhs_tys = substTyVars rhs_subst fam_tvs+ (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs+ (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
compiler/GHC/Tc/TyCl.hs view
@@ -4542,30 +4542,39 @@ -- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig checkNewDataCon con = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags-- ; checkTc (isSingleton arg_tys) $- TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)-- ; checkTc (ok_mult (scaledMult arg_ty1)) $- TcRnIllegalNewtype con show_linear_types IsNonLinear+ ; checkNoErrs $+ -- Fail here if the newtype is invalid: subsequent code in+ -- checkValidDataCon can fall over if it comes across an invalid newtype.+ do { case arg_tys of+ [Scaled arg_mult _] ->+ unless (ok_mult arg_mult) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types IsNonLinear+ _ ->+ addErrTc $+ TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) - ; checkTc (null eq_spec) $- TcRnIllegalNewtype con show_linear_types IsGADT+ -- Add an error if the newtype is a GADt or has existentials.+ --+ -- If the newtype is a GADT, the GADT error is enough;+ -- we don't need to *also* complain about existentials.+ ; if not (null eq_spec)+ then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT+ else unless (null ex_tvs) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types HasExistentialTyVar - ; checkTc (null theta) $+ ; unless (null theta) $+ addErrTc $ TcRnIllegalNewtype con show_linear_types HasConstructorContext - ; checkTc (null ex_tvs) $- TcRnIllegalNewtype con show_linear_types HasExistentialTyVar-- ; checkTc (all ok_bang (dataConSrcBangs con)) $- TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation- }+ ; unless (all ok_bang (dataConSrcBangs con)) $+ addErrTc $+ TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } } where+ (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con-- (arg_ty1 : _) = arg_tys ok_bang (HsSrcBang _ _ SrcStrict) = False ok_bang (HsSrcBang _ _ SrcLazy) = False
compiler/GHC/Tc/TyCl/Build.hs view
@@ -18,7 +18,7 @@ import GHC.Prelude import GHC.Iface.Env-import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy )+import GHC.Builtin.Types import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad@@ -65,11 +65,12 @@ tvs = tyConTyVars tycon roles = tyConRoles tycon res_kind = tyConResKind tycon- con_arg_ty = case dataConRepArgTys con of- [arg_ty] -> scaledThing arg_ty- tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)- rhs_ty = substTyWith (dataConUnivTyVars con)- (mkTyVarTys tvs) con_arg_ty+ rhs_ty+ -- Only try if the newtype is actually valid (see "otherwise" below).+ | [Scaled _ arg_ty] <- dataConRepArgTys con+ , null $ dataConExTyCoVars con+ = substTyWith (dataConUnivTyVars con)+ (mkTyVarTys tvs) arg_ty -- Instantiate the newtype's RHS with the -- type variables from the tycon -- NB: a newtype DataCon has a type that must look like@@ -78,6 +79,13 @@ -- the newtype arising from class Foo a => Bar a where {} -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns [].+ | otherwise+ -- If the newtype is invalid (e.g. doesn't have a single argument),+ -- we fake up a type here. The newtype will get rejected once we're+ -- outside the knot-tied loop, in GHC.Tc.TyCl.checkNewDataCon.+ -- See the various test cases in T23308.+ = unitTy -- Might be ill-kinded, but checkNewDataCon should reject this+ -- whole declaration soon enough, before that causes any problems. -- Eta-reduce the newtype -- See Note [Newtype eta] in GHC.Core.TyCon
compiler/GHC/Tc/TyCl/Class.hs view
@@ -22,6 +22,7 @@ , instDeclCtxt2 , instDeclCtxt3 , tcATDefault+ , substATBndrs ) where @@ -37,7 +38,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType-import GHC.Core.Type ( piResultTys )+import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin@@ -55,7 +56,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var-import GHC.Types.Var.Env+import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -497,8 +498,7 @@ -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs- = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst- (tyConTyVars fam_tc)+ = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv'@@ -521,14 +521,73 @@ | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] }++-- | Apply a substitution to the type variable binders of an associated type+-- family. This is used to compute default instances for associated type+-- families (see 'tcATDefault') as well as @newtype@-derived associated type+-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate").+--+-- As a concrete example, consider the following class and associated type+-- family:+--+-- @+-- class C k (a :: k) where+-- type F k a (b :: k) :: Type+-- type F j p q = (Proxy @j p, Proxy @j (q :: j))+-- @+--+-- If a user defines this instance:+--+-- @+-- instance C (Type -> Type) Maybe where {}+-- @+--+-- Then in order to typecheck the default @F@ instance, we must apply the+-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which+-- are @[k, a, (b :: k)]@. The result should look like this:+--+-- @+-- type F (Type -> Type) Maybe (b :: Type -> Type) =+-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type))+-- @+--+-- Making this work requires some care. There are two cases:+--+-- 1. If we encounter a type variable in the domain of the substitution (e.g.,+-- @k@ or @a@), then we apply the substitution directly.+--+-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn+-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution+-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@).+--+-- This step is important to do in case there are later occurrences of @b@,+-- which we must ensure have the correct kind. Otherwise, we might end up+-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the+-- default instance, which would be completely wrong.+--+-- Contrast 'substATBndrs' function with similar substitution functions:+--+-- * 'substTyVars' does not substitute into the kinds of each type variable,+-- nor does it extend the substitution. 'substTyVars' is meant for occurrences+-- of type variables, whereas 'substATBndr's is meant for binders.+--+-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution,+-- but it does not apply the substitution to the variables themselves. As+-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of+-- 'Type's.+substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])+substATBndrs = mapAccumL substATBndr where- subst_tv subst tc_tv+ substATBndr :: Subst -> TyVar -> (Subst, Type)+ substATBndr subst tc_tv+ -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty)+ -- Case (2) in the Haddocks | otherwise- = (extendTvSubst subst tc_tv ty', ty')+ = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') where- ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)+ tc_tv' = updateTyVarKind (substTy subst) tc_tv warnMissingAT :: Name -> TcM () warnMissingAT name
ghc-lib.cabal view
@@ -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
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_lock 1224 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184+#define OFFSET_Capability_context_switch 1192 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188+#define OFFSET_Capability_interrupt 1196 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320+#define OFFSET_Capability_sparks 1328 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192+#define OFFSET_Capability_total_allocated 1200 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168+#define OFFSET_Capability_weak_ptr_list_hd 1176 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176+#define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0