[Git][ghc/ghc][wip/T21623-tycon] 15 commits: Introduce CapIOManager as the per-cap I/O mangager state
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Nov 22 10:05:30 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623-tycon at Glasgow Haskell Compiler / GHC
Commits:
8d6aaa49 by Duncan Coutts at 2022-11-22T02:06:16-05:00
Introduce CapIOManager as the per-cap I/O mangager state
Rather than each I/O manager adding things into the Capability structure
ad-hoc, we should have a common CapIOManager iomgr member of the
Capability structure, with a common interface to initialise etc.
The content of the CapIOManager struct will be defined differently for
each I/O manager implementation. Eventually we should be able to have
the CapIOManager be opaque to the rest of the RTS, and known just to the
I/O manager implementation. We plan for that by making the Capability
contain a pointer to the CapIOManager rather than containing the
structure directly.
Initially just move the Unix threaded I/O manager's control FD.
- - - - -
8901285e by Duncan Coutts at 2022-11-22T02:06:17-05:00
Add hook markCapabilityIOManager
To allow I/O managers to have GC roots in the Capability, within the
CapIOManager structure.
Not yet used in this patch.
- - - - -
5cf709c5 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Move APPEND_TO_BLOCKED_QUEUE from cmm to C
The I/O and delay blocking primitives for the non-threaded way
currently access the blocked_queue and sleeping_queue directly.
We want to move where those queues are to make their ownership clearer:
to have them clearly belong to the I/O manager impls rather than to the
scheduler. Ultimately we will want to change their representation too.
It's inconvenient to do that if these queues are accessed directly from
cmm code. So as a first step, replace the APPEND_TO_BLOCKED_QUEUE with a
C version appendToIOBlockedQueue(), and replace the open-coded
sleeping_queue insertion with insertIntoSleepingQueue().
- - - - -
ced9acdb by Duncan Coutts at 2022-11-22T02:06:17-05:00
Move {blocked,sleeping}_queue from scheduler global vars to CapIOManager
The blocked_queue_{hd,tl} and the sleeping_queue are currently
cooperatively managed between the scheduler and (some but not all of)
the non-threaded I/O manager implementations.
They lived as global vars with the scheduler, but are poked by I/O
primops and the I/O manager backends.
This patch is a step on the path towards making the management of I/O or
timer blocking belong to the I/O managers and not the scheduler.
Specifically, this patch moves the {blocked,sleeping}_queue from being
global vars in the scheduler to being members of the CapIOManager struct
within each Capability. They are not yet exclusively used by the I/O
managers: they are still poked from a couple other places, notably in
the scheduler before calling awaitEvent.
- - - - -
0f68919e by Duncan Coutts at 2022-11-22T02:06:17-05:00
Remove the now-unused markScheduler
The global vars {blocked,sleeping}_queue are now in the Capability and
so get marked there via markCapabilityIOManager.
- - - - -
39a91f60 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Move macros for checking for pending IO or timers
from Schedule.h to Schedule.c and IOManager.h
This is just moving, the next step will be to rejig them slightly.
For the non-threaded RTS the scheduler needs to be able to test for
there being pending I/O operation or pending timers. The implementation
of these tests should really be considered to be part of the I/O
managers and not part of the scheduler.
- - - - -
664b034b by Duncan Coutts at 2022-11-22T02:06:17-05:00
Replace EMPTY_{BLOCKED,SLEEPING}_QUEUE macros by function
These are the macros originaly from Scheduler.h, previously moved to
IOManager.h, and now replaced with a single inline function
anyPendingTimeoutsOrIO(). We can use a single function since the two
macros were always checked together.
Note that since anyPendingTimeoutsOrIO is defined for all IO manager
cases, including threaded, we do not need to guard its use by cpp
#if !defined(THREADED_RTS)
- - - - -
32946220 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Expand emptyThreadQueues inline for clarity
It was not really adding anything. The name no longer meant anything
since those I/O and timeout queues do not belong to the scheuler.
In one of the two places it was used, the comments already had to
explain what it did, whereas now the code matches the comment nicely.
- - - - -
9943baf9 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Move the awaitEvent declaration into IOManager.h
And add or adjust comments at the use sites of awaitEvent.
- - - - -
054dcc9d by Duncan Coutts at 2022-11-22T02:06:17-05:00
Pass the Capability *cap explicitly to awaitEvent
It is currently only used in the non-threaded RTS so it works to use
MainCapability, but it's a bit nicer to pass the cap anyway. It's
certainly shorter.
- - - - -
667fe5a4 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Pass the Capability *cap explicitly to appendToIOBlockedQueue
And to insertIntoSleepingQueue. Again, it's a bit cleaner and simpler
though not strictly necessary given that these primops are currently
only used in the non-threaded RTS.
- - - - -
7181b074 by Duncan Coutts at 2022-11-22T02:06:17-05:00
Reveiew feedback: improve one of the TODO comments
The one about the nonsense (const False) test on WinIO for there being any IO
or timers pending, leading to unnecessary complication later in the
scheduler.
- - - - -
e5b68183 by Andreas Klebinger at 2022-11-22T02:06:52-05:00
Optimize getLevity.
Avoid the intermediate data structures allocated by splitTyConApp.
This avoids ~0.5% of allocations for a build using -O2.
Fixes #22254
- - - - -
de5fb348 by Andreas Klebinger at 2022-11-22T02:07:28-05:00
hadrian:Set TNTC when running testsuite.
- - - - -
9bef4adb by Simon Peyton Jones at 2022-11-22T10:06:48+00:00
Refactor TyCon to have a top-level product
This patch changes the representation of TyCon so that it has
a top-level product type, with a field that gives the details
(newtype, type family etc), #22458.
Not much change in allocation, but execution seems to be a bit
faster.
- - - - -
28 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- + compiler/GHC/Core/TyCo/FVs.hs-boot
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- hadrian/src/Settings/Builders/RunTest.hs
- − rts/AwaitEvent.h
- rts/Capability.c
- rts/Capability.h
- rts/IOManager.c
- rts/IOManager.h
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/Schedule.c
- rts/Schedule.h
- rts/posix/Select.c
- rts/posix/Signals.c
- rts/sm/Compact.c
- rts/sm/GC.c
- rts/sm/NonMoving.c
- rts/win32/AsyncMIO.c
- rts/win32/AwaitEvent.c
- utils/haddock
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -1037,12 +1037,11 @@ unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple Boxed arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
+ tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con
BoxedTuple flavour
tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)
tc_res_kind = liftedTypeKind
- tc_arity = arity
flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name)
dc_tvs = binderVars tc_binders
@@ -1060,7 +1059,7 @@ mk_tuple Boxed arity = (tycon, tuple_con)
mk_tuple Unboxed arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
+ tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con
UnboxedTuple flavour
-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
@@ -1069,8 +1068,6 @@ mk_tuple Unboxed arity = (tycon, tuple_con)
(\ks -> map mkTYPEapp ks)
tc_res_kind = unboxedTupleKind rr_tys
-
- tc_arity = arity * 2
flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name)
dc_tvs = binderVars tc_binders
@@ -1223,7 +1220,7 @@ unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon
mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)
mk_sum arity = (tycon, sum_cons)
where
- tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons)
+ tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons)
UnboxedSumTyCon
tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -271,7 +271,10 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) =
-> TEQ
_ -> TNEQ
- gos _ _ [] [] = TEQ
+ -- These bangs make 'gos' strict in the CMEnv, which in turn
+ -- keeps the CMEnv unboxed across the go/gos mutual recursion
+ -- (If you want a test case, T9872c really exercises this code.)
+ gos !_ !_ [] [] = TEQ
gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq`
gos e1 e2 tys1 tys2
gos _ _ _ _ = TNEQ
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -571,6 +571,11 @@ data UnboxingDecision unboxing_info
-- returned product was constructed, so unbox it.
| DropAbsent -- ^ The argument/field was absent. Drop it.
+instance Outputable i => Outputable (UnboxingDecision i) where
+ ppr DontUnbox = text "DontUnbox"
+ ppr DropAbsent = text "DropAbsent"
+ ppr (DoUnbox i) = text "DoUnbox" <> braces (ppr i)
+
-- | Do we want to create workers just for unlifting?
wwUseForUnlifting :: WwOpts -> WwUse
wwUseForUnlifting !opts
=====================================
compiler/GHC/Core/TyCo/FVs.hs-boot
=====================================
@@ -0,0 +1,6 @@
+module GHC.Core.TyCo.FVs where
+
+import GHC.Prelude ( Bool )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )
+
+noFreeVarsOfType :: Type -> Bool
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -81,7 +81,7 @@ module GHC.Core.TyCon(
tyConKind,
tyConUnique,
tyConTyVars, tyConVisibleTyVars,
- tyConCType, tyConCType_maybe,
+ tyConCType_maybe,
tyConDataCons, tyConDataCons_maybe,
tyConSingleDataCon_maybe, tyConSingleDataCon,
tyConAlgDataCons_maybe,
@@ -96,7 +96,7 @@ module GHC.Core.TyCon(
tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
tyConFamilyResVar_maybe,
synTyConDefn_maybe, synTyConRhs_maybe,
- famTyConFlav_maybe, famTcResVar,
+ famTyConFlav_maybe,
algTyConRhs,
newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
@@ -104,7 +104,8 @@ module GHC.Core.TyCon(
algTcFields,
tyConPromDataConInfo,
tyConBinders, tyConResKind, tyConInvisTVBinders,
- tcTyConScopedTyVars, tcTyConIsPoly,
+ tcTyConScopedTyVars, isMonoTcTyCon,
+ tyConHasClosedResKind,
mkTyConTagMap,
-- ** Manipulating TyCons
@@ -138,6 +139,8 @@ import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep
( Kind, Type, PredType, mkForAllTy, mkNakedKindFunTy, mkNakedTyConTy )
+import {-# SOURCE #-} GHC.Core.TyCo.FVs
+ ( noFreeVarsOfType )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr
( pprType )
import {-# SOURCE #-} GHC.Builtin.Types
@@ -773,10 +776,34 @@ instance Binary TyConBndrVis where
--
-- This data type also encodes a number of primitive, built in type constructors
-- such as those for function and tuple types.
-
+--
-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
-data TyCon =
+data TyCon = TyCon {
+ tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant:
+ -- identical to Unique of Name stored in
+ -- tyConName field.
+
+ tyConName :: !Name, -- ^ Name of the constructor
+
+ -- See Note [The binders/kind/arity fields of a TyCon]
+ tyConBinders :: [TyConBinder], -- ^ Full binders
+ tyConResKind :: Kind, -- ^ Result kind
+ tyConHasClosedResKind :: Bool,
+
+ -- Cached values
+ tyConTyVars :: [TyVar], -- ^ TyVar binders
+ tyConKind :: Kind, -- ^ Kind of this TyCon
+ tyConArity :: Arity, -- ^ Arity
+ tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+
+ tyConRoles :: [Role], -- ^ The role for each type variable
+ -- This list has length = tyConArity
+ -- See also Note [TyCon Role signatures]
+
+ tyConDetails :: !TyConDetails }
+
+data TyConDetails =
-- | Algebraic data types, from
-- - @data@ declarations
-- - @newtype@ declarations
@@ -790,20 +817,6 @@ data TyCon =
-- Data/newtype/type /families/ are handled by 'FamilyTyCon'.
-- See 'AlgTyConRhs' for more information.
AlgTyCon {
- tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant:
- -- identical to Unique of Name stored in
- -- tyConName field.
-
- tyConName :: Name, -- ^ Name of the constructor
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConBinder], -- ^ Full binders
- tyConTyVars :: [TyVar], -- ^ TyVar binders
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-
-- The tyConTyVars scope over:
--
-- 1. The 'algTcStupidTheta'
@@ -813,10 +826,6 @@ data TyCon =
-- Note that it does /not/ scope over the data
-- constructors.
- tcRoles :: [Role], -- ^ The role for each type variable
- -- This list has length = tyConArity
- -- See also Note [TyCon Role signatures]
-
tyConCType :: Maybe CType,-- ^ The C type that should be used
-- for this type when using the FFI
-- and CAPI
@@ -851,25 +860,8 @@ data TyCon =
-- | Represents type synonyms
| SynonymTyCon {
- tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant:
- -- identical to Unique of Name stored in
- -- tyConName field.
-
- tyConName :: Name, -- ^ Name of the constructor
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConBinder], -- ^ Full binders
- tyConTyVars :: [TyVar], -- ^ TyVar binders
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-- tyConTyVars scope over: synTcRhs
- tcRoles :: [Role], -- ^ The role for each type variable
- -- This list has length = tyConArity
- -- See also Note [TyCon Role signatures]
-
synTcRhs :: Type, -- ^ Contains information about the expansion
-- of the synonym
@@ -890,19 +882,6 @@ data TyCon =
-- | Represents families (both type and data)
-- Argument roles are all Nominal
| FamilyTyCon {
- tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant:
- -- identical to Unique of Name stored in
- -- tyConName field.
-
- tyConName :: Name, -- ^ Name of the constructor
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConBinder], -- ^ Full binders
- tyConTyVars :: [TyVar], -- ^ TyVar binders
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-- tyConTyVars connect an associated family TyCon
-- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst
@@ -928,23 +907,6 @@ data TyCon =
-- the usual suspects (such as @Int#@) as well as foreign-imported
-- types and kinds (@*@, @#@, and @?@)
| PrimTyCon {
- tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant:
- -- identical to Unique of Name stored in
- -- tyConName field.
-
- tyConName :: Name, -- ^ Name of the constructor
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConBinder], -- ^ Full binders
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-
- tcRoles :: [Role], -- ^ The role for each type variable
- -- This list has length = tyConArity
- -- See also Note [TyCon Role signatures]
-
primRepName :: TyConRepName -- ^ The 'Typeable' representation.
-- A cached version of
-- @'mkPrelTyConRepName' ('tyConName' tc)@.
@@ -952,18 +914,6 @@ data TyCon =
-- | Represents promoted data constructor.
| PromotedDataCon { -- See Note [Promoted data constructors]
- tyConUnique :: !Unique, -- ^ Same Unique as the data constructor
- tyConName :: Name, -- ^ Same Name as the data constructor
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConPiTyBinder], -- ^ Full binders
- -- TyConPiTyBinder: see Note [Promoted GADT data constructors]
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-
- tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars
dataCon :: DataCon, -- ^ Corresponding data constructor
tcRepName :: TyConRepName,
promDcInfo :: PromDataConInfo -- ^ See comments with 'PromDataConInfo'
@@ -972,31 +922,20 @@ data TyCon =
-- | These exist only during type-checking. See Note [How TcTyCons work]
-- in "GHC.Tc.TyCl"
| TcTyCon {
- tyConUnique :: !Unique,
- tyConName :: Name,
-
- -- See Note [The binders/kind/arity fields of a TyCon]
- tyConBinders :: [TyConBinder], -- ^ Full binders
- tyConTyVars :: [TyVar], -- ^ TyVar binders
- tyConResKind :: Kind, -- ^ Result kind
- tyConKind :: Kind, -- ^ Kind of this TyCon
- tyConArity :: Arity, -- ^ Arity
- tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
-
-- NB: the tyConArity of a TcTyCon must match
-- the number of Required (positional, user-specified)
-- arguments to the type constructor; see the use
-- of tyConArity in generaliseTcTyCon
- tcTyConScopedTyVars :: [(Name,TcTyVar)],
+ tctc_scoped_tvs :: [(Name,TcTyVar)],
-- ^ Scoped tyvars over the tycon's body
-- The range is always a skolem or TcTyVar, be
-- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon]
- tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized?
- -- Used only to make zonking more efficient
+ tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized?
+ -- Used only to make zonking more efficient
- tcTyConFlavour :: TyConFlavour
+ tctc_flavour :: TyConFlavour
-- ^ What sort of 'TyCon' this represents.
}
@@ -1515,21 +1454,24 @@ type TyConRepName = Name
-- $tcMaybe = TyCon { tyConName = "Maybe", ... }
tyConRepName_maybe :: TyCon -> Maybe TyConRepName
-tyConRepName_maybe (PrimTyCon { primRepName = rep_nm })
- = Just rep_nm
-tyConRepName_maybe (AlgTyCon { algTcFlavour = parent }) = case parent of
- VanillaAlgTyCon rep_nm -> Just rep_nm
- UnboxedSumTyCon -> Nothing
- ClassTyCon _ rep_nm -> Just rep_nm
- DataFamInstTyCon {} -> Nothing
-tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
- = Just rep_nm
-tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })
- | isUnboxedSumDataCon dc -- see #13276
- = Nothing
- | otherwise
- = Just rep_nm
-tyConRepName_maybe _ = Nothing
+tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details
+ where
+ get_rep_nm (PrimTyCon { primRepName = rep_nm })
+ = Just rep_nm
+ get_rep_nm (AlgTyCon { algTcFlavour = parent })
+ = case parent of
+ VanillaAlgTyCon rep_nm -> Just rep_nm
+ UnboxedSumTyCon -> Nothing
+ ClassTyCon _ rep_nm -> Just rep_nm
+ DataFamInstTyCon {} -> Nothing
+ get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
+ = Just rep_nm
+ get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })
+ | isUnboxedSumDataCon dc -- see #13276
+ = Nothing
+ | otherwise
+ = Just rep_nm
+ get_rep_nm _ = Nothing
-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type
mkPrelTyConRepName :: Name -> TyConRepName
@@ -1801,9 +1743,9 @@ tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc
-- | The labels for the fields of this particular 'TyCon'
tyConFieldLabelEnv :: TyCon -> FieldLabelEnv
-tyConFieldLabelEnv tc
- | isAlgTyCon tc = algTcFields tc
- | otherwise = emptyDFsEnv
+tyConFieldLabelEnv (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcFields = fields } <- details = fields
+ | otherwise = emptyDFsEnv
-- | Look up a field label belonging to this 'TyCon'
lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel
@@ -1833,6 +1775,25 @@ module mutual-recursion. And they aren't called from many places.
So we compromise, and move their Kind calculation to the call site.
-}
+mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon
+mkTyCon name binders res_kind roles details
+ = tc
+ where
+ -- Recurisve binding because of tcNullaryTy
+ tc = TyCon { tyConName = name
+ , tyConUnique = nameUnique name
+ , tyConBinders = binders
+ , tyConResKind = res_kind
+ , tyConRoles = roles
+ , tyConDetails = details
+
+ -- Cached things
+ , tyConKind = mkTyConKind binders res_kind
+ , tyConArity = length binders
+ , tyConNullaryTy = mkNakedTyConTy tc
+ , tyConHasClosedResKind = noFreeVarsOfType res_kind
+ , tyConTyVars = binderVars binders }
+
-- | This is the making of an algebraic 'TyCon'.
mkAlgTyCon :: Name
-> [TyConBinder] -- ^ Binders of the 'TyCon'
@@ -1847,25 +1808,14 @@ mkAlgTyCon :: Name
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn
- = let tc =
- AlgTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConBinders = binders,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- tyConArity = length binders,
- tyConNullaryTy = mkNakedTyConTy tc,
- tyConTyVars = binderVars binders,
- tcRoles = roles,
- tyConCType = cType,
- algTcStupidTheta = stupid,
- algTcRhs = rhs,
- algTcFields = fieldsOfAlgTcRhs rhs,
- algTcFlavour = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent,
- algTcGadtSyntax = gadt_syn
- }
- in tc
+ = mkTyCon name binders res_kind roles $
+ AlgTyCon { tyConCType = cType
+ , algTcStupidTheta = stupid
+ , algTcRhs = rhs
+ , algTcFields = fieldsOfAlgTcRhs rhs
+ , algTcFlavour = assertPpr (okParent name parent)
+ (ppr name $$ ppr parent) parent
+ , algTcGadtSyntax = gadt_syn }
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> [TyConBinder]
@@ -1879,61 +1829,37 @@ mkClassTyCon name binders roles rhs clas tc_rep_name
mkTupleTyCon :: Name
-> [TyConBinder]
-> Kind -- ^ Result kind of the 'TyCon'
- -> Arity -- ^ Arity of the tuple 'TyCon'
-> DataCon
-> TupleSort -- ^ Whether the tuple is boxed or unboxed
-> AlgTyConFlav
-> TyCon
-mkTupleTyCon name binders res_kind arity con sort parent
- = let tc =
- AlgTyCon {
- tyConUnique = nameUnique name,
- tyConName = name,
- tyConBinders = binders,
- tyConTyVars = binderVars binders,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- tyConArity = arity,
- tyConNullaryTy = mkNakedTyConTy tc,
- tcRoles = replicate arity Representational,
- tyConCType = Nothing,
- algTcGadtSyntax = False,
- algTcStupidTheta = [],
- algTcRhs = TupleTyCon { data_con = con,
- tup_sort = sort },
- algTcFields = emptyDFsEnv,
- algTcFlavour = parent
- }
- in tc
+mkTupleTyCon name binders res_kind con sort parent
+ = mkTyCon name binders res_kind (constRoles binders Representational) $
+ AlgTyCon { tyConCType = Nothing
+ , algTcGadtSyntax = False
+ , algTcStupidTheta = []
+ , algTcRhs = TupleTyCon { data_con = con
+ , tup_sort = sort }
+ , algTcFields = emptyDFsEnv
+ , algTcFlavour = parent }
+
+constRoles :: [TyConBinder] -> Role -> [Role]
+constRoles bndrs role = [role | _ <- bndrs]
mkSumTyCon :: Name
- -> [TyConBinder]
- -> Kind -- ^ Kind of the resulting 'TyCon'
- -> Arity -- ^ Arity of the sum
- -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
- -> [DataCon]
- -> AlgTyConFlav
- -> TyCon
-mkSumTyCon name binders res_kind arity tyvars cons parent
- = let tc =
- AlgTyCon {
- tyConUnique = nameUnique name,
- tyConName = name,
- tyConBinders = binders,
- tyConTyVars = tyvars,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- tyConArity = arity,
- tyConNullaryTy = mkNakedTyConTy tc,
- tcRoles = replicate arity Representational,
- tyConCType = Nothing,
- algTcGadtSyntax = False,
- algTcStupidTheta = [],
- algTcRhs = mkSumTyConRhs cons,
- algTcFields = emptyDFsEnv,
- algTcFlavour = parent
- }
- in tc
+ -> [TyConBinder]
+ -> Kind -- ^ Kind of the resulting 'TyCon'
+ -> [DataCon]
+ -> AlgTyConFlav
+ -> TyCon
+mkSumTyCon name binders res_kind cons parent
+ = mkTyCon name binders res_kind (constRoles binders Representational) $
+ AlgTyCon { tyConCType = Nothing
+ , algTcGadtSyntax = False
+ , algTcStupidTheta = []
+ , algTcRhs = mkSumTyConRhs cons
+ , algTcFields = emptyDFsEnv
+ , algTcFlavour = parent }
-- | Makes a tycon suitable for use during type-checking. It stores
-- a variety of details about the definition of the TyCon, but no
@@ -1951,19 +1877,10 @@ mkTcTyCon :: Name
-> TyConFlavour -- ^ What sort of 'TyCon' this represents
-> TyCon
mkTcTyCon name binders res_kind scoped_tvs poly flav
- = let tc =
- TcTyCon { tyConUnique = getUnique name
- , tyConName = name
- , tyConTyVars = binderVars binders
- , tyConBinders = binders
- , tyConResKind = res_kind
- , tyConKind = mkTyConKind binders res_kind
- , tyConArity = length binders
- , tyConNullaryTy = mkNakedTyConTy tc
- , tcTyConScopedTyVars = scoped_tvs
- , tcTyConIsPoly = poly
- , tcTyConFlavour = flav }
- in tc
+ = mkTyCon name binders res_kind (constRoles binders Nominal) $
+ TcTyCon { tctc_scoped_tvs = scoped_tvs
+ , tctc_is_poly = poly
+ , tctc_flavour = flav }
-- | No scoped type variables (to be used with mkTcTyCon).
noTcTyConScopedTyVars :: [(Name, TcTyVar)]
@@ -1980,64 +1897,29 @@ mkPrimTyCon :: Name -> [TyConBinder]
-> [Role]
-> TyCon
mkPrimTyCon name binders res_kind roles
- = let tc =
- PrimTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConBinders = binders,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- tyConArity = length roles,
- tyConNullaryTy = mkNakedTyConTy tc,
- tcRoles = roles,
- primRepName = mkPrelTyConRepName name
- }
- in tc
+ = mkTyCon name binders res_kind roles $
+ PrimTyCon { primRepName = mkPrelTyConRepName name }
-- | Create a type synonym 'TyCon'
mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon
mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
- = let tc =
- SynonymTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConBinders = binders,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- tyConArity = length binders,
- tyConNullaryTy = mkNakedTyConTy tc,
- tyConTyVars = binderVars binders,
- tcRoles = roles,
- synTcRhs = rhs,
- synIsTau = is_tau,
- synIsFamFree = is_fam_free,
- synIsForgetful = is_forgetful
- }
- in tc
+ = mkTyCon name binders res_kind roles $
+ SynonymTyCon { synTcRhs = rhs
+ , synIsTau = is_tau
+ , synIsFamFree = is_fam_free
+ , synIsForgetful = is_forgetful }
-- | Create a type family 'TyCon'
mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind
-> Maybe Name -> FamTyConFlav
-> Maybe Class -> Injectivity -> TyCon
mkFamilyTyCon name binders res_kind resVar flav parent inj
- = let tc =
- FamilyTyCon
- { tyConUnique = nameUnique name
- , tyConName = name
- , tyConBinders = binders
- , tyConResKind = res_kind
- , tyConKind = mkTyConKind binders res_kind
- , tyConArity = length binders
- , tyConNullaryTy = mkNakedTyConTy tc
- , tyConTyVars = binderVars binders
- , famTcResVar = resVar
- , famTcFlav = flav
- , famTcParent = classTyCon <$> parent
- , famTcInj = inj
- }
- in tc
-
+ = mkTyCon name binders res_kind (constRoles binders Nominal) $
+ FamilyTyCon { famTcResVar = resVar
+ , famTcFlav = flav
+ , famTcParent = classTyCon <$> parent
+ , famTcInj = inj }
-- | Create a promoted data constructor 'TyCon'
-- Somewhat dodgily, we give it the same Name
@@ -2047,43 +1929,36 @@ mkPromotedDataCon :: DataCon -> Name -> TyConRepName
-> [TyConPiTyBinder] -> Kind -> [Role]
-> PromDataConInfo -> TyCon
mkPromotedDataCon con name rep_name binders res_kind roles rep_info
- = let tc =
- PromotedDataCon {
- tyConUnique = nameUnique name,
- tyConName = name,
- tyConArity = length roles,
- tyConNullaryTy = mkNakedTyConTy tc,
- tcRoles = roles,
- tyConBinders = binders,
- tyConResKind = res_kind,
- tyConKind = mkTyConKind binders res_kind,
- dataCon = con,
- tcRepName = rep_name,
- promDcInfo = rep_info
- }
- in tc
+ = mkTyCon name binders res_kind roles $
+ PromotedDataCon { dataCon = con
+ , tcRepName = rep_name
+ , promDcInfo = rep_info }
-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)
isAbstractTyCon :: TyCon -> Bool
-isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True
-isAbstractTyCon _ = False
+isAbstractTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True
+ | otherwise = False
-- | Does this 'TyCon' represent something that cannot be defined in Haskell?
isPrimTyCon :: TyCon -> Bool
-isPrimTyCon (PrimTyCon {}) = True
-isPrimTyCon _ = False
+isPrimTyCon (TyCon { tyConDetails = details })
+ | PrimTyCon {} <- details = True
+ | otherwise = False
-- | Returns @True@ if the supplied 'TyCon' resulted from either a
-- @data@ or @newtype@ declaration
isAlgTyCon :: TyCon -> Bool
-isAlgTyCon (AlgTyCon {}) = True
-isAlgTyCon _ = False
+isAlgTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {} <- details = True
+ | otherwise = False
-- | Returns @True@ for vanilla AlgTyCons -- that is, those created
-- with a @data@ or @newtype@ declaration.
isVanillaAlgTyCon :: TyCon -> Bool
-isVanillaAlgTyCon (AlgTyCon { algTcFlavour = VanillaAlgTyCon _ }) = True
-isVanillaAlgTyCon _ = False
+isVanillaAlgTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True
+ | otherwise = False
isDataTyCon :: TyCon -> Bool
-- ^ Returns @True@ for data types that are /definitely/ represented by
@@ -2097,7 +1972,8 @@ isDataTyCon :: TyCon -> Bool
--
-- NB: for a data type family, only the /instance/ 'TyCon's
-- get an info table. The family declaration 'TyCon' does not
-isDataTyCon (AlgTyCon {algTcRhs = rhs})
+isDataTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = rhs} <- details
= case rhs of
TupleTyCon { tup_sort = sort }
-> isBoxed (tupleSortBoxity sort)
@@ -2113,9 +1989,10 @@ isDataTyCon _ = False
-- | Was this 'TyCon' declared as "type data"?
-- See Note [Type data declarations] in GHC.Rename.Module.
isTypeDataTyCon :: TyCon -> Bool
-isTypeDataTyCon (AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }})
- = type_data
-isTypeDataTyCon _ = False
+isTypeDataTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details
+ = type_data
+ | otherwise = False
-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds
-- (where X is the role passed in):
@@ -2123,30 +2000,38 @@ isTypeDataTyCon _ = False
-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X)
-- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical"
isInjectiveTyCon :: TyCon -> Role -> Bool
-isInjectiveTyCon _ Phantom = False
-isInjectiveTyCon (AlgTyCon {}) Nominal = True
-isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational
- = isGenInjAlgRhs rhs
-isInjectiveTyCon (SynonymTyCon {}) _ = False
-isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })
- Nominal = True
-isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj
-isInjectiveTyCon (FamilyTyCon {}) _ = False
-isInjectiveTyCon (PrimTyCon {}) _ = True
-isInjectiveTyCon (PromotedDataCon {}) _ = True
-isInjectiveTyCon (TcTyCon {}) _ = True
- -- Reply True for TcTyCon to minimise knock on type errors
- -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl
+isInjectiveTyCon (TyCon { tyConDetails = details }) role
+ = go role details
+ where
+ go Phantom _ = False
+
+ go Nominal (AlgTyCon {}) = True
+ go Representational (AlgTyCon {algTcRhs = rhs}) = isGenInjAlgRhs rhs
+
+ go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) = True
+ go Nominal (FamilyTyCon { famTcInj = Injective inj }) = and inj
+ go _ (FamilyTyCon {}) = False
+
+ go _ (SynonymTyCon {}) = False
+ go _ (PrimTyCon {}) = True
+ go _ (PromotedDataCon {}) = True
+ go _ (TcTyCon {}) = True
+ -- Reply True for TcTyCon to minimise knock on type errors
+ -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl
-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds
-- (where X is the role passed in):
-- If (T tys ~X t), then (t's head ~X T).
-- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical"
isGenerativeTyCon :: TyCon -> Role -> Bool
-isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True
-isGenerativeTyCon (FamilyTyCon {}) _ = False
- -- in all other cases, injectivity implies generativity
-isGenerativeTyCon tc r = isInjectiveTyCon tc r
+isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role
+ = go role details
+ where
+ go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True
+ go _ (FamilyTyCon {}) = False
+
+ -- In all other cases, injectivity implies generativity
+ go r _ = isInjectiveTyCon tc r
-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective
-- with respect to representational equality?
@@ -2159,42 +2044,46 @@ isGenInjAlgRhs (NewTyCon {}) = False
-- | Is this 'TyCon' that for a @newtype@
isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True
-isNewTyCon _ = False
+isNewTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True
+ | otherwise = False
-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it
-- expands into, and (possibly) a coercion from the representation type to the
-- @newtype at .
-- Returns @Nothing@ if this is not possible.
unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)
-unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
- algTcRhs = NewTyCon { nt_co = co,
- nt_rhs = rhs }})
- = Just (tvs, rhs, co)
-unwrapNewTyCon_maybe _ = Nothing
+unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details })
+ | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details
+ = Just (tvs, rhs, co)
+ | otherwise = Nothing
unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)
-unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co,
- nt_etad_rhs = (tvs,rhs) }})
- = Just (tvs, rhs, co)
-unwrapNewTyConEtad_maybe _ = Nothing
+unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = NewTyCon { nt_co = co
+ , nt_etad_rhs = (tvs,rhs) }} <- details
+ = Just (tvs, rhs, co)
+ | otherwise = Nothing
-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?
{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type
isTypeSynonymTyCon :: TyCon -> Bool
-isTypeSynonymTyCon (SynonymTyCon {}) = True
-isTypeSynonymTyCon _ = False
+isTypeSynonymTyCon (TyCon { tyConDetails = details })
+ | SynonymTyCon {} <- details = True
+ | otherwise = False
isTauTyCon :: TyCon -> Bool
-isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau
-isTauTyCon _ = True
+isTauTyCon (TyCon { tyConDetails = details })
+ | SynonymTyCon { synIsTau = is_tau } <- details = is_tau
+ | otherwise = True
-- | Is this tycon neither a type family nor a synonym that expands
-- to a type family?
isFamFreeTyCon :: TyCon -> Bool
-isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free
-isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav
-isFamFreeTyCon _ = True
+isFamFreeTyCon (TyCon { tyConDetails = details })
+ | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free
+ | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav
+ | otherwise = True
-- | Is this a forgetful type synonym? If this is a type synonym whose
-- RHS does not mention one (or more) of its bound variables, returns
@@ -2202,8 +2091,9 @@ isFamFreeTyCon _ = True
-- True may not mean anything, as the test to set this flag is
-- conservative.
isForgetfulSynTyCon :: TyCon -> Bool
-isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget
-isForgetfulSynTyCon _ = False
+isForgetfulSynTyCon (TyCon { tyConDetails = details })
+ | SynonymTyCon { synIsForgetful = forget } <- details = forget
+ | otherwise = False
-- As for newtypes, it is in some contexts important to distinguish between
-- closed synonyms and synonym families, as synonym families have no unique
@@ -2224,71 +2114,86 @@ tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour
-- | Is this an algebraic 'TyCon' declared with the GADT syntax?
isGadtSyntaxTyCon :: TyCon -> Bool
-isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res
-isGadtSyntaxTyCon _ = False
+isGadtSyntaxTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcGadtSyntax = res } <- details = res
+ | otherwise = False
-- | Is this an algebraic 'TyCon' which is just an enumeration of values?
isEnumerationTyCon :: TyCon -> Bool
-- See Note [Enumeration types] in GHC.Core.TyCon
-isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs })
+isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
= case rhs of
DataTyCon { is_enum = res } -> res
TupleTyCon {} -> arity == 0
_ -> False
-isEnumerationTyCon _ = False
+ | otherwise = False
-- | Is this a 'TyCon', synonym or otherwise, that defines a family?
isFamilyTyCon :: TyCon -> Bool
-isFamilyTyCon (FamilyTyCon {}) = True
-isFamilyTyCon _ = False
+isFamilyTyCon (TyCon { tyConDetails = details })
+ | FamilyTyCon {} <- details = True
+ | otherwise = False
-- | Is this a 'TyCon', synonym or otherwise, that defines a family with
-- instances?
isOpenFamilyTyCon :: TyCon -> Bool
-isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav })
- | OpenSynFamilyTyCon <- flav = True
- | DataFamilyTyCon {} <- flav = True
-isOpenFamilyTyCon _ = False
+isOpenFamilyTyCon (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcFlav = flav } <- details
+ = case flav of
+ OpenSynFamilyTyCon -> True
+ DataFamilyTyCon {} -> True
+ _ -> False
+ | otherwise = False
-- | Is this a synonym 'TyCon' that can have may have further instances appear?
isTypeFamilyTyCon :: TyCon -> Bool
-isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav)
-isTypeFamilyTyCon _ = False
+isTypeFamilyTyCon (TyCon { tyConDetails = details })
+ | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav)
+ | otherwise = False
-- | Is this a synonym 'TyCon' that can have may have further instances appear?
isDataFamilyTyCon :: TyCon -> Bool
-isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav
-isDataFamilyTyCon _ = False
+isDataFamilyTyCon (TyCon { tyConDetails = details })
+ | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav
+ | otherwise = False
-- | Is this an open type family TyCon?
isOpenTypeFamilyTyCon :: TyCon -> Bool
-isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True
-isOpenTypeFamilyTyCon _ = False
+isOpenTypeFamilyTyCon (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True
+ | otherwise = False
-- | Is this a non-empty closed type family? Returns 'Nothing' for
-- abstract or empty closed families.
isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)
-isClosedSynFamilyTyConWithAxiom_maybe
- (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb
-isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing
+isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb
+ | otherwise = Nothing
+
+isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
+isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops } <- details = Just ops
+ | otherwise = Nothing
+
+-- | Extract type variable naming the result of injective type family
+tyConFamilyResVar_maybe :: TyCon -> Maybe Name
+tyConFamilyResVar_maybe (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcResVar = res} <- details = res
+ | otherwise = Nothing
-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an
-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is
-- injective), or 'NotInjective' otherwise.
tyConInjectivityInfo :: TyCon -> Injectivity
-tyConInjectivityInfo tc
- | FamilyTyCon { famTcInj = inj } <- tc
+tyConInjectivityInfo tc@(TyCon { tyConDetails = details })
+ | FamilyTyCon { famTcInj = inj } <- details
= inj
| isInjectiveTyCon tc Nominal
= Injective (replicate (tyConArity tc) True)
| otherwise
= NotInjective
-isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
-isBuiltInSynFamTyCon_maybe
- (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops
-isBuiltInSynFamTyCon_maybe _ = Nothing
-
isDataFamFlav :: FamTyConFlav -> Bool
isDataFamFlav (DataFamilyTyCon {}) = True -- Data family
isDataFamFlav _ = False -- Type synonym family
@@ -2317,39 +2222,50 @@ isTupleTyCon :: TyCon -> Bool
-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they
-- get spat into the interface file as tuple tycons, so I don't think
-- it matters.
-isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True
-isTupleTyCon _ = False
+isTupleTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True
+ | otherwise = False
tyConTuple_maybe :: TyCon -> Maybe TupleSort
-tyConTuple_maybe (AlgTyCon { algTcRhs = rhs })
- | TupleTyCon { tup_sort = sort} <- rhs = Just sort
-tyConTuple_maybe _ = Nothing
+tyConTuple_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
+ , TupleTyCon { tup_sort = sort} <- rhs = Just sort
+ | otherwise = Nothing
-- | Is this the 'TyCon' for an unboxed tuple?
isUnboxedTupleTyCon :: TyCon -> Bool
-isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs })
- | TupleTyCon { tup_sort = sort } <- rhs
- = not (isBoxed (tupleSortBoxity sort))
-isUnboxedTupleTyCon _ = False
+isUnboxedTupleTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
+ , TupleTyCon { tup_sort = sort } <- rhs
+ = not (isBoxed (tupleSortBoxity sort))
+ | otherwise = False
-- | Is this the 'TyCon' for a boxed tuple?
isBoxedTupleTyCon :: TyCon -> Bool
-isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs })
- | TupleTyCon { tup_sort = sort } <- rhs
- = isBoxed (tupleSortBoxity sort)
-isBoxedTupleTyCon _ = False
+isBoxedTupleTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
+ , TupleTyCon { tup_sort = sort } <- rhs
+ = isBoxed (tupleSortBoxity sort)
+ | otherwise = False
-- | Is this the 'TyCon' for an unboxed sum?
isUnboxedSumTyCon :: TyCon -> Bool
-isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs })
- | SumTyCon {} <- rhs
- = True
-isUnboxedSumTyCon _ = False
+isUnboxedSumTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
+ , SumTyCon {} <- rhs
+ = True
+ | otherwise = False
isLiftedAlgTyCon :: TyCon -> Bool
-isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind })
- = isLiftedTypeKind res_kind
-isLiftedAlgTyCon _ = False
+isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details })
+ | AlgTyCon {} <- details = isLiftedTypeKind res_kind
+ | otherwise = False
+
+-- | Retrieves the promoted DataCon if this is a PromotedDataCon;
+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon
+isPromotedDataCon_maybe (TyCon { tyConDetails = details })
+ | PromotedDataCon { dataCon = dc } <- details = Just dc
+ | otherwise = Nothing
-- | Is this the 'TyCon' for a /promoted/ tuple?
isPromotedTupleTyCon :: TyCon -> Bool
@@ -2360,8 +2276,9 @@ isPromotedTupleTyCon tyCon
-- | Is this a PromotedDataCon?
isPromotedDataCon :: TyCon -> Bool
-isPromotedDataCon (PromotedDataCon {}) = True
-isPromotedDataCon _ = False
+isPromotedDataCon (TyCon { tyConDetails = details })
+ | PromotedDataCon {} <- details = True
+ | otherwise = False
-- | This function identifies PromotedDataCon's from data constructors in
-- `data T = K1 | K2`, promoted by -XDataKinds. These type constructors
@@ -2372,14 +2289,10 @@ isPromotedDataCon _ = False
-- represented with their original undecorated names.
-- See Note [Type data declarations] in GHC.Rename.Module
isDataKindsPromotedDataCon :: TyCon -> Bool
-isDataKindsPromotedDataCon (PromotedDataCon { dataCon = dc })
- = not (isTypeDataCon dc)
-isDataKindsPromotedDataCon _ = False
-
--- | Retrieves the promoted DataCon if this is a PromotedDataCon;
-isPromotedDataCon_maybe :: TyCon -> Maybe DataCon
-isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc
-isPromotedDataCon_maybe _ = Nothing
+isDataKindsPromotedDataCon (TyCon { tyConDetails = details })
+ | PromotedDataCon { dataCon = dc } <- details
+ = not (isTypeDataCon dc)
+ | otherwise = False
-- | Is this tycon really meant for use at the kind level? That is,
-- should it be permitted without -XDataKinds?
@@ -2416,36 +2329,22 @@ isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)
-- (namely: boxed and unboxed tuples are wired-in and implicit,
-- but constraint tuples are not)
isImplicitTyCon :: TyCon -> Bool
-isImplicitTyCon (PrimTyCon {}) = True
-isImplicitTyCon (PromotedDataCon {}) = True
-isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name })
- | TupleTyCon {} <- rhs = isWiredInName name
- | SumTyCon {} <- rhs = True
- | otherwise = False
-isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent
-isImplicitTyCon (SynonymTyCon {}) = False
-isImplicitTyCon (TcTyCon {}) = False
+isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details
+ where
+ go (PrimTyCon {}) = True
+ go (PromotedDataCon {}) = True
+ go (SynonymTyCon {}) = False
+ go (TcTyCon {}) = False
+ go (FamilyTyCon { famTcParent = parent }) = isJust parent
+ go (AlgTyCon { algTcRhs = rhs })
+ | TupleTyCon {} <- rhs = isWiredInName name
+ | SumTyCon {} <- rhs = True
+ | otherwise = False
tyConCType_maybe :: TyCon -> Maybe CType
-tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc
-tyConCType_maybe _ = Nothing
-
--- | Is this a TcTyCon? (That is, one only used during type-checking?)
-isTcTyCon :: TyCon -> Bool
-isTcTyCon (TcTyCon {}) = True
-isTcTyCon _ = False
-
-setTcTyConKind :: TyCon -> Kind -> TyCon
--- Update the Kind of a TcTyCon
--- The new kind is always a zonked version of its previous
--- kind, so we don't need to update any other fields.
--- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType
-setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind
- , tyConNullaryTy = mkNakedTyConTy tc'
- -- see Note [Sharing nullary TyConApps]
- }
- in tc'
-setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc)
+tyConCType_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype
+ | otherwise = Nothing
-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied,
-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?
@@ -2455,31 +2354,33 @@ setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc)
--
-- See Note [Representation-polymorphic TyCons]
tcHasFixedRuntimeRep :: TyCon -> Bool
-tcHasFixedRuntimeRep (AlgTyCon { algTcRhs = rhs }) = case rhs of
- AbstractTyCon {} -> False
- -- An abstract TyCon might not have a fixed runtime representation.
- -- Note that this is an entirely different matter from the concreteness
- -- of the 'TyCon', in the sense of 'isConcreteTyCon'.
+tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
+ = case rhs of
+ AbstractTyCon {} -> False
+ -- An abstract TyCon might not have a fixed runtime representation.
+ -- Note that this is an entirely different matter from the concreteness
+ -- of the 'TyCon', in the sense of 'isConcreteTyCon'.
- DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev
- -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).
- -- NB: the current representation-polymorphism checks require that
- -- the representation be fully-known, including levity variables.
- -- This might be relaxed in the future (#15532).
+ DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev
+ -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).
+ -- NB: the current representation-polymorphism checks require that
+ -- the representation be fully-known, including levity variables.
+ -- This might be relaxed in the future (#15532).
- TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort)
+ TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort)
- SumTyCon {} -> False -- only unboxed sums here
+ SumTyCon {} -> False -- only unboxed sums here
- NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep
- -- A newtype might not have a fixed runtime representation
- -- with UnliftedNewtypes (#17360)
+ NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep
+ -- A newtype might not have a fixed runtime representation
+ -- with UnliftedNewtypes (#17360)
-tcHasFixedRuntimeRep SynonymTyCon{} = False -- conservative choice
-tcHasFixedRuntimeRep FamilyTyCon{} = False
-tcHasFixedRuntimeRep PrimTyCon{} = True
-tcHasFixedRuntimeRep TcTyCon{} = False
-tcHasFixedRuntimeRep tc at PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)
+ | SynonymTyCon {} <- details = False -- conservative choice
+ | FamilyTyCon{} <- details = False
+ | PrimTyCon{} <- details = True
+ | TcTyCon{} <- details = False
+ | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)
-- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?
--
@@ -2505,6 +2406,40 @@ isConcreteTyConFlavour = \case
BuiltInTypeFlavour -> True
PromotedDataConFlavour -> True
+{-
+-----------------------------------------------
+-- TcTyCon
+-----------------------------------------------
+-}
+
+-- | Is this a TcTyCon? (That is, one only used during type-checking?)
+isTcTyCon :: TyCon -> Bool
+isTcTyCon (TyCon { tyConDetails = details })
+ | TcTyCon {} <- details = True
+ | otherwise = False
+
+setTcTyConKind :: TyCon -> Kind -> TyCon
+-- Update the Kind of a TcTyCon
+-- The new kind is always a zonked version of its previous
+-- kind, so we don't need to update any other fields.
+-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType
+setTcTyConKind tc kind
+ = assert (isMonoTcTyCon tc) $
+ let tc' = tc { tyConKind = kind
+ , tyConNullaryTy = mkNakedTyConTy tc' }
+ -- See Note [Sharing nullary TyConApps]
+ in tc'
+
+isMonoTcTyCon :: TyCon -> Bool
+isMonoTcTyCon (TyCon { tyConDetails = details })
+ | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly
+ | otherwise = False
+
+tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)]
+tcTyConScopedTyVars tc@(TyCon { tyConDetails = details })
+ | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs
+ | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc)
+
{-
-----------------------------------------------
-- Expand type-constructor applications
@@ -2525,8 +2460,9 @@ expandSynTyCon_maybe
-- ^ Expand a type synonym application
-- Return Nothing if the TyCon is not a synonym,
-- or if not enough arguments are supplied
-expandSynTyCon_maybe tc tys
- | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
+expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity
+ , tyConDetails = details }) tys
+ | SynonymTyCon { synTcRhs = rhs } <- details
= if arity == 0
then ExpandsSyn [] rhs tys -- Avoid a bit of work in the case of nullary synonyms
else case tys `listLengthCmp` arity of
@@ -2546,17 +2482,17 @@ expandSynTyCon_maybe tc tys
-- exported tycon can have a pattern synonym bundled with it, e.g.,
-- module Foo (TyCon(.., PatSyn)) where
isTyConWithSrcDataCons :: TyCon -> Bool
-isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcFlavour = parent }) =
- case rhs of
- DataTyCon {} -> isSrcParent
- NewTyCon {} -> isSrcParent
- TupleTyCon {} -> isSrcParent
- _ -> False
- where
- isSrcParent = isNoParent parent
-isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} })
- = True -- #14058
-isTyConWithSrcDataCons _ = False
+isTyConWithSrcDataCons (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details
+ , let isSrcParent = isNoParent parent
+ = case rhs of
+ DataTyCon {} -> isSrcParent
+ NewTyCon {} -> isSrcParent
+ TupleTyCon {} -> isSrcParent
+ _ -> False
+ | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details
+ = True -- #14058
+ | otherwise = False
-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no
@@ -2570,7 +2506,8 @@ tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []
-- is the sort that can have any constructors (note: this does not include
-- abstract algebraic types)
tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
-tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs})
+tyConDataCons_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = rhs} <- details
= case rhs of
DataTyCon { data_cons = cons } -> Just cons
NewTyCon { data_con = con } -> Just [con]
@@ -2584,13 +2521,14 @@ tyConDataCons_maybe _ = Nothing
-- is returned. If the 'TyCon' has more than one constructor, or represents a
-- primitive or function type constructor then @Nothing@ is returned.
tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon
-tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })
+tyConSingleDataCon_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
= case rhs of
DataTyCon { data_cons = [c] } -> Just c
TupleTyCon { data_con = c } -> Just c
NewTyCon { data_con = c } -> Just c
_ -> Nothing
-tyConSingleDataCon_maybe _ = Nothing
+ | otherwise = Nothing
-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'.
tyConSingleDataCon :: TyCon -> DataCon
@@ -2619,68 +2557,56 @@ tyConAlgDataCons_maybe tycon
-- | Determine the number of value constructors a 'TyCon' has. Panics if the
-- 'TyCon' is not algebraic or a tuple
tyConFamilySize :: TyCon -> Int
-tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })
+tyConFamilySize tc@(TyCon { tyConDetails = details })
+ | AlgTyCon { algTcRhs = rhs } <- details
= case rhs of
DataTyCon { data_cons_size = size } -> size
NewTyCon {} -> 1
TupleTyCon {} -> 1
SumTyCon { data_cons_size = size } -> size
_ -> pprPanic "tyConFamilySize 1" (ppr tc)
-tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)
+ | otherwise = pprPanic "tyConFamilySize 2" (ppr tc)
-- | Extract an 'AlgTyConRhs' with information about data constructors from an
-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'
algTyConRhs :: TyCon -> AlgTyConRhs
-algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs
-algTyConRhs other = pprPanic "algTyConRhs" (ppr other)
-
--- | Extract type variable naming the result of injective type family
-tyConFamilyResVar_maybe :: TyCon -> Maybe Name
-tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res
-tyConFamilyResVar_maybe _ = Nothing
-
--- | Get the list of roles for the type parameters of a TyCon
-tyConRoles :: TyCon -> [Role]
--- See also Note [TyCon Role signatures]
-tyConRoles tc
- = case tc of
- { AlgTyCon { tcRoles = roles } -> roles
- ; SynonymTyCon { tcRoles = roles } -> roles
- ; FamilyTyCon {} -> const_role Nominal
- ; PrimTyCon { tcRoles = roles } -> roles
- ; PromotedDataCon { tcRoles = roles } -> roles
- ; TcTyCon {} -> const_role Nominal
- }
- where
- const_role r = replicate (tyConArity tc) r
+algTyConRhs tc@(TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = rhs} <- details = rhs
+ | otherwise = pprPanic "algTyConRhs" (ppr tc)
-- | Extract the bound type variables and type expansion of a type synonym
-- 'TyCon'. Panics if the 'TyCon' is not a synonym
newTyConRhs :: TyCon -> ([TyVar], Type)
-newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }})
- = (tvs, rhs)
-newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon)
+newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details })
+ | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details
+ = (tvs, rhs)
+ | otherwise
+ = pprPanic "newTyConRhs" (ppr tc)
-- | The number of type parameters that need to be passed to a newtype to
-- resolve it. May be less than in the definition if it can be eta-contracted.
newTyConEtadArity :: TyCon -> Int
-newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }})
- = length (fst tvs_rhs)
-newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon)
+newTyConEtadArity tc@(TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details
+ = length (fst tvs_rhs)
+ | otherwise
+ = pprPanic "newTyConEtadArity" (ppr tc)
-- | Extract the bound type variables and type expansion of an eta-contracted
-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym
newTyConEtadRhs :: TyCon -> ([TyVar], Type)
-newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs
-newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)
+newTyConEtadRhs tc@(TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs
+ | otherwise = pprPanic "newTyConEtadRhs" (ppr tc)
-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to
-- construct something with the @newtype at s type from its representation type
-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns
-- @Nothing@
newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)
-newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co
-newTyConCo_maybe _ = Nothing
+newTyConCo_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co
+ | otherwise = Nothing
newTyConCo :: TyCon -> CoAxiom Unbranched
newTyConCo tc = case newTyConCo_maybe tc of
@@ -2688,83 +2614,93 @@ newTyConCo tc = case newTyConCo_maybe tc of
Nothing -> pprPanic "newTyConCo" (ppr tc)
newTyConDataCon_maybe :: TyCon -> Maybe DataCon
-newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con
-newTyConDataCon_maybe _ = Nothing
+newTyConDataCon_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con
+ | otherwise = Nothing
-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context
-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration
-- @data Eq a => T a ... at . See @Note [The stupid context]@ in "GHC.Core.DataCon".
tyConStupidTheta :: TyCon -> [PredType]
-tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid
-tyConStupidTheta (PrimTyCon {}) = []
-tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
+tyConStupidTheta tc@(TyCon { tyConDetails = details })
+ | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid
+ | PrimTyCon {} <- details = []
+ | otherwise = pprPanic "tyConStupidTheta" (ppr tc)
-- | Extract the 'TyVar's bound by a vanilla type synonym
-- and the corresponding (unsubstituted) right hand side.
synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)
-synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty})
+synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details })
+ | SynonymTyCon {synTcRhs = ty} <- details
= Just (tyvars, ty)
-synTyConDefn_maybe _ = Nothing
+ | otherwise
+ = Nothing
-- | Extract the information pertaining to the right hand side of a type synonym
-- (@type@) declaration.
synTyConRhs_maybe :: TyCon -> Maybe Type
-synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs
-synTyConRhs_maybe _ = Nothing
+synTyConRhs_maybe (TyCon { tyConDetails = details })
+ | SynonymTyCon {synTcRhs = rhs} <- details = Just rhs
+ | otherwise = Nothing
-- | Extract the flavour of a type family (with all the extra information that
-- it carries)
famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav
-famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav
-famTyConFlav_maybe _ = Nothing
+famTyConFlav_maybe (TyCon { tyConDetails = details })
+ | FamilyTyCon {famTcFlav = flav} <- details = Just flav
+ | otherwise = Nothing
-- | Is this 'TyCon' that for a class instance?
isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTcFlavour = ClassTyCon {}}) = True
-isClassTyCon _ = False
+isClassTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True
+ | otherwise = False
-- | If this 'TyCon' is that for a class instance, return the class it is for.
-- Otherwise returns @Nothing@
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = Just clas
-tyConClass_maybe _ = Nothing
+tyConClass_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas
+ | otherwise = Nothing
-- | Return the associated types of the 'TyCon', if any
tyConATs :: TyCon -> [TyCon]
-tyConATs (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = classATs clas
-tyConATs _ = []
+tyConATs (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas
+ | otherwise = []
----------------------------------------------------------------------------
-- | Is this 'TyCon' that for a data family instance?
isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcFlavour = DataFamInstTyCon {} })
- = True
-isFamInstTyCon _ = False
+isFamInstTyCon (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True
+ | otherwise = False
tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
-tyConFamInstSig_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts })
- = Just (f, ts, ax)
-tyConFamInstSig_maybe _ = Nothing
+tyConFamInstSig_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax)
+ | otherwise = Nothing
-- | If this 'TyCon' is that of a data family instance, return the family in question
-- and the instance types. Otherwise, return @Nothing@
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
-tyConFamInst_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts })
- = Just (f, ts)
-tyConFamInst_maybe _ = Nothing
+tyConFamInst_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts)
+ | otherwise = Nothing
-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which
-- represents a coercion identifying the representation type with the type
-- instance family. Otherwise, return @Nothing@
tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)
-tyConFamilyCoercion_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ })
- = Just ax
-tyConFamilyCoercion_maybe _ = Nothing
+tyConFamilyCoercion_maybe (TyCon { tyConDetails = details })
+ | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax
+ | otherwise = Nothing
-- | Extract any 'RuntimeRepInfo' from this TyCon
tyConPromDataConInfo :: TyCon -> PromDataConInfo
-tyConPromDataConInfo (PromotedDataCon { promDcInfo = rri }) = rri
-tyConPromDataConInfo _ = NoPromInfo
+tyConPromDataConInfo (TyCon { tyConDetails = details })
+ | PromotedDataCon { promDcInfo = rri } <- details = rri
+ | otherwise = NoPromInfo
-- could panic in that second case. But Douglas Adams told me not to.
{-
@@ -2854,26 +2790,30 @@ instance Outputable TyConFlavour where
go PromotedDataConFlavour = "promoted data constructor"
tyConFlavour :: TyCon -> TyConFlavour
-tyConFlavour (AlgTyCon { algTcFlavour = parent, algTcRhs = rhs })
- | ClassTyCon _ _ <- parent = ClassFlavour
- | otherwise = case rhs of
+tyConFlavour (TyCon { tyConDetails = details })
+ | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details
+ = case parent of
+ ClassTyCon {} -> ClassFlavour
+ _ -> case rhs of
TupleTyCon { tup_sort = sort }
-> TupleFlavour (tupleSortBoxity sort)
SumTyCon {} -> SumFlavour
DataTyCon {} -> DataTypeFlavour
NewTyCon {} -> NewtypeFlavour
AbstractTyCon {} -> AbstractTypeFlavour
-tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent })
+
+ | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details
= case flav of
DataFamilyTyCon{} -> DataFamilyFlavour parent
OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent
ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour
AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour
BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour
-tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour
-tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour
-tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour
-tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav
+
+ | SynonymTyCon {} <- details = TypeSynonymFlavour
+ | PrimTyCon {} <- details = BuiltInTypeFlavour
+ | PromotedDataCon {} <- details = PromotedDataConFlavour
+ | TcTyCon { tctc_flavour = flav } <-details = flav
-- | Can this flavour of 'TyCon' appear unsaturated?
tcFlavourMustBeSaturated :: TyConFlavour -> Bool
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -260,7 +260,7 @@ import GHC.Builtin.Types.Prim
import {-# SOURCE #-} GHC.Builtin.Types
( charTy, naturalTy
, typeSymbolKind, liftedTypeKind, unliftedTypeKind
- , boxedRepDataConTyCon, constraintKind, zeroBitTypeKind
+ , constraintKind, zeroBitTypeKind
, manyDataConTy, oneDataConTy
, liftedRepTy, unliftedRepTy, zeroBitRepTy )
@@ -596,6 +596,8 @@ interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind.
--
-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff
-- the type @ty = T tys@, where T's unique = key
+-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`.
+-- Thanks to this fact, we don't have to pattern match on `FunTy` here.
isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]
isTyConKeyApp_maybe key ty
| TyConApp tc args <- coreFullView ty
@@ -2313,8 +2315,11 @@ getRuntimeRep ty
getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type
getLevity_maybe ty
| Just rep <- getRuntimeRep_maybe ty
- , Just (tc, [lev]) <- splitTyConApp_maybe rep
- , tc == boxedRepDataConTyCon
+ -- Directly matching on TyConApp after expanding type synonyms
+ -- saves allocations compared to `splitTyConApp_maybe`. See #22254.
+ -- Given that this is a pretty hot function we make use of the fact
+ -- and use isTyConKeyApp_maybe instead.
+ , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep
= Just lev
| otherwise
= Nothing
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -532,7 +532,7 @@ tyConToIfaceDecl env tycon
, IfaceData { ifName = getName tycon,
ifBinders = if_binders,
ifResKind = if_res_kind,
- ifCType = tyConCType tycon,
+ ifCType = tyConCType_maybe tycon,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2121,7 +2121,7 @@ reifyTyCon tc
| isTypeFamilyTyCon tc
= do { let tvs = tyConTyVars tc
res_kind = tyConResKind tc
- resVar = famTcResVar tc
+ resVar = tyConFamilyResVar_maybe tc
; kind' <- reifyKind res_kind
; let (resultSig, injectivity) =
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -5177,8 +5177,7 @@ addVDQNote :: TcTyCon -> TcM a -> TcM a
-- See Note [Inferring visible dependent quantification]
-- Only types without a signature (CUSK or SAK) here
addVDQNote tycon thing_inside
- | assertPpr (isTcTyCon tycon) (ppr tycon) $
- assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)
+ | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind)
has_vdq
= addLandmarkErrCtxt vdq_warning thing_inside
| otherwise
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2484,9 +2484,9 @@ zonkTcTyCon :: TcTyCon -> TcM TcTyCon
-- A non-poly TcTyCon may have unification
-- variables that need zonking, but poly ones cannot
zonkTcTyCon tc
- | tcTyConIsPoly tc = return tc
- | otherwise = do { tck' <- zonkTcType (tyConKind tc)
+ | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc)
; return (setTcTyConKind tc tck') }
+ | otherwise = return tc
zonkTcTyVar :: TcTyVar -> TcM TcType
-- Simply look through all Flexis
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -60,7 +60,6 @@ runTestGhcFlags = do
, pure "-dno-debug-output"
]
-
data TestCompilerArgs = TestCompilerArgs{
hasDynamicRts, hasThreadedRts :: Bool
, hasDynamic :: Bool
@@ -68,6 +67,7 @@ data TestCompilerArgs = TestCompilerArgs{
, withNativeCodeGen :: Bool
, withInterpreter :: Bool
, unregisterised :: Bool
+ , tables_next_to_code :: Bool
, withSMP :: Bool
, debugAssertions :: Bool
-- ^ Whether the compiler has debug assertions enabled,
@@ -99,6 +99,7 @@ inTreeCompilerArgs stg = do
leadingUnderscore <- flag LeadingUnderscore
withInterpreter <- ghcWithInterpreter
unregisterised <- flag GhcUnregisterised
+ tables_next_to_code <- flag TablesNextToCode
withSMP <- targetSupportsSMP
debugAssertions <- ($ stg) . ghcDebugAssertions <$> flavour
profiled <- ghcProfiled <$> flavour <*> pure stg
@@ -144,6 +145,7 @@ outOfTreeCompilerArgs = do
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
+ tables_next_to_code <- getBooleanSetting TestGhcUnregisterised
withSMP <- getBooleanSetting TestGhcWithSMP
debugAssertions <- getBooleanSetting TestGhcDebugged
@@ -254,6 +256,7 @@ runTestBuilderArgs = builder Testsuite ? do
, arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
, arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
+ , arg "-e", arg $ "config.tables_next_to_code=" ++ show tables_next_to_code
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasDynamicRts)
=====================================
rts/AwaitEvent.h deleted
=====================================
@@ -1,21 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team 1998-2005
- *
- * The awaitEvent() interface, for the non-threaded RTS
- *
- * -------------------------------------------------------------------------*/
-
-#pragma once
-
-#if !defined(THREADED_RTS)
-/* awaitEvent(bool wait)
- *
- * Checks for blocked threads that need to be woken.
- *
- * Called from STG : NO
- * Locks assumed : sched_mutex
- */
-RTS_PRIVATE void awaitEvent(bool wait); /* In posix/Select.c or
- * win32/AwaitEvent.c */
-#endif
=====================================
rts/Capability.c
=====================================
@@ -278,12 +278,11 @@ initCapability (Capability *cap, uint32_t i)
cap->spark_stats.converted = 0;
cap->spark_stats.gcd = 0;
cap->spark_stats.fizzled = 0;
-#if !defined(mingw32_HOST_OS)
- cap->io_manager_control_wr_fd = -1;
-#endif
#endif
cap->total_allocated = 0;
+ initCapabilityIOManager(&cap->iomgr);
+
cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info;
cap->f.stgGCEnter1 = (StgFunPtr)__stg_gc_enter_1;
cap->f.stgGCFun = (StgFunPtr)__stg_gc_fun;
@@ -1323,6 +1322,8 @@ markCapability (evac_fn evac, void *user, Capability *cap,
}
#endif
+ markCapabilityIOManager(evac, user, cap->iomgr);
+
// Free STM structures for this Capability
stmPreGCHook(cap);
}
=====================================
rts/Capability.h
=====================================
@@ -24,6 +24,7 @@
#include "Task.h"
#include "Sparks.h"
#include "sm/NonMovingMark.h" // for MarkQueue
+#include "IOManager.h" // for CapIOManager
#include "BeginPrivate.h"
@@ -157,12 +158,11 @@ struct Capability_ {
// Stats on spark creation/conversion
SparkCounters spark_stats;
-#if !defined(mingw32_HOST_OS)
- // IO manager for this cap
- int io_manager_control_wr_fd;
-#endif
#endif
+ // I/O manager data structures for this capability
+ CapIOManager *iomgr;
+
// Per-capability STM-related data
StgTVarWatchQueue *free_tvar_watch_queues;
StgTRecChunk *free_trec_chunks;
=====================================
rts/IOManager.c
=====================================
@@ -19,7 +19,9 @@
#include "rts/IOInterface.h" // exported
#include "IOManager.h" // RTS internal
#include "Capability.h"
+#include "Schedule.h"
#include "RtsFlags.h"
+#include "RtsUtils.h"
#if !defined(mingw32_HOST_OS) && defined(HAVE_SIGNAL_H)
#include "posix/Signals.h"
@@ -32,7 +34,30 @@
#endif
-/* Called in the RTS initialisation
+/* Allocate and initialise the per-capability CapIOManager that lives in each
+ * Capability. Called early in the RTS initialisation.
+ */
+void initCapabilityIOManager(CapIOManager **piomgr)
+{
+ CapIOManager *iomgr =
+ (CapIOManager *) stgMallocBytes(sizeof(CapIOManager),
+ "initCapabilityIOManager");
+
+#if defined(THREADED_RTS)
+#if !defined(mingw32_HOST_OS)
+ iomgr->control_fd = -1;
+#endif
+#else // !defined(THREADED_RTS)
+ iomgr->blocked_queue_hd = END_TSO_QUEUE;
+ iomgr->blocked_queue_tl = END_TSO_QUEUE;
+ iomgr->sleeping_queue = END_TSO_QUEUE;
+#endif
+
+ *piomgr = iomgr;
+}
+
+
+/* Called late in the RTS initialisation
*/
void
initIOManager(void)
@@ -131,6 +156,19 @@ void wakeupIOManager(void)
#endif
}
+void markCapabilityIOManager(evac_fn evac USED_IF_NOT_THREADS,
+ void *user USED_IF_NOT_THREADS,
+ CapIOManager *iomgr USED_IF_NOT_THREADS)
+{
+
+#if !defined(THREADED_RTS)
+ evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_hd);
+ evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_tl);
+ evac(user, (StgClosure **)(void *)&iomgr->sleeping_queue);
+#endif
+
+}
+
/* Declared in rts/IOInterface.h. Used only by the MIO threaded I/O manager on
* Unix platforms.
@@ -140,10 +178,42 @@ void
setIOManagerControlFd(uint32_t cap_no USED_IF_THREADS, int fd USED_IF_THREADS) {
#if defined(THREADED_RTS)
if (cap_no < n_capabilities) {
- RELAXED_STORE(&capabilities[cap_no]->io_manager_control_wr_fd, fd);
+ RELAXED_STORE(&capabilities[cap_no]->iomgr->control_fd, fd);
} else {
errorBelch("warning: setIOManagerControlFd called with illegal capability number.");
}
#endif
}
#endif
+
+#if !defined(THREADED_RTS)
+void appendToIOBlockedQueue(Capability *cap, StgTSO *tso)
+{
+ CapIOManager *iomgr = cap->iomgr;
+ ASSERT(tso->_link == END_TSO_QUEUE);
+ if (iomgr->blocked_queue_hd == END_TSO_QUEUE) {
+ iomgr->blocked_queue_hd = tso;
+ } else {
+ setTSOLink(cap, iomgr->blocked_queue_tl, tso);
+ }
+ iomgr->blocked_queue_tl = tso;
+}
+
+void insertIntoSleepingQueue(Capability *cap, StgTSO *tso, LowResTime target)
+{
+ CapIOManager *iomgr = cap->iomgr;
+ StgTSO *prev = NULL;
+ StgTSO *t = iomgr->sleeping_queue;
+ while (t != END_TSO_QUEUE && t->block_info.target < target) {
+ prev = t;
+ t = t->_link;
+ }
+
+ tso->_link = t;
+ if (prev == NULL) {
+ iomgr->sleeping_queue = tso;
+ } else {
+ setTSOLink(cap, prev, tso);
+ }
+}
+#endif
=====================================
rts/IOManager.h
=====================================
@@ -21,7 +21,58 @@
#include "BeginPrivate.h"
-/* Init hook: called from hs_init_ghc.
+#include "sm/GC.h" // for evac_fn
+#include "posix/Select.h" // for LowResTime TODO: switch to normal Time
+
+
+/* The per-capability data structures belonging to the I/O manager.
+ *
+ * It can be accessed as cap->iomgr.
+ *
+ * The content of the structure is defined conditionally so it is different for
+ * each I/O manager implementation.
+ *
+ * TODO: once the content of this struct is genuinely private, and not shared
+ * with other parts of the RTS, then it can be made opaque, so the content is
+ * known only to the I/O manager and not the rest of the RTS.
+ */
+typedef struct {
+
+#if defined(THREADED_RTS)
+#if !defined(mingw32_HOST_OS)
+ /* Control FD for the MIO manager for this capability */
+ int control_fd;
+#endif
+#else // !defined(THREADED_RTS)
+ /* Thread queue for threads blocked on I/O completion.
+ * Used by the select() and Win32 MIO I/O managers. It is not used by
+ * the WinIO I/O manager, though it remains defined in this case.
+ */
+ StgTSO *blocked_queue_hd;
+ StgTSO *blocked_queue_tl;
+
+ /* Thread queue for threads blocked on timeouts.
+ * Used by the select() I/O manager only. It is grossly inefficient, like
+ * everything else to do with the select() I/O manager.
+ *
+ * TODO: It is not used by any of the Windows I/O managers, though it
+ * remains defined for them. This is an oddity that should be resolved.
+ */
+ StgTSO *sleeping_queue;
+#endif
+
+} CapIOManager;
+
+
+/* Allocate and initialise the per-capability CapIOManager that lives in each
+ * Capability. It is called from initCapability, via initScheduler,
+ * via hs_init_ghc.
+ */
+void initCapabilityIOManager(CapIOManager **iomgr);
+
+
+/* Init hook: called from hs_init_ghc, very late in the startup after almost
+ * everything else is done.
*/
void initIOManager(void);
@@ -66,6 +117,52 @@ void exitIOManager(bool wait_threads);
void wakeupIOManager(void);
+/* GC hook: mark any per-capability GC roots the I/O manager uses.
+ */
+void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr);
+
+
+#if !defined(THREADED_RTS)
+/* Add a thread to the end of the queue of threads blocked on I/O.
+ *
+ * This is used by the select() and the Windows MIO non-threaded I/O manager
+ * implementation.
+ */
+void appendToIOBlockedQueue(Capability *cap, StgTSO *tso);
+
+/* Insert a thread into the queue of threads blocked on timers.
+ *
+ * This is used by the select() I/O manager implementation only.
+ *
+ * The sleeping queue is defined for other non-threaded I/O managers but not
+ * used. This is a wart that should be excised.
+ */
+void insertIntoSleepingQueue(Capability *cap, StgTSO *tso, LowResTime target);
+#endif
+
+/* Check to see if there are any pending timeouts or I/O operations
+ * in progress with the I/O manager.
+ *
+ * This is used by the scheduler as part of deadlock-detection, and the
+ * "context switch as often as possible" test.
+ */
+INLINE_HEADER bool anyPendingTimeoutsOrIO(CapIOManager *iomgr);
+
+
+#if !defined(THREADED_RTS)
+/* Check whether there is any completed I/O or expired timers. If so,
+ * process the competions as appropriate, which will typically cause some
+ * waiting threads to be woken up.
+ *
+ * Called from schedule() both *before* and *after* scheduleDetectDeadlock().
+ *
+ * Defined in posix/Select.c
+ * or win32/AwaitEvent.c
+ */
+void awaitEvent(Capability *cap, bool wait);
+#endif
+
+
/* Pedantic warning cleanliness
*/
#if !defined(THREADED_RTS) && defined(mingw32_HOST_OS)
@@ -80,5 +177,40 @@ void wakeupIOManager(void);
#define USED_IF_THREADS_AND_NOT_MINGW32 STG_UNUSED
#endif
+/* -----------------------------------------------------------------------------
+ * INLINE functions... private from here on down.
+ *
+ * Some of these hooks are performance sensitive so parts of them are
+ * implemented here so they can be inlined.
+ * -----------------------------------------------------------------------------
+ */
+
+INLINE_HEADER bool anyPendingTimeoutsOrIO(CapIOManager *iomgr USED_IF_NOT_THREADS)
+{
+#if defined(THREADED_RTS)
+ /* For the purpose of the scheduler, the threaded I/O managers never have
+ pending I/O or timers. Of course in reality they do, but they're
+ managed via other primitives that the scheduler can see into (threads,
+ MVars and foreign blocking calls).
+ */
+ return false;
+#else
+#if defined(mingw32_HOST_OS)
+ /* The MIO I/O manager uses the blocked_queue, while the WinIO does not.
+ Note: the latter fact makes this test useless for the WinIO I/O manager,
+ and is the probable cause of the complication in the scheduler with
+ having to call awaitEvent in multiple places.
+
+ None of the Windows I/O managers use the sleeping_queue
+ */
+ return (iomgr->blocked_queue_hd != END_TSO_QUEUE);
+#else
+ /* The select() I/O manager uses the blocked_queue and the sleeping_queue.
+ */
+ return (iomgr->blocked_queue_hd != END_TSO_QUEUE)
+ || (iomgr->sleeping_queue != END_TSO_QUEUE);
+#endif
+#endif
+}
#include "EndPrivate.h"
=====================================
rts/PrimOps.cmm
=====================================
@@ -2571,18 +2571,6 @@ stg_whereFromzh (P_ clos)
Thread I/O blocking primitives
-------------------------------------------------------------------------- */
-/* Add a thread to the end of the blocked queue. (C-- version of the C
- * macro in Schedule.h).
- */
-#define APPEND_TO_BLOCKED_QUEUE(tso) \
- ASSERT(StgTSO__link(tso) == END_TSO_QUEUE); \
- if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \
- W_[blocked_queue_hd] = tso; \
- } else { \
- ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
- } \
- W_[blocked_queue_tl] = tso;
-
stg_waitReadzh ( W_ fd )
{
#if defined(THREADED_RTS)
@@ -2594,7 +2582,7 @@ stg_waitReadzh ( W_ fd )
StgTSO_block_info(CurrentTSO) = fd;
// No locking - we're not going to use this interface in the
// threaded RTS anyway.
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_noregs();
#endif
}
@@ -2610,7 +2598,7 @@ stg_waitWritezh ( W_ fd )
StgTSO_block_info(CurrentTSO) = fd;
// No locking - we're not going to use this interface in the
// threaded RTS anyway.
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_noregs();
#endif
}
@@ -2647,32 +2635,16 @@ stg_delayzh ( W_ us_delay )
* delayed thread on the blocked_queue.
*/
StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_async_void();
#else
-
(target) = ccall getDelayTarget(us_delay);
StgTSO_block_info(CurrentTSO) = target;
- /* Insert the new thread in the sleeping queue. */
- prev = NULL;
- t = W_[sleeping_queue];
-while:
- if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
- prev = t;
- t = StgTSO__link(t);
- goto while;
- }
-
- StgTSO__link(CurrentTSO) = t;
- if (prev == NULL) {
- W_[sleeping_queue] = CurrentTSO;
- } else {
- ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO);
- }
+ ccall insertIntoSleepingQueue(MyCapability() "ptr", CurrentTSO "ptr", target);
jump stg_block_noregs();
#endif
#endif /* !THREADED_RTS */
@@ -2700,7 +2672,7 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
StgAsyncIOResult_len(ares) = 0;
StgAsyncIOResult_errCode(ares) = 0;
StgTSO_block_info(CurrentTSO) = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_async();
#endif
}
@@ -2725,7 +2697,7 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
StgAsyncIOResult_len(ares) = 0;
StgAsyncIOResult_errCode(ares) = 0;
StgTSO_block_info(CurrentTSO) = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_async();
#endif
}
@@ -2750,7 +2722,7 @@ stg_asyncDoProczh ( W_ proc, W_ param )
StgAsyncIOResult_len(ares) = 0;
StgAsyncIOResult_errCode(ares) = 0;
StgTSO_block_info(CurrentTSO) = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
jump stg_block_async();
#endif
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -708,7 +708,8 @@ removeFromQueues(Capability *cap, StgTSO *tso)
#if defined(mingw32_HOST_OS)
case BlockedOnDoProc:
#endif
- removeThreadFromDeQueue(cap, &blocked_queue_hd, &blocked_queue_tl, tso);
+ removeThreadFromDeQueue(cap, &cap->iomgr->blocked_queue_hd,
+ &cap->iomgr->blocked_queue_tl, tso);
#if defined(mingw32_HOST_OS)
/* (Cooperatively) signal that the worker thread should abort
* the request.
@@ -718,7 +719,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
goto done;
case BlockedOnDelay:
- removeThreadFromQueue(cap, &sleeping_queue, tso);
+ removeThreadFromQueue(cap, &cap->iomgr->sleeping_queue, tso);
goto done;
#endif
=====================================
rts/Schedule.c
=====================================
@@ -30,7 +30,6 @@
#include "Sparks.h"
#include "Capability.h"
#include "Task.h"
-#include "AwaitEvent.h"
#include "IOManager.h"
#if defined(mingw32_HOST_OS)
#include "win32/MIOManager.h"
@@ -70,13 +69,6 @@
* Global variables
* -------------------------------------------------------------------------- */
-#if !defined(THREADED_RTS)
-// Blocked/sleeping threads
-StgTSO *blocked_queue_hd = NULL;
-StgTSO *blocked_queue_tl = NULL;
-StgTSO *sleeping_queue = NULL; // perhaps replace with a hash table?
-#endif
-
// Bytes allocated since the last time a HeapOverflow exception was thrown by
// the RTS
uint64_t allocated_bytes_at_heapoverflow = 0;
@@ -174,6 +166,7 @@ static void deleteAllThreads (void);
static void deleteThread_(StgTSO *tso);
#endif
+
/* ---------------------------------------------------------------------------
Main scheduling loop.
@@ -323,7 +316,10 @@ schedule (Capability *initialCapability, Task *task)
/* Notify the I/O manager that we have nothing to do. If there are
any outstanding I/O requests we'll block here. If there are not
then this is a user error and we will abort soon. */
- awaitEvent (emptyRunQueue(cap));
+ /* TODO: see if we can rationalise these two awaitEvent calls before
+ * and after scheduleDetectDeadlock().
+ */
+ awaitEvent (cap, emptyRunQueue(cap));
#else
ASSERT(sched_state >= SCHED_INTERRUPTING);
#endif
@@ -404,8 +400,9 @@ schedule (Capability *initialCapability, Task *task)
* the user specified "context switch as often as possible", with
* +RTS -C0
*/
- if (RtsFlags.ConcFlags.ctxtSwitchTicks == 0
- && !emptyThreadQueues(cap)) {
+ if (RtsFlags.ConcFlags.ctxtSwitchTicks == 0 &&
+ (!emptyRunQueue(cap) ||
+ anyPendingTimeoutsOrIO(cap->iomgr))) {
RELAXED_STORE(&cap->context_switch, 1);
}
@@ -905,14 +902,34 @@ static void
scheduleCheckBlockedThreads(Capability *cap USED_IF_NOT_THREADS)
{
#if !defined(THREADED_RTS)
- //
- // Check whether any waiting threads need to be woken up. If the
- // run queue is empty, and there are no other tasks running, we
- // can wait indefinitely for something to happen.
- //
- if ( !emptyQueue(blocked_queue_hd) || !emptyQueue(sleeping_queue) )
+ /* Check whether there is any completed I/O or expired timers. If so,
+ * process the competions as appropriate, which will typically cause some
+ * waiting threads to be woken up.
+ *
+ * If the run queue is empty, and there are no other threads running, we
+ * can wait indefinitely for something to happen.
+ *
+ * TODO: see if we can rationalise these two awaitEvent calls before
+ * and after scheduleDetectDeadlock()
+ *
+ * TODO: this test anyPendingTimeoutsOrIO does not have a proper
+ * implementation the WinIO I/O manager!
+ *
+ * The select() I/O manager uses the sleeping_queue and the blocked_queue,
+ * and the test checks both. The legacy win32 I/O manager only consults
+ * the blocked_queue, but then it puts threads waiting on delay# on the
+ * blocked_queue too, so that's ok.
+ *
+ * The WinIO I/O manager does not use either the sleeping_queue or the
+ * blocked_queue, but it's implementation of anyPendingTimeoutsOrIO still
+ * checks both! Since both queues will _always_ be empty then it will
+ * _always_ return false and so awaitEvent will _never_ be called here for
+ * WinIO. This may explain why there is a second call to awaitEvent below
+ * for the case of !defined(THREADED_RTS) && defined(mingw32_HOST_OS).
+ */
+ if (anyPendingTimeoutsOrIO(cap->iomgr))
{
- awaitEvent (emptyRunQueue(cap));
+ awaitEvent (cap, emptyRunQueue(cap));
}
#endif
}
@@ -931,7 +948,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task)
* other tasks are waiting for work, we must have a deadlock of
* some description.
*/
- if ( emptyThreadQueues(cap) )
+ if ( emptyRunQueue(cap) && !anyPendingTimeoutsOrIO(cap->iomgr) )
{
#if defined(THREADED_RTS)
/*
@@ -2365,11 +2382,6 @@ deleteAllThreads ()
// somewhere, and the main scheduler loop has to deal with it.
// Also, the run queue is the only thing keeping these threads from
// being GC'd, and we don't want the "main thread has been GC'd" panic.
-
-#if !defined(THREADED_RTS)
- ASSERT(blocked_queue_hd == END_TSO_QUEUE);
- ASSERT(sleeping_queue == END_TSO_QUEUE);
-#endif
}
/* -----------------------------------------------------------------------------
@@ -2703,12 +2715,6 @@ startWorkerTasks (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS)
void
initScheduler(void)
{
-#if !defined(THREADED_RTS)
- blocked_queue_hd = END_TSO_QUEUE;
- blocked_queue_tl = END_TSO_QUEUE;
- sleeping_queue = END_TSO_QUEUE;
-#endif
-
sched_state = SCHED_RUNNING;
SEQ_CST_STORE(&recent_activity, ACTIVITY_YES);
@@ -2793,16 +2799,6 @@ freeScheduler( void )
#endif
}
-void markScheduler (evac_fn evac USED_IF_NOT_THREADS,
- void *user USED_IF_NOT_THREADS)
-{
-#if !defined(THREADED_RTS)
- evac(user, (StgClosure **)(void *)&blocked_queue_hd);
- evac(user, (StgClosure **)(void *)&blocked_queue_tl);
- evac(user, (StgClosure **)(void *)&sleeping_queue);
-#endif
-}
-
/* -----------------------------------------------------------------------------
performGC
=====================================
rts/Schedule.h
=====================================
@@ -22,7 +22,6 @@
void initScheduler (void);
void exitScheduler (bool wait_foreign);
void freeScheduler (void);
-void markScheduler (evac_fn evac, void *user);
// Place a new thread on the run queue of the current Capability
void scheduleThread (Capability *cap, StgTSO *tso);
@@ -105,14 +104,6 @@ extern volatile StgWord sched_state;
*/
extern volatile StgWord recent_activity;
-/* Thread queues.
- * Locks required : sched_mutex
- */
-#if !defined(THREADED_RTS)
-extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
-extern StgTSO *sleeping_queue;
-#endif
-
extern bool heap_overflow;
#if defined(THREADED_RTS)
@@ -155,30 +146,6 @@ peekRunQueue (Capability *cap)
void promoteInRunQueue (Capability *cap, StgTSO *tso);
-/* Add a thread to the end of the blocked queue.
- */
-#if !defined(THREADED_RTS)
-INLINE_HEADER void
-appendToBlockedQueue(StgTSO *tso)
-{
- ASSERT(tso->_link == END_TSO_QUEUE);
- if (blocked_queue_hd == END_TSO_QUEUE) {
- blocked_queue_hd = tso;
- } else {
- setTSOLink(&MainCapability, blocked_queue_tl, tso);
- }
- blocked_queue_tl = tso;
-}
-#endif
-
-/* Check whether various thread queues are empty
- */
-INLINE_HEADER bool
-emptyQueue (StgTSO *q)
-{
- return (q == END_TSO_QUEUE);
-}
-
INLINE_HEADER bool
emptyRunQueue(Capability *cap)
{
@@ -199,21 +166,6 @@ truncateRunQueue(Capability *cap)
cap->n_run_queue = 0;
}
-#if !defined(THREADED_RTS)
-#define EMPTY_BLOCKED_QUEUE() (emptyQueue(blocked_queue_hd))
-#define EMPTY_SLEEPING_QUEUE() (emptyQueue(sleeping_queue))
-#endif
-
-INLINE_HEADER bool
-emptyThreadQueues(Capability *cap)
-{
- return emptyRunQueue(cap)
-#if !defined(THREADED_RTS)
- && EMPTY_BLOCKED_QUEUE() && EMPTY_SLEEPING_QUEUE()
-#endif
- ;
-}
-
#endif /* !IN_STG_CODE */
#include "EndPrivate.h"
=====================================
rts/posix/Select.c
=====================================
@@ -19,7 +19,7 @@
#include "RtsUtils.h"
#include "Capability.h"
#include "Select.h"
-#include "AwaitEvent.h"
+#include "IOManager.h"
#include "Stats.h"
#include "GetTime.h"
@@ -93,23 +93,23 @@ LowResTime getDelayTarget (HsInt us)
* if this is true, then our time has expired.
* (idea due to Andy Gill).
*/
-static bool wakeUpSleepingThreads (LowResTime now)
+static bool wakeUpSleepingThreads (Capability *cap, LowResTime now)
{
+ CapIOManager *iomgr = cap->iomgr;
StgTSO *tso;
bool flag = false;
- while (sleeping_queue != END_TSO_QUEUE) {
- tso = sleeping_queue;
+ while (iomgr->sleeping_queue != END_TSO_QUEUE) {
+ tso = iomgr->sleeping_queue;
if (((long)now - (long)tso->block_info.target) < 0) {
break;
}
- sleeping_queue = tso->_link;
+ iomgr->sleeping_queue = tso->_link;
tso->why_blocked = NotBlocked;
tso->_link = END_TSO_QUEUE;
IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %"
FMT_StgThreadID "\n", tso->id));
- // MainCapability: this code is !THREADED_RTS
- pushOnRunQueue(&MainCapability,tso);
+ pushOnRunQueue(cap,tso);
flag = true;
}
return flag;
@@ -217,8 +217,9 @@ static enum FdState fdPollWriteState (int fd)
*
*/
void
-awaitEvent(bool wait)
+awaitEvent(Capability *cap, bool wait)
{
+ CapIOManager *iomgr = cap->iomgr;
StgTSO *tso, *prev, *next;
fd_set rfd,wfd;
int numFound;
@@ -243,7 +244,7 @@ awaitEvent(bool wait)
do {
now = getLowResTimeOfDay();
- if (wakeUpSleepingThreads(now)) {
+ if (wakeUpSleepingThreads(cap, now)) {
return;
}
@@ -253,7 +254,9 @@ awaitEvent(bool wait)
FD_ZERO(&rfd);
FD_ZERO(&wfd);
- for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; tso = next) {
+ for(tso = iomgr->blocked_queue_hd;
+ tso != END_TSO_QUEUE;
+ tso = next) {
next = tso->_link;
/* On older FreeBSDs, FD_SETSIZE is unsigned. Cast it to signed int
@@ -298,7 +301,7 @@ awaitEvent(bool wait)
tv.tv_sec = 0;
tv.tv_usec = 0;
ptv = &tv;
- } else if (sleeping_queue != END_TSO_QUEUE) {
+ } else if (iomgr->sleeping_queue != END_TSO_QUEUE) {
/* SUSv2 allows implementations to have an implementation defined
* maximum timeout for select(2). The standard requires
* implementations to silently truncate values exceeding this maximum
@@ -317,7 +320,9 @@ awaitEvent(bool wait)
*/
const time_t max_seconds = 2678400; // 31 * 24 * 60 * 60
- Time min = LowResTimeToTime(sleeping_queue->block_info.target - now);
+ Time min = LowResTimeToTime(
+ iomgr->sleeping_queue->block_info.target - now
+ );
tv.tv_sec = TimeToSeconds(min);
if (tv.tv_sec < max_seconds) {
tv.tv_usec = TimeToUS(min) % 1000000;
@@ -350,7 +355,7 @@ awaitEvent(bool wait)
*/
#if defined(RTS_USER_SIGNALS)
if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) {
- startSignalHandlers(&MainCapability);
+ startSignalHandlers(cap);
return; /* still hold the lock */
}
#endif
@@ -363,12 +368,12 @@ awaitEvent(bool wait)
/* check for threads that need waking up
*/
- wakeUpSleepingThreads(getLowResTimeOfDay());
+ wakeUpSleepingThreads(cap, getLowResTimeOfDay());
/* If new runnable threads have arrived, stop waiting for
* I/O and run them.
*/
- if (!emptyRunQueue(&MainCapability)) {
+ if (!emptyRunQueue(cap)) {
return; /* still hold the lock */
}
}
@@ -385,7 +390,9 @@ awaitEvent(bool wait)
* traversed blocked TSOs. As a result you
* can't use functions accessing 'blocked_queue_hd'.
*/
- for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; tso = next) {
+ for(tso = iomgr->blocked_queue_hd;
+ tso != END_TSO_QUEUE;
+ tso = next) {
next = tso->_link;
int fd;
enum FdState fd_state = RTS_FD_IS_BLOCKING;
@@ -422,7 +429,7 @@ awaitEvent(bool wait)
IF_DEBUG(scheduler,
debugBelch("Killing blocked thread %" FMT_StgThreadID
" on bad fd=%i\n", tso->id, fd));
- raiseAsync(&MainCapability, tso,
+ raiseAsync(cap, tso,
(StgClosure *)blockedOnBadFD_closure, false, NULL);
break;
case RTS_FD_IS_READY:
@@ -431,28 +438,29 @@ awaitEvent(bool wait)
tso->id));
tso->why_blocked = NotBlocked;
tso->_link = END_TSO_QUEUE;
- pushOnRunQueue(&MainCapability,tso);
+ pushOnRunQueue(cap,tso);
break;
case RTS_FD_IS_BLOCKING:
if (prev == NULL)
- blocked_queue_hd = tso;
+ iomgr->blocked_queue_hd = tso;
else
- setTSOLink(&MainCapability, prev, tso);
+ setTSOLink(cap, prev, tso);
prev = tso;
break;
}
}
if (prev == NULL)
- blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
+ iomgr->blocked_queue_hd =
+ iomgr->blocked_queue_tl = END_TSO_QUEUE;
else {
prev->_link = END_TSO_QUEUE;
- blocked_queue_tl = prev;
+ iomgr->blocked_queue_tl = prev;
}
}
} while (wait && sched_state == SCHED_RUNNING
- && emptyRunQueue(&MainCapability));
+ && emptyRunQueue(cap));
}
#endif /* THREADED_RTS */
=====================================
rts/posix/Signals.c
=====================================
@@ -203,11 +203,11 @@ ioManagerDie (void)
{
// Shut down IO managers
for (i=0; i < n_capabilities; i++) {
- const int fd = RELAXED_LOAD(&capabilities[i]->io_manager_control_wr_fd);
+ const int fd = RELAXED_LOAD(&capabilities[i]->iomgr->control_fd);
if (0 <= fd) {
r = write(fd, &byte, 1);
if (r == -1) { sysErrorBelch("ioManagerDie: write"); }
- RELAXED_STORE(&capabilities[i]->io_manager_control_wr_fd, -1);
+ RELAXED_STORE(&capabilities[i]->iomgr->control_fd, -1);
}
}
}
=====================================
rts/sm/Compact.c
=====================================
@@ -20,7 +20,6 @@
#include "BlockAlloc.h"
#include "GC.h"
#include "Compact.h"
-#include "Schedule.h"
#include "Apply.h"
#include "Trace.h"
#include "Weak.h"
@@ -981,8 +980,6 @@ compact(StgClosure *static_objects,
// 1. thread the roots
markCapabilities((evac_fn)thread_root, NULL);
- markScheduler((evac_fn)thread_root, NULL);
-
// the weak pointer lists...
for (W_ g = 0; g < RtsFlags.GcFlags.generations; g++) {
if (generations[g].weak_ptr_list != NULL) {
=====================================
rts/sm/GC.c
=====================================
@@ -537,8 +537,6 @@ GarbageCollect (uint32_t collect_gen,
markCapability(mark_root, gct, cap, true/*don't mark sparks*/);
}
- markScheduler(mark_root, gct);
-
// Mark the weak pointer list, and prepare to detect dead weak pointers.
markWeakPtrList();
initWeakForGC();
=====================================
rts/sm/NonMoving.c
=====================================
@@ -25,7 +25,6 @@
#include "NonMovingSweep.h"
#include "NonMovingCensus.h"
#include "StablePtr.h" // markStablePtrTable
-#include "Schedule.h" // markScheduler
#include "Weak.h" // dead_weak_ptr_list
struct NonmovingHeap nonmovingHeap;
@@ -949,7 +948,6 @@ void nonmovingCollect(StgWeak **dead_weaks, StgTSO **resurrected_threads)
markCapability((evac_fn)markQueueAddRoot, mark_queue,
capabilities[n], true/*don't mark sparks*/);
}
- markScheduler((evac_fn)markQueueAddRoot, mark_queue);
nonmovingMarkWeakPtrList(mark_queue, *dead_weaks);
markStablePtrTable((evac_fn)markQueueAddRoot, mark_queue);
=====================================
rts/win32/AsyncMIO.c
=====================================
@@ -224,6 +224,8 @@ awaitRequests(bool wait)
#if !defined(THREADED_RTS)
// none of this is actually used in the threaded RTS
+ CapIOManager *iomgr = MainCapability.iomgr;
+
start:
#if 0
fprintf(stderr, "awaitRequests(): %d %d %d\n",
@@ -289,7 +291,7 @@ start:
unsigned int rID = completedTable[i].reqID;
prev = NULL;
- for(tso = blocked_queue_hd; tso != END_TSO_QUEUE;
+ for(tso = iomgr->blocked_queue_hd; tso != END_TSO_QUEUE;
tso = tso->_link) {
switch(tso->why_blocked) {
@@ -309,10 +311,11 @@ start:
if (prev) {
setTSOLink(&MainCapability, prev, tso->_link);
} else {
- blocked_queue_hd = tso->_link;
+ iomgr->blocked_queue_hd = tso->_link;
}
- if (blocked_queue_tl == tso) {
- blocked_queue_tl = prev ? prev : END_TSO_QUEUE;
+ if (iomgr->blocked_queue_tl == tso) {
+ iomgr->blocked_queue_tl = prev ? prev
+ : END_TSO_QUEUE;
}
// Terminates the run queue + this inner for-loop.
=====================================
rts/win32/AwaitEvent.c
=====================================
@@ -16,7 +16,7 @@
#include "Rts.h"
#include "RtsFlags.h"
#include "Schedule.h"
-#include "AwaitEvent.h"
+#include "IOManager.h"
#include <windows.h>
#include "win32/AsyncMIO.h"
#include "win32/AsyncWinIO.h"
@@ -28,7 +28,7 @@
static bool workerWaitingForRequests = false;
void
-awaitEvent(bool wait)
+awaitEvent(Capability *cap, bool wait)
{
do {
/* Try to de-queue completed IO requests
@@ -45,7 +45,7 @@ awaitEvent(bool wait)
// startSignalHandlers(), but this is the way that posix/Select.c
// does it and I'm feeling too paranoid to refactor it today --SDM
if (stg_pending_events != 0) {
- startSignalHandlers(&MainCapability);
+ startSignalHandlers(cap);
return;
}
@@ -57,7 +57,7 @@ awaitEvent(bool wait)
} while (wait
&& sched_state == SCHED_RUNNING
- && emptyRunQueue(&MainCapability)
+ && emptyRunQueue(cap)
);
}
#endif
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 2ffde83344bab8ed0aee3e8ef46f43856c7ca6ef
+Subproject commit 9f3d49deb0463294c86af35d7bda5e577360298f
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1059c4aaf677600c00119a12deaf6af9564e570e...9bef4adbb5bcf4c94d45a28b48f701cc2a6d1983
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1059c4aaf677600c00119a12deaf6af9564e570e...9bef4adbb5bcf4c94d45a28b48f701cc2a6d1983
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221122/9de7e721/attachment-0001.html>
More information about the ghc-commits
mailing list