[Git][ghc/ghc][wip/tycl-group] 8 commits: Update "GHC differences to the FFI Chapter" in user guide.
Vladislav Zavialov
gitlab at gitlab.haskell.org
Thu Mar 19 14:15:25 UTC 2020
Vladislav Zavialov pushed to branch wip/tycl-group at Glasgow Haskell Compiler / GHC
Commits:
5cbf9934 by Andreas Klebinger at 2020-03-19T04:39:27Z
Update "GHC differences to the FFI Chapter" in user guide.
The old entry had a heavy focus on how things had been. Which is
not what I generally look for in a user guide.
I also added a small section on behaviour of nested safe ffi calls.
[skip-ci]
- - - - -
b03fd3bc by Sebastian Graf at 2020-03-19T04:40:06Z
PmCheck: Use ConLikeSet to model negative info
In #17911, Simon recognised many warnings stemming from over-long list
unions while coverage checking Cabal's `LicenseId` module.
This patch introduces a new `PmAltConSet` type which uses a `UniqDSet`
instead of an association list for `ConLike`s. For `PmLit`s, it will
still use an assocation list, though, because a similar map data
structure would entail a lot of busy work.
Fixes #17911.
- - - - -
e35f1969 by Vladislav Zavialov at 2020-03-19T14:14:44Z
Data family TyClGroup
- - - - -
42269092 by Vladislav Zavialov at 2020-03-19T14:14:51Z
tcLookupTcTyCon for kinded decls
- - - - -
9d580d0f by Vladislav Zavialov at 2020-03-19T14:14:51Z
improve tcLookupTcTyCon panic message
- - - - -
5d98faa5 by Vladislav Zavialov at 2020-03-19T14:14:51Z
accept new test output
- - - - -
906d74e1 by Vladislav Zavialov at 2020-03-19T14:14:51Z
minor comments
- - - - -
2d7968dd by Vladislav Zavialov at 2020-03-19T14:14:51Z
No concatMap
- - - - -
18 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/PmCheck/Oracle.hs
- compiler/GHC/HsToCore/PmCheck/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Source.hs
- compiler/typecheck/TcEnv.hs
- compiler/typecheck/TcHsType.hs
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcTyClsDecls.hs
- docs/users_guide/exts/ffi.rst
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -7,6 +7,7 @@ The @TyCon@ datatype
-}
{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Core.TyCon(
-- * Main TyCon data types
@@ -2583,7 +2584,7 @@ data TyConFlavour
| TypeSynonymFlavour
| BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.
| PromotedDataConFlavour
- deriving Eq
+ deriving (Eq, Data.Data)
instance Outputable TyConFlavour where
ppr = text . go
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -3,6 +3,7 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -10,6 +11,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
@@ -29,6 +31,7 @@ module GHC.Hs.Decls (
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
+ DeclHeaderRn(..), DeclSigRn(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
@@ -42,7 +45,7 @@ module GHC.Hs.Decls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
- InstDecl(..), LInstDecl, FamilyInfo(..),
+ InstDecl(..), LInstDecl, FamilyInfo(..), getFamFlav,
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
@@ -88,11 +91,14 @@ module GHC.Hs.Decls (
resultVariableName, familyDeclLName, familyDeclName,
-- * Grouping
- HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
+ KindedDecls(..), isKindedDecl,
+ HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
hsGroupTopLevelFixitySigs,
) where
+#include "HsVersions.h"
+
-- friends:
import GhcPrelude
@@ -120,6 +126,8 @@ import GHC.Core.Type
import Bag
import Maybes
import Data.Data hiding (TyCon,Fixity, Infix)
+import Data.Void
+import qualified Data.Semigroup
{-
************************************************************************
@@ -250,18 +258,32 @@ data HsGroup p
}
| XHsGroup (XXHsGroup p)
-type instance XCHsGroup (GhcPass _) = NoExtField
+type instance XCHsGroup GhcPs = NoExtField
+type instance XCHsGroup GhcRn = KindedDecls
+type instance XCHsGroup GhcTc = Void
type instance XXHsGroup (GhcPass _) = NoExtCon
+-- | Names of declarations that either have a CUSK or a SAKS.
+newtype KindedDecls = KindedDecls NameSet
+
+instance Semigroup KindedDecls where
+ KindedDecls a <> KindedDecls b = KindedDecls (unionNameSet a b)
+
+instance Monoid KindedDecls where
+ mempty = KindedDecls emptyNameSet
+
+isKindedDecl :: KindedDecls -> TyClDecl GhcRn -> Bool
+isKindedDecl (KindedDecls nameSet) d = elemNameSet (tcdName d) nameSet
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
+emptyGroup :: Monoid (XCHsGroup (GhcPass p)) => HsGroup (GhcPass p)
+
+emptyRdrGroup :: HsGroup GhcPs
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
-emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
-hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
-hsGroupInstDecls = (=<<) group_instds . hs_tyclds
+emptyRnGroup :: HsGroup GhcRn
+emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
-emptyGroup = HsGroup { hs_ext = noExtField,
+emptyGroup = HsGroup { hs_ext = mempty,
hs_tyclds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
@@ -273,7 +295,7 @@ emptyGroup = HsGroup { hs_ext = noExtField,
-- | The fixity signatures for each top-level declaration and class method
-- in an 'HsGroup'.
-- See Note [Top-level fixity signatures in an HsGroup]
-hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
+hsGroupTopLevelFixitySigs :: IsPass p => HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
fixds ++ cls_fixds
where
@@ -283,10 +305,12 @@ hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
]
hsGroupTopLevelFixitySigs (XHsGroup nec) = noExtCon nec
-appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
+appendGroups :: Semigroup (XCHsGroup (GhcPass p))
+ => HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
appendGroups
HsGroup {
+ hs_ext = ext1,
hs_valds = val_groups1,
hs_splcds = spliceds1,
hs_tyclds = tyclds1,
@@ -299,6 +323,7 @@ appendGroups
hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup {
+ hs_ext = ext2,
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
@@ -312,7 +337,7 @@ appendGroups
hs_docs = docs2 }
=
HsGroup {
- hs_ext = noExtField,
+ hs_ext = ext1 Data.Semigroup.<> ext2,
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
@@ -795,20 +820,28 @@ instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where
ppr (XTyClDecl x) = ppr x
-instance OutputableBndrId p
- => Outputable (TyClGroup (GhcPass p)) where
- ppr (TyClGroup { group_tyclds = tyclds
- , group_roles = roles
- , group_kisigs = kisigs
- , group_instds = instds
- }
- )
- = hang (text "TyClGroup") 2 $
- ppr kisigs $$
- ppr tyclds $$
- ppr roles $$
- ppr instds
- ppr (XTyClGroup x) = ppr x
+instance IsPass p => Outputable (TyClGroup (GhcPass p)) where
+ ppr =
+ case ghcPass @p of
+ GhcPs -> pprPs
+ GhcRn -> pprRn
+ GhcTc -> tcg_tc_absurd
+ where
+ pprPs (TcgPsDecl d) = ppr d
+ pprPs (TcgPsRole role) = ppr role
+ pprPs (TcgPsKiSig kisig) = ppr kisig
+ pprPs (TcgPsInst instd) = ppr instd
+
+ pprRn (TcgRn { tcg_rn_tyclds = tyclds
+ , tcg_rn_roles = roles
+ , tcg_rn_kisigs = kisigs
+ , tcg_rn_instds = instds
+ })
+ = hang (text "TyClGroup") 2 $
+ ppr kisigs $$
+ ppr tyclds $$
+ ppr roles $$
+ ppr instds
pp_vanilla_decl_head :: (OutputableBndrId p)
=> Located (IdP (GhcPass p))
@@ -965,31 +998,88 @@ See Note [Dependency analysis of type, class, and instance decls]
in GHC.Rename.Source for more info.
-}
--- | Type or Class Group
-data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
- = TyClGroup { group_ext :: XCTyClGroup pass
- , group_tyclds :: [LTyClDecl pass]
- , group_roles :: [LRoleAnnotDecl pass]
- , group_kisigs :: [LStandaloneKindSig pass]
- , group_instds :: [LInstDecl pass] }
- | XTyClGroup (XXTyClGroup pass)
-
-type instance XCTyClGroup (GhcPass _) = NoExtField
-type instance XXTyClGroup (GhcPass _) = NoExtCon
-
-
-tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]
-tyClGroupTyClDecls = concatMap group_tyclds
-
-tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]
-tyClGroupInstDecls = concatMap group_instds
-
-tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
-tyClGroupRoleDecls = concatMap group_roles
-
-tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]
-tyClGroupKindSigs = concatMap group_kisigs
+-- | Renamed declaration header (left-hand side of a declaration):
+--
+-- 1. data T a b = MkT (a -> b)
+-- ^^^^^^^^^^
+--
+-- 2. class C a where
+-- ^^^^^^^^^
+--
+-- 3. type family F a b :: r where
+-- ^^^^^^^^^^^^^^^^^^^^^^
+--
+-- Supplies arity and flavor information not covered by a standalone kind
+-- signature.
+--
+data DeclHeaderRn
+ = DeclHeaderRn
+ { decl_header_flav :: TyConFlavour,
+ decl_header_name :: Located (IdP GhcRn),
+ decl_header_bndrs :: LHsQTyVars GhcRn,
+ decl_header_res_sig :: Maybe (LHsType GhcRn)
+ }
+-- | Type or Class Group
+data family TyClGroup pass
+
+data instance TyClGroup GhcPs
+ = TcgPsDecl (LTyClDecl GhcPs)
+ | TcgPsRole (LRoleAnnotDecl GhcPs)
+ | TcgPsKiSig (LStandaloneKindSig GhcPs)
+ | TcgPsInst (LInstDecl GhcPs)
+
+-- | Declaration signature (CUSK or SAKS).
+data DeclSigRn
+ = DeclSigRnCUSK
+ (Located DeclHeaderRn) -- Complete user-specified kind (CUSK)
+ | DeclSigRnSAKS
+ (Located DeclHeaderRn) -- Not necessarily a CUSK
+ (LStandaloneKindSig GhcRn) -- Standalone kind signature (SAKS)
+
+instance Outputable DeclSigRn where
+ ppr (DeclSigRnCUSK hdr) = text "CUSK:" <+> ppr (decl_header_name (unLoc hdr))
+ ppr (DeclSigRnSAKS _ sig) = ppr sig
+
+-- See Note [TyClGroups and dependency analysis]
+data instance TyClGroup GhcRn =
+ TcgRn { tcg_rn_tyclds :: [LTyClDecl GhcRn]
+ , tcg_rn_roles :: [LRoleAnnotDecl GhcRn]
+ , tcg_rn_kisigs :: [DeclSigRn]
+ , tcg_rn_instds :: [LInstDecl GhcRn] }
+
+newtype instance TyClGroup GhcTc = TcgTc Void
+
+tcg_tc_absurd :: TyClGroup GhcTc -> a
+tcg_tc_absurd (TcgTc a) = absurd a
+
+tyClGroupTyClDecls :: forall p. IsPass p => [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)]
+tyClGroupTyClDecls = concatMap $ \tcg ->
+ case ghcPass @p of
+ GhcPs -> [a | TcgPsDecl a <- [tcg] ]
+ GhcRn -> tcg_rn_tyclds tcg
+ GhcTc -> tcg_tc_absurd tcg
+
+tyClGroupInstDecls :: forall p. IsPass p => [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)]
+tyClGroupInstDecls = concatMap $ \tcg ->
+ case ghcPass @p of
+ GhcPs -> [a | TcgPsInst a <- [tcg] ]
+ GhcRn -> tcg_rn_instds tcg
+ GhcTc -> tcg_tc_absurd tcg
+
+tyClGroupRoleDecls :: forall p. IsPass p => [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)]
+tyClGroupRoleDecls = concatMap $ \tcg ->
+ case ghcPass @p of
+ GhcPs -> [a | TcgPsRole a <- [tcg] ]
+ GhcRn -> tcg_rn_roles tcg
+ GhcTc -> tcg_tc_absurd tcg
+
+tyClGroupKindSigs :: forall p. IsPass p => [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)]
+tyClGroupKindSigs = concatMap $ \tcg ->
+ case ghcPass @p of
+ GhcPs -> [a | TcgPsKiSig a <- [tcg] ]
+ GhcRn -> [a | DeclSigRnSAKS _ a <- tcg_rn_kisigs tcg ]
+ GhcTc -> tcg_tc_absurd tcg
{- *********************************************************************
* *
@@ -1145,6 +1235,27 @@ data FamilyInfo pass
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
+getFamFlav
+ :: Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
+ -> FamilyInfo pass
+ -> TyConFlavour
+getFamFlav mb_parent_tycon info =
+ case info of
+ DataFamily -> DataFamilyFlavour mb_parent_tycon
+ OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
+ ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]
+ ClosedTypeFamilyFlavour
+
+{- Note [Closed type family mb_parent_tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's no way to write a closed type family inside a class declaration:
+
+ class C a where
+ type family F a where -- error: parse error on input ‘where’
+
+In fact, it is not clear what the meaning of such a declaration would be.
+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.
+-}
------------- Functions over FamilyDecls -----------
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Hs.Extension where
import GhcPrelude
import Data.Data hiding ( Fixity )
+import Data.Semigroup
import Name
import RdrName
import Var
@@ -143,6 +144,12 @@ data NoExtField = NoExtField
instance Outputable NoExtField where
ppr _ = text "NoExtField"
+instance Semigroup NoExtField where
+ _ <> _ = NoExtField
+
+instance Monoid NoExtField where
+ mempty = NoExtField
+
-- | Used when constructing a term with an unused extension point.
noExtField :: NoExtField
noExtField = NoExtField
@@ -375,11 +382,6 @@ type family XDataDecl x
type family XClassDecl x
type family XXTyClDecl x
--- -------------------------------------
--- TyClGroup type families
-type family XCTyClGroup x
-type family XXTyClGroup x
-
-- -------------------------------------
-- FamilyResultSig type families
type family XNoSig x
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -104,6 +104,8 @@ deriving instance Data (HsDecl GhcPs)
deriving instance Data (HsDecl GhcRn)
deriving instance Data (HsDecl GhcTc)
+deriving instance Data KindedDecls
+
-- deriving instance (DataIdLR p p) => Data (HsGroup p)
deriving instance Data (HsGroup GhcPs)
deriving instance Data (HsGroup GhcRn)
@@ -119,6 +121,9 @@ deriving instance Data (TyClDecl GhcPs)
deriving instance Data (TyClDecl GhcRn)
deriving instance Data (TyClDecl GhcTc)
+deriving instance Data DeclHeaderRn
+deriving instance Data DeclSigRn
+
-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
deriving instance Data (TyClGroup GhcPs)
deriving instance Data (TyClGroup GhcRn)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1154,9 +1154,9 @@ hsTyClForeignBinders :: [TyClGroup GhcRn]
hsTyClForeignBinders tycl_decls foreign_decls
= map unLoc (hsForeignDeclsBinders foreign_decls)
++ getSelectorNames
- (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
+ (foldMap hsLTyClDeclBinders (tyClGroupTyClDecls tycl_decls)
`mappend`
- foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
+ foldMap hsLInstDeclBinders (tyClGroupInstDecls tycl_decls))
where
getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
=====================================
compiler/GHC/HsToCore/PmCheck/Oracle.hs
=====================================
@@ -51,7 +51,6 @@ import GHC.Core.Make (mkListExpr, mkCharExpr)
import UniqSupply
import FastString
import SrcLoc
-import ListSetOps (unionLists)
import Maybes
import GHC.Core.ConLike
import GHC.Core.DataCon
@@ -613,9 +612,6 @@ Maintaining these invariants in 'addVarCt' (the core of the term oracle) and
- (Refine) If we had @x /~ K zs@, unify each y with each z in turn.
* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addNotConCt')
- (Refut) If we have @x ~ K ys@, refute.
- - (Redundant) If we have @x ~ K2@ and @eqPmAltCon K K2 == Disjoint@
- (ex. Just and Nothing), the info is redundant and can be
- discarded.
- (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get
@x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in
COMPLETE set, so should refute.
@@ -655,7 +651,7 @@ tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM addTmCt delta new_
-- * Looking up VarInfo
emptyVarInfo :: Id -> VarInfo
-emptyVarInfo x = VI (idType x) [] [] NoPM
+emptyVarInfo x = VI (idType x) [] emptyPmAltConSet NoPM
lookupVarInfo :: TmState -> Id -> VarInfo
-- (lookupVarInfo tms x) tells what we know about 'x'
@@ -754,7 +750,7 @@ TyCon, so tc_rep = tc_fam afterwards.
canDiverge :: Delta -> Id -> Bool
canDiverge delta at MkDelta{ delta_tm_st = ts } x
| VI _ pos neg _ <- lookupVarInfo ts x
- = null neg && all pos_can_diverge pos
+ = isEmptyPmAltConSet neg && all pos_can_diverge pos
where
pos_can_diverge (PmAltConLike (RealDataCon dc), _, [y])
-- See Note [Divergence of Newtype matches]
@@ -793,8 +789,8 @@ lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]
lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =
case lookupUDFM env k of
Nothing -> []
- Just (Indirect y) -> vi_neg (lookupVarInfo ts y)
- Just (Entry vi) -> vi_neg vi
+ Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y))
+ Just (Entry vi) -> pmAltConSetElems (vi_neg vi)
isDataConSolution :: (PmAltCon, [TyVar], [Id]) -> Bool
isDataConSolution (PmAltConLike (RealDataCon _), _, _) = True
@@ -937,7 +933,7 @@ addNotConCt delta at MkDelta{ delta_tm_st = TmSt env reps } x nalt = do
| any (implies nalt) pos = neg
-- See Note [Completeness checking with required Thetas]
| hasRequiredTheta nalt = neg
- | otherwise = unionLists neg [nalt]
+ | otherwise = extendPmAltConSet neg nalt
let vi_ext = vi{ vi_neg = neg' }
-- 3. Make sure there's at least one other possible constructor
vi' <- case nalt of
@@ -1129,7 +1125,7 @@ equate delta at MkDelta{ delta_tm_st = TmSt env reps } x y
delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)
-- Do the same for negative info
let add_refut delta nalt = addNotConCt delta y nalt
- delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x)
+ delta_neg <- foldlM add_refut delta_pos (pmAltConSetElems (vi_neg vi_x))
-- vi_cache will be updated in addNotConCt, so we are good to
-- go!
pure delta_neg
@@ -1144,7 +1140,7 @@ addConCt :: Delta -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Delta
addConCt delta at MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do
VI ty pos neg cache <- lift (initLookupVarInfo delta x)
-- First try to refute with a negative fact
- guard (all ((/= Equal) . eqPmAltCon alt) neg)
+ guard (not (elemPmAltConSet alt neg))
-- Then see if any of the other solutions (remember: each of them is an
-- additional refinement of the possible values x could take) indicate a
-- contradiction
@@ -1160,11 +1156,8 @@ addConCt delta at MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do
let tm_cts = zipWithEqual "addConCt" PmVarCt args other_args
MaybeT $ addPmCts delta (listToBag ty_cts `unionBags` listToBag tm_cts)
Nothing -> do
- -- Filter out redundant negative facts (those that compare Just False to
- -- the new solution)
- let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg
let pos' = (alt, tvs, args):pos
- pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps}
+ pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg cache)) reps}
equateTys :: [Type] -> [Type] -> [PmCt]
equateTys ts us =
@@ -1553,7 +1546,7 @@ provideEvidence = go
[]
-- When there are literals involved, just print negative info
-- instead of listing missed constructors
- | notNull [ l | PmAltLit l <- neg ]
+ | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]
-> go xs n delta
[] -> try_instantiate x xs n delta
=====================================
compiler/GHC/HsToCore/PmCheck/Types.hs
=====================================
@@ -24,6 +24,10 @@ module GHC.HsToCore.PmCheck.Types (
-- * Caching partially matched COMPLETE sets
ConLikeSet, PossibleMatches(..),
+ -- * PmAltConSet
+ PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,
+ extendPmAltConSet, pmAltConSetElems,
+
-- * A 'DIdEnv' where entries may be shared
Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE,
setIndirectSDIE, setEntrySDIE, traverseSDIE,
@@ -49,6 +53,7 @@ import Name
import GHC.Core.DataCon
import GHC.Core.ConLike
import Outputable
+import ListSetOps (unionLists)
import Maybes
import GHC.Core.Type
import GHC.Core.TyCon
@@ -152,6 +157,33 @@ eqConLike _ _ = PossiblyOverlap
data PmAltCon = PmAltConLike ConLike
| PmAltLit PmLit
+data PmAltConSet = PACS !ConLikeSet ![PmLit]
+
+emptyPmAltConSet :: PmAltConSet
+emptyPmAltConSet = PACS emptyUniqDSet []
+
+isEmptyPmAltConSet :: PmAltConSet -> Bool
+isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits
+
+-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to
+-- the given 'PmAltCon' according to 'eqPmAltCon'.
+elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
+elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls
+elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits
+
+extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
+extendPmAltConSet (PACS cls lits) (PmAltConLike cl)
+ = PACS (addOneToUniqDSet cls cl) lits
+extendPmAltConSet (PACS cls lits) (PmAltLit lit)
+ = PACS cls (unionLists lits [lit])
+
+pmAltConSetElems :: PmAltConSet -> [PmAltCon]
+pmAltConSetElems (PACS cls lits)
+ = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits
+
+instance Outputable PmAltConSet where
+ ppr = ppr . pmAltConSetElems
+
-- | We can't in general decide whether two 'PmAltCon's match the same set of
-- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a
-- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'.
@@ -475,7 +507,7 @@ data VarInfo
-- However, no more than one RealDataCon in the list, otherwise contradiction
-- because of generativity.
- , vi_neg :: ![PmAltCon]
+ , vi_neg :: !PmAltConSet
-- ^ Negative info: A list of 'PmAltCon's that it cannot match.
-- Example, assuming
--
@@ -489,6 +521,9 @@ data VarInfo
-- between 'vi_pos' and 'vi_neg'.
-- See Note [Why record both positive and negative info?]
+ -- It's worth having an actual set rather than a simple association list,
+ -- because files like Cabal's `LicenseId` define relatively huge enums
+ -- that lead to quadratic or worse behavior.
, vi_cache :: !PossibleMatches
-- ^ A cache of the associated COMPLETE sets. At any time a superset of
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -270,7 +270,7 @@ repTopDs group@(HsGroup { hs_valds = valds
= do { let { bndrs = hsScopedTvBinders valds
++ hsGroupBinders group
++ hsPatSynSelectors valds
- ; instds = tyclds >>= group_instds } ;
+ ; instds = tyClGroupInstDecls tyclds } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -284,8 +284,8 @@ repTopDs group@(HsGroup { hs_valds = valds
do { val_ds <- rep_val_binds valds
; _ <- mapM no_splice splcds
; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)
- ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
- ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
+ ; role_ds <- mapM repRoleD (tyClGroupRoleDecls tyclds)
+ ; kisig_ds <- mapM repKiSigD (tyClGroupKindSigs tyclds)
; inst_ds <- mapM repInstD instds
; deriv_ds <- mapM repStandaloneDerivD derivds
; fix_ds <- mapM repLFixD fixds
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1261,17 +1261,16 @@ instance ( a ~ GhcPass p
XCmd _ -> []
instance ToHie (TyClGroup GhcRn) where
- toHie TyClGroup{ group_tyclds = classes
- , group_roles = roles
- , group_kisigs = sigs
- , group_instds = instances } =
+ toHie TcgRn{ tcg_rn_tyclds = classes
+ , tcg_rn_roles = roles
+ , tcg_rn_kisigs = sigs
+ , tcg_rn_instds = instances } =
concatM
[ toHie classes
- , toHie sigs
+ , toHie [a | DeclSigRnSAKS _ a <- sigs ]
, toHie roles
, toHie instances
]
- toHie (XTyClGroup _) = pure []
instance ToHie (LTyClDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -669,7 +669,7 @@ getLocalNonValBinders fixity_env
hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
= do { -- Process all type/class decls *except* family instances
- ; let inst_decls = tycl_decls >>= group_instds
+ ; let inst_decls = tyClGroupInstDecls tycl_decls
; overload_ok <- xoptM LangExt.DuplicateRecordFields
; (tc_avails, tc_fldss)
<- fmap unzip $ mapM (new_tc overload_ok)
=====================================
compiler/GHC/Rename/Source.hs
=====================================
@@ -52,6 +52,7 @@ import PrelNames ( applicativeClassName, pureAName, thenAName
import Name
import NameSet
import NameEnv
+import GHC.Core.TyCon ( TyConFlavour(..) )
import Avail
import Outputable
import Bag
@@ -59,7 +60,8 @@ import BasicTypes ( pprRuleName, TypeOrKind(..) )
import FastString
import SrcLoc
import GHC.Driver.Session
-import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith )
+import Util ( debugIsOn, filterOut, lengthExceeds,
+ partitionWith, (<&&>) )
import GHC.Driver.Types ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
@@ -160,7 +162,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
- (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
+ (rn_tycl_decls, kinded_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn "Start rnmono" empty ;
@@ -202,7 +204,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
- let {rn_group = HsGroup { hs_ext = noExtField,
+ let {rn_group = HsGroup { hs_ext = kinded_decls,
hs_valds = rn_val_decls,
hs_splcds = rn_splice_decls,
hs_tyclds = rn_tycl_decls,
@@ -1287,7 +1289,7 @@ constructors] in TcEnv
rnTyClDecls :: [TyClGroup GhcPs]
- -> RnM ([TyClGroup GhcRn], FreeVars)
+ -> RnM ([TyClGroup GhcRn], KindedDecls, FreeVars)
-- Rename the declarations and do dependency analysis on them
rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declaraations
@@ -1297,25 +1299,32 @@ rnTyClDecls tycl_ds
; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+ ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
+ -- See Note [CUSKs and PolyKinds] in TcTyClsDecls
+ ; let (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
+ decl_sig_list =
+ mapMaybe (mkDeclSigRn cusks_enabled kisig_env . fst) $
+ tycls_w_fvs
+ decl_sig_env = mkNameEnv decl_sig_list
+ kinded_decls = KindedDecls (mkNameSet (map fst decl_sig_list))
+
-- Do SCC analysis on the type/class decls
; rdr_env <- getGlobalRdrEnv
; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
role_annot_env = mkRoleAnnotEnv role_annots
- (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
(init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
first_group
| null init_inst_ds = []
- | otherwise = [TyClGroup { group_ext = noExtField
- , group_tyclds = []
- , group_kisigs = []
- , group_roles = []
- , group_instds = init_inst_ds }]
+ | otherwise = [TcgRn { tcg_rn_tyclds = []
+ , tcg_rn_kisigs = []
+ , tcg_rn_roles = []
+ , tcg_rn_instds = init_inst_ds }]
(final_inst_ds, groups)
- = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
+ = mapAccumL (mk_group role_annot_env decl_sig_env) rest_inst_ds tycl_sccs
all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
@@ -1327,26 +1336,87 @@ rnTyClDecls tycl_ds
$$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
- ; return (all_groups, all_fvs) }
+ ; return (all_groups, kinded_decls, all_fvs) }
where
mk_group :: RoleAnnotEnv
- -> KindSigEnv
+ -> NameEnv DeclSigRn
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
- mk_group role_env kisig_env inst_map scc
+ mk_group role_env decl_sig_env inst_map scc
= (inst_map', group)
where
tycl_ds = flattenSCC scc
bndrs = map (tcdName . unLoc) tycl_ds
roles = getRoleAnnots bndrs role_env
- kisigs = getKindSigs bndrs kisig_env
+ decl_sigs = getDeclSigs bndrs decl_sig_env
(inst_ds, inst_map') = getInsts bndrs inst_map
- group = TyClGroup { group_ext = noExtField
- , group_tyclds = tycl_ds
- , group_kisigs = kisigs
- , group_roles = roles
- , group_instds = inst_ds }
+ group = TcgRn { tcg_rn_tyclds = tycl_ds
+ , tcg_rn_kisigs = decl_sigs
+ , tcg_rn_roles = roles
+ , tcg_rn_instds = inst_ds }
+
+mkDeclSigRn
+ :: Bool -- ^ CUSKs enabled
+ -> KindSigEnv
+ -> LTyClDecl GhcRn
+ -> Maybe (Name, DeclSigRn)
+mkDeclSigRn cusks_enabled kisig_env tcd
+ -- Stanadlone kind signature
+ | Just ki <- lookupNameEnv kisig_env name
+ = Just (name, DeclSigRnSAKS decl_header ki)
+ -- Complete user-supplied kind
+ | cusks_enabled && has_cusk
+ = Just (name, DeclSigRnCUSK decl_header)
+ -- No signature: needs inference
+ | otherwise
+ = Nothing
+ where
+ has_cusk = hsDeclHasCusk (unLoc tcd)
+ name = tcdName (unLoc tcd)
+ decl_header = mapLoc mkDeclHeaderRn tcd
+
+mkDeclHeaderRn :: TyClDecl GhcRn -> DeclHeaderRn
+mkDeclHeaderRn tcd = case tcd of
+ -- Class
+ ClassDecl { tcdLName = name, tcdTyVars = ktvs }
+ -> DeclHeaderRn
+ { decl_header_flav = ClassFlavour,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = Nothing }
+ -- Data/Newtype
+ DataDecl { tcdLName = name
+ , tcdTyVars = ktvs
+ , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+ , dd_ND = new_or_data } }
+ -> DeclHeaderRn
+ { decl_header_flav = newOrDataToFlavour new_or_data,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = m_sig }
+ -- Type/data family
+ FamDecl { tcdFam =
+ FamilyDecl { fdLName = name
+ , fdTyVars = ktvs
+ , fdResultSig = L _ resultSig
+ , fdInfo = info } }
+ -> DeclHeaderRn
+ { decl_header_flav = getFamFlav Nothing info,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = famResultKindSignature resultSig }
+ -- Type synonym
+ SynDecl { tcdLName = name, tcdTyVars = ktvs, tcdRhs = rhs }
+ -> DeclHeaderRn
+ { decl_header_flav = TypeSynonymFlavour,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = hsTyKindSig rhs }
+ -- Impossible cases
+ DataDecl _ _ _ _ (XHsDataDefn nec) -> noExtCon nec
+ FamDecl {tcdFam = XFamilyDecl nec} -> noExtCon nec
+ XTyClDecl nec -> noExtCon nec
-- | Free variables of standalone kind signatures.
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
@@ -1366,8 +1436,8 @@ mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
= mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
-getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
-getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
+getDeclSigs :: [Name] -> NameEnv DeclSigRn -> [DeclSigRn]
+getDeclSigs bndrs decl_sig_env = mapMaybe (lookupNameEnv decl_sig_env) bndrs
rnStandaloneKindSignatures
:: NameSet -- names of types and classes in the current TyClGroup
@@ -2306,7 +2376,7 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
-- Class declarations: added to the TyClGroup
add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds
- = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
+ = addl (gp { hs_tyclds = TcgPsDecl (L l d) : ts }) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
@@ -2314,7 +2384,7 @@ add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
-- Standalone kind signatures: added to the TyClGroup
add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds
- = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds
+ = addl (gp {hs_tyclds = TcgPsKiSig (L l s) : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
@@ -2325,13 +2395,13 @@ add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
-- Role annotations: added to the TyClGroup
add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
- = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
+ = addl (gp { hs_tyclds = TcgPsRole (L l d) : ts }) ds
-- NB instance declarations go into TyClGroups. We throw them into the first
-- group, just as we do for the TyClD case. The renamer will go on to group
-- and order them later.
add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds
- = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
+ = addl (gp { hs_tyclds = TcgPsInst (L l d) : ts }) ds
-- The rest are routine
add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds
@@ -2352,58 +2422,6 @@ add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec
add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec
add (XHsGroup nec) _ _ _ = noExtCon nec
-add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
- -> [TyClGroup (GhcPass p)]
-add_tycld d [] = [TyClGroup { group_ext = noExtField
- , group_tyclds = [d]
- , group_kisigs = []
- , group_roles = []
- , group_instds = []
- }
- ]
-add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
- = ds { group_tyclds = d : tyclds } : dss
-add_tycld _ (XTyClGroup nec: _) = noExtCon nec
-
-add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
- -> [TyClGroup (GhcPass p)]
-add_instd d [] = [TyClGroup { group_ext = noExtField
- , group_tyclds = []
- , group_kisigs = []
- , group_roles = []
- , group_instds = [d]
- }
- ]
-add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
- = ds { group_instds = d : instds } : dss
-add_instd _ (XTyClGroup nec: _) = noExtCon nec
-
-add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
- -> [TyClGroup (GhcPass p)]
-add_role_annot d [] = [TyClGroup { group_ext = noExtField
- , group_tyclds = []
- , group_kisigs = []
- , group_roles = [d]
- , group_instds = []
- }
- ]
-add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
- = tycls { group_roles = d : roles } : rest
-add_role_annot _ (XTyClGroup nec: _) = noExtCon nec
-
-add_kisig :: LStandaloneKindSig (GhcPass p)
- -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
-add_kisig d [] = [TyClGroup { group_ext = noExtField
- , group_tyclds = []
- , group_kisigs = [d]
- , group_roles = []
- , group_instds = []
- }
- ]
-add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)
- = tycls { group_kisigs = d : kisigs } : rest
-add_kisig _ (XTyClGroup nec : _) = noExtCon nec
-
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind"
=====================================
compiler/typecheck/TcEnv.hs
=====================================
@@ -464,7 +464,7 @@ tcLookupTcTyCon name = do
thing <- tcLookup name
case thing of
ATcTyCon tc -> return tc
- _ -> pprPanic "tcLookupTcTyCon" (ppr name)
+ _ -> pprPanic "tcLookupTcTyCon" (ppr name <+> text ":" <+> ppr thing)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
=====================================
compiler/typecheck/TcHsType.hs
=====================================
@@ -251,8 +251,8 @@ tcHsSigType ctxt sig_ty
skol_info = SigTypeSkol ctxt
-- Does validity checking and zonking.
-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
-tcStandaloneKindSig (L _ kisig) = case kisig of
+tcStandaloneKindSig :: StandaloneKindSig GhcRn -> TcM (Name, Kind)
+tcStandaloneKindSig kisig = case kisig of
StandaloneKindSig _ (L _ name) ksig ->
let ctxt = StandaloneKindSigCtxt name in
addSigCtxt ctxt (hsSigType ksig) $
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -625,7 +625,8 @@ tcRnHsBootDecls hsc_src decls
= do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
- ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
+ ; (tcg_env, HsGroup { hs_ext = kinded_decls
+ , hs_tyclds = tycl_decls
, hs_derivds = deriv_decls
, hs_fords = for_decls
, hs_defds = def_decls
@@ -653,7 +654,7 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds)
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+ <- tcTyClsInstDecls kinded_decls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
-- Emit Typeable bindings
@@ -1396,7 +1397,8 @@ rnTopSrcDecls group
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
+tcTopSrcDecls (HsGroup { hs_ext = kinded_decls,
+ hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
@@ -1412,7 +1414,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- tcTyClsInstDecls kinded_decls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
@@ -1681,7 +1683,8 @@ tcMissingParentClassWarn warnFlag isName shouldName
---------------------------
-tcTyClsInstDecls :: [TyClGroup GhcRn]
+tcTyClsInstDecls :: KindedDecls
+ -> [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, -- The full inst env
@@ -1691,11 +1694,11 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
-tcTyClsInstDecls tycl_decls deriv_decls binds
- = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
+tcTyClsInstDecls kinded_decls tycl_decls deriv_decls binds
+ = tcAddDataFamConPlaceholders (tyClGroupInstDecls tycl_decls) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { (tcg_env, inst_info, deriv_info)
- <- tcTyAndClassDecls tycl_decls ;
+ <- tcTyAndClassDecls kinded_decls tycl_decls ;
; setGblEnv tcg_env $ do {
-- With the @TyClDecl at s and @InstDecl at s checked we're ready to
-- process the deriving clauses, including data family deriving
=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -123,7 +123,25 @@ Thus, we take two passes over the resulting tycons, first checking for general
validity and then checking for valid role annotations.
-}
-tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
+-- | TcTyCons generated from SAKS/CUSKs, whose definitions occur in a later TyClGroup.
+newtype InterGroupEnv = InterGroupEnv (NameEnv TcTyCon)
+
+emptyInterGroupEnv :: InterGroupEnv
+emptyInterGroupEnv = InterGroupEnv emptyNameEnv
+
+extendInterGroupEnv :: [TcTyCon] -> InterGroupEnv -> InterGroupEnv
+extendInterGroupEnv tcs (InterGroupEnv env) = InterGroupEnv (extendNameEnvList env named_tcs)
+ where named_tcs = map (\tc -> (tyConName tc, tc)) tcs
+
+purgeInterGroupEnv :: [TcTyCon] -> InterGroupEnv -> InterGroupEnv
+purgeInterGroupEnv tcs (InterGroupEnv env) = InterGroupEnv (delListFromNameEnv env tcs_names)
+ where tcs_names = map tyConName tcs
+
+interGroupEnvTyCons :: InterGroupEnv -> [TcTyCon]
+interGroupEnvTyCons (InterGroupEnv env )= nameEnvElts env
+
+tcTyAndClassDecls :: KindedDecls
+ -> [TyClGroup GhcRn] -- Mutually-recursive groups in
-- dependency order
-> TcM ( TcGblEnv -- Input env extended by types and
-- classes
@@ -132,44 +150,58 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
, [DerivInfo] -- Deriving info
)
-- Fails if there are any errors
-tcTyAndClassDecls tyclds_s
+tcTyAndClassDecls kinded_decls tyclds_s
-- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
-- Type check each group in dependency order folding the global env
- = checkNoErrs $ fold_env [] [] tyclds_s
+ = checkNoErrs $ fold_env emptyInterGroupEnv [] [] tyclds_s
where
- fold_env :: [InstInfo GhcRn]
+ fold_env :: InterGroupEnv
+ -> [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
- fold_env inst_info deriv_info []
+ fold_env _ inst_info deriv_info []
= do { gbl_env <- getGblEnv
; return (gbl_env, inst_info, deriv_info) }
- fold_env inst_info deriv_info (tyclds:tyclds_s)
- = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+ fold_env inter_group_env inst_info deriv_info (tyclds:tyclds_s)
+ = do { (tcg_env, inter_group_env', inst_info', deriv_info') <-
+ tcTyClGroup kinded_decls inter_group_env tyclds
; setGblEnv tcg_env $
-- remaining groups are typechecked in the extended global env.
- fold_env (inst_info' ++ inst_info)
+ fold_env inter_group_env'
+ (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
tyclds_s }
-tcTyClGroup :: TyClGroup GhcRn
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+tcTyClGroup :: KindedDecls
+ -> InterGroupEnv
+ -> TyClGroup GhcRn
+ -> TcM (TcGblEnv, InterGroupEnv, [InstInfo GhcRn], [DerivInfo])
-- Typecheck one strongly-connected component of type, class, and instance decls
-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls
-tcTyClGroup (TyClGroup { group_tyclds = tyclds
- , group_roles = roles
- , group_kisigs = kisigs
- , group_instds = instds })
+tcTyClGroup kinded_decls inter_group_env
+ (TcgRn { tcg_rn_tyclds = tyclds
+ , tcg_rn_roles = roles
+ , tcg_rn_kisigs = kisigs
+ , tcg_rn_instds = instds })
= do { let role_annots = mkRoleAnnotEnv roles
-- Step 1: Typecheck the standalone kind signatures and type/class declarations
; traceTc "---- tcTyClGroup ---- {" empty
; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
- ; (tyclss, data_deriv_info) <-
+ ; (inter_group_env', tyclss, data_deriv_info) <-
tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
- do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
- ; tcTyClDecls tyclds kisig_env role_annots }
+ do { checked_tcs <-
+ tcExtendKindEnv (mkSigPromotionErrorEnv kisigs) $
+ traverse tcDeclSig kisigs
+ ; let extended_inter_group_env = extendInterGroupEnv checked_tcs inter_group_env
+ ; (tyclss, data_deriv_info) <-
+ tcExtendKindEnvWithTyCons (interGroupEnvTyCons extended_inter_group_env) $
+ tcTyClDecls tyclds kinded_decls role_annots
+ ; let purged_inter_group_env = purgeInterGroupEnv tyclss extended_inter_group_env
+ ; return (purged_inter_group_env, tyclss, data_deriv_info)
+ }
-- Step 1.5: Make sure we don't have any type synonym cycles
; traceTc "Starting synonym cycle check" (ppr tyclss)
@@ -200,24 +232,66 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
tcInstDecls1 instds
; let deriv_info = datafam_deriv_info ++ data_deriv_info
- ; return (gbl_env', inst_info, deriv_info) }
-
-
-tcTyClGroup (XTyClGroup nec) = noExtCon nec
+ ; return (gbl_env', inter_group_env', inst_info, deriv_info) }
+
+tcDeclSig :: DeclSigRn -> TcM TcTyCon
+tcDeclSig (DeclSigRnCUSK (L l hdr)) =
+ setSrcSpan l $ check_decl_sig CUSK hdr
+tcDeclSig (DeclSigRnSAKS (L l_hdr hdr) (L l_sig kisig)) = do
+ (_, ki) <- setSrcSpan l_sig $ tcStandaloneKindSig kisig
+ setSrcSpan l_hdr $ check_decl_sig (SAKS ki) hdr
+
+check_decl_sig :: SAKS_or_CUSK -> DeclHeaderRn -> TcM TcTyCon
+check_decl_sig msig hdr =
+ kcDeclHeader (InitialKindCheck msig) name flav (decl_header_bndrs hdr) $
+ if | flav == ClassFlavour
+ -> return (TheKind constraintKind)
+
+ | flav == DataTypeFlavour
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+ Nothing -> return $ dataDeclDefaultResultKind DataType
+
+ | flav == NewtypeFlavour
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+ Nothing -> return $ dataDeclDefaultResultKind NewType
+
+ | is_fam_flav flav
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (TyFamResKindCtxt name) ksig
+ Nothing ->
+ case msig of
+ CUSK -> return (TheKind liftedTypeKind)
+ SAKS _ -> return AnyKind
+
+ | flav == TypeSynonymFlavour
+ -> case res_sig of
+ Just rhs_sig -> TheKind <$> tcLHsKindSig (TySynKindCtxt name) rhs_sig
+ Nothing -> return AnyKind
+
+ | otherwise -> return AnyKind
+ where
+ L _ name = decl_header_name hdr
+ flav = decl_header_flav hdr
+ res_sig = decl_header_res_sig hdr
--- Gives the kind for every TyCon that has a standalone kind signature
-type KindSigEnv = NameEnv Kind
+is_fam_flav :: TyConFlavour -> Bool
+is_fam_flav DataFamilyFlavour{} = True
+is_fam_flav OpenTypeFamilyFlavour{} = True
+is_fam_flav ClosedTypeFamilyFlavour = True
+is_fam_flav _ = False
tcTyClDecls
:: [LTyClDecl GhcRn]
- -> KindSigEnv
+ -> KindedDecls
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo])
-tcTyClDecls tyclds kisig_env role_annots
+tcTyClDecls tyclds kinded_decls role_annots
= do { -- Step 1: kind-check this group and returns the final
-- (possibly-polymorphic) kind of each TyCon and Class
-- See Note [Kind checking for type and class decls]
- tc_tycons <- kcTyClGroup kisig_env tyclds
+ tc_tycons <- kcTyClGroup kinded_decls tyclds
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-- Step 2: type-check all groups together, returning
@@ -618,13 +692,13 @@ been generalized.
-}
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+kcTyClGroup :: KindedDecls -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
-- Kind check this group, kind generalize, and return the resulting local env
-- This binds the TyCons and Classes of the group, but not the DataCons
-- See Note [Kind checking for type and class decls]
-- and Note [Inferring kinds for type declarations]
-kcTyClGroup kisig_env decls
+kcTyClGroup kd_set decls
= do { mod <- getModule
; traceTc "---- kcTyClGroup ---- {"
(text "module" <+> ppr mod $$ vcat (map ppr decls))
@@ -635,22 +709,16 @@ kcTyClGroup kisig_env decls
-- 3. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls]
- ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
- -- See Note [CUSKs and PolyKinds]
; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
- get_kind d
- | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))
- = Right (d, SAKS ki)
+ get_kind (L l d)
+ | isKindedDecl kd_set d = Right d
+ | otherwise = Left (L l d)
- | cusks_enabled && hsDeclHasCusk (unLoc d)
- = Right (d, CUSK)
-
- | otherwise = Left d
-
- ; checked_tcs <- checkInitialKinds kinded_decls
+ ; (checked_tcs, concat -> checked_assoc_tcs) <-
+ mapAndUnzipM checkKindedDecl kinded_decls
; inferred_tcs
- <- tcExtendKindEnvWithTyCons checked_tcs $
+ <- tcExtendKindEnvWithTyCons checked_assoc_tcs $
pushTcLevelM_ $ -- We are going to kind-generalise, so
-- unification variables in here must
-- be one level in
@@ -679,7 +747,7 @@ kcTyClGroup kisig_env decls
; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)
kindless_decls
- ; let poly_tcs = checked_tcs ++ generalized_tcs
+ ; let poly_tcs = checked_tcs ++ checked_assoc_tcs ++ generalized_tcs
; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
; return poly_tcs }
where
@@ -1254,6 +1322,21 @@ mk_prom_err_env decl
= unitNameEnv (tcdName decl) (APromotionErr TyConPE)
-- Works for family declarations too
+mkSigPromotionErrorEnv :: [DeclSigRn] -> TcTypeEnv
+mkSigPromotionErrorEnv =
+ foldr (plusNameEnv . mk_sig_prom_err_env) emptyNameEnv
+
+mk_sig_prom_err_env :: DeclSigRn -> TcTypeEnv
+mk_sig_prom_err_env sig =
+ unitNameEnv (unLoc (decl_header_name hdr))
+ (case decl_header_flav hdr of
+ ClassFlavour -> APromotionErr ClassPE
+ _ -> APromotionErr TyConPE)
+ where
+ hdr = case sig of
+ DeclSigRnCUSK (L _ h) -> h
+ DeclSigRnSAKS (L _ h) _ -> h
+
--------------
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
-- Returns a TcTyCon for each TyCon bound by the decls,
@@ -1261,27 +1344,24 @@ inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
inferInitialKinds decls
= do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)
- ; tcs <- concatMapM infer_initial_kind decls
+ ; tcs <- concatMapM (addLocM inferInitialKind) decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
- where
- infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
-
--- Check type/class declarations against their standalone kind signatures or
--- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
-checkInitialKinds decls
- = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
- ; tcs <- concatMapM check_initial_kind decls
- ; traceTc "checkInitialKinds done }" empty
- ; return tcs }
- where
- check_initial_kind (ldecl, msig) =
- addLocM (getInitialKind (InitialKindCheck msig)) ldecl
--- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
--- depending on the 'InitialKindStrategy'.
-getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
+checkKindedDecl :: TyClDecl GhcRn -> TcM (TcTyCon, [TcTyCon])
+checkKindedDecl (ClassDecl { tcdLName = L _ name , tcdATs = ats })
+ = do { cls <- tcLookupTcTyCon name
+ ; let parent_tv_prs = tcTyConScopedTyVars cls
+ ; inner_tcs <-
+ tcExtendNameTyVarEnv parent_tv_prs $
+ mapM (addLocM (check_initial_kind_assoc_fam cls)) ats
+ ; return (cls, inner_tcs) }
+checkKindedDecl d
+ = do { tc <- tcLookupTcTyCon (tcdName d)
+ ; return (tc, []) }
+
+-- | Get the initial, non-generalized kind of a TyClDecl.
+inferInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
-- Allocate a fresh kind variable for each TyCon and Class
-- For each tycon, return a TcTyCon with kind k
@@ -1296,71 +1376,49 @@ getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
-- * The result kinds signature on a TyClDecl
--
-- No family instances are passed to checkInitialKinds/inferInitialKinds
-getInitialKind strategy
+inferInitialKind
(ClassDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdATs = ats })
- = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $
+ = do { cls <- kcDeclHeader InitialKindInfer name ClassFlavour ktvs $
return (TheKind constraintKind)
; let parent_tv_prs = tcTyConScopedTyVars cls
-- See Note [Don't process associated types in getInitialKind]
; inner_tcs <-
tcExtendNameTyVarEnv parent_tv_prs $
- mapM (addLocM (getAssocFamInitialKind cls)) ats
+ mapM (addLocM (get_fam_decl_initial_kind (Just cls))) ats
; return (cls : inner_tcs) }
- where
- getAssocFamInitialKind cls =
- case strategy of
- InitialKindInfer -> get_fam_decl_initial_kind (Just cls)
- InitialKindCheck _ -> check_initial_kind_assoc_fam cls
-getInitialKind strategy
+inferInitialKind
(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_ND = new_or_data } })
= do { let flav = newOrDataToFlavour new_or_data
ctxt = DataKindCtxt name
- ; tc <- kcDeclHeader strategy name flav ktvs $
+ ; tc <- kcDeclHeader InitialKindInfer name flav ktvs $
case m_sig of
Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
Nothing -> return $ dataDeclDefaultResultKind new_or_data
; return [tc] }
-getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })
+inferInitialKind (FamDecl { tcdFam = decl })
= do { tc <- get_fam_decl_initial_kind Nothing decl
; return [tc] }
-getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =
- FamilyDecl { fdLName = unLoc -> name
- , fdTyVars = ktvs
- , fdResultSig = unLoc -> resultSig
- , fdInfo = info } } )
- = do { let flav = getFamFlav Nothing info
- ctxt = TyFamResKindCtxt name
- ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $
- case famResultKindSignature resultSig of
- Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
- Nothing ->
- case msig of
- CUSK -> return (TheKind liftedTypeKind)
- SAKS _ -> return AnyKind
- ; return [tc] }
-
-getInitialKind strategy
+inferInitialKind
(SynDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdRhs = rhs })
= do { let ctxt = TySynKindCtxt name
- ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $
+ ; tc <- kcDeclHeader InitialKindInfer name TypeSynonymFlavour ktvs $
case hsTyKindSig rhs of
Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig
Nothing -> return AnyKind
; return [tc] }
-getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
-getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
-getInitialKind _ (XTyClDecl nec) = noExtCon nec
+inferInitialKind (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
+inferInitialKind (XTyClDecl nec) = noExtCon nec
get_fam_decl_initial_kind
:: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
@@ -1473,29 +1531,6 @@ See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note
<Error Messages>.
-}
----------------------------------
-getFamFlav
- :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
- -> FamilyInfo pass
- -> TyConFlavour
-getFamFlav mb_parent_tycon info =
- case info of
- DataFamily -> DataFamilyFlavour mb_parent_tycon
- OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
- ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]
- ClosedTypeFamilyFlavour
-
-{- Note [Closed type family mb_parent_tycon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's no way to write a closed type family inside a class declaration:
-
- class C a where
- type family F a where -- error: parse error on input ‘where’
-
-In fact, it is not clear what the meaning of such a declaration would be.
-Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.
--}
-
------------------------------------------------------------------------
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
-- See Note [Kind checking for type and class decls]
=====================================
docs/users_guide/exts/ffi.rst
=====================================
@@ -37,31 +37,51 @@ Guaranteed call safety
~~~~~~~~~~~~~~~~~~~~~~
The Haskell 2010 Report specifies that ``safe`` FFI calls must allow foreign
-calls to safely call into Haskell code. In practice, this means that the
-garbage collector must be able to run while these calls are in progress,
-moving heap-allocated Haskell values around arbitrarily.
+calls to safely call into Haskell code. In practice, this means that called
+functions also have to assume heap-allocated Haskell values may move around
+arbitrarily in order to allow for GC.
This greatly constrains library authors since it implies that it is not safe to
pass any heap object reference to a ``safe`` foreign function call. For
-instance, it is often desirable to pass an :ref:`unpinned <pinned-byte-arrays>`
+instance, it is often desirable to pass :ref:`unpinned <pinned-byte-arrays>`
``ByteArray#``\s directly to native code to avoid making an otherwise-unnecessary
-copy. However, this can only be done safely if the array is guaranteed not to be
-moved by the garbage collector in the middle of the call.
+copy. However, this can not be done safely for ``safe`` calls since the array might
+be moved by the garbage collector in the middle of the call.
-The Chapter does *not* require implementations to refrain from doing the
-same for ``unsafe`` calls, so strictly Haskell 2010-conforming programs
+The Chapter *does* allow for implementations to move objects around during
+``unsafe`` calls as well. So strictly Haskell 2010-conforming programs
cannot pass heap-allocated references to ``unsafe`` FFI calls either.
+GHC, since version 8.4, **guarantees** that garbage collection will never occur
+during an ``unsafe`` call, even in the bytecode interpreter, and further guarantees
+that ``unsafe`` calls will be performed in the calling thread. Making it safe to
+pass heap-allocated objects to unsafe functions.
+
In previous releases, GHC would take advantage of the freedom afforded by the
Chapter by performing ``safe`` foreign calls in place of ``unsafe`` calls in
the bytecode interpreter. This meant that some packages which worked when
-compiled would fail under GHCi (e.g. :ghc-ticket:`13730`).
+compiled would fail under GHCi (e.g. :ghc-ticket:`13730`). But this is no
+longer the case in recent releases.
+
+Interactions between ``safe`` calls and bound threads
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A ``safe`` call calling into haskell is run on a bound thread by
+the RTS. This means any nesting of ``safe`` calls will be executed on
+the same operating system thread. *Sequential* ``safe`` calls however
+do not enjoy this luxury and may be run on arbitrary OS threads.
-However, since version 8.4 this is no longer the case: GHC **guarantees** that
-garbage collection will never occur during an ``unsafe`` call, even in the
-bytecode interpreter, and further guarantees that ``unsafe`` calls will be
-performed in the calling thread.
+This behaviour is considered an implementation detail and code relying on
+thread local state should instead use one of the interfaces provided
+in :base-ref:`Control.Concurrent.` to make this explicit.
+For information on what bound threads are,
+see the documentation for the :base-ref:`Control.Concurrent.`.
+
+For more details on the implementation see the Paper:
+"Extending the Haskell Foreign Function Interface with Concurrency".
+Last known to be accessible `here
+<https://www.microsoft.com/en-us/research/wp-content/uploads/2004/09/conc-ffi.pdf>`_.
.. _ffi-ghcexts:
@@ -100,7 +120,7 @@ restrictions:
of heap objects record writes for the purpose of garbage collection.
An array of heap objects is passed to a foreign C function, the
runtime does not record any writes. Consequently, it is not safe to
- write to an array of heap objects in a foreign function.
+ write to an array of heap objects in a foreign function.
Since the runtime has no facilities for tracking mutation of a
``MutableByteArray#``, these can be safely mutated in any foreign
function.
@@ -169,7 +189,7 @@ In other situations, the C function may need knowledge of the RTS
closure types. The following example sums the first element of
each ``ByteArray#`` (interpreting the bytes as an array of ``CInt``)
element of an ``ArrayArray##`` [3]_::
-
+
// C source, must include the RTS to make the struct StgArrBytes
// available along with its fields: ptrs and payload.
#include "Rts.h"
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -4,7 +4,12 @@
(Just
((,,,)
(HsGroup
- (NoExtField)
+ (KindedDecls
+ {NameSet:
+ [{Name: DumpRenamedAst.F1}
+ ,{Name: DumpRenamedAst.Length}
+ ,{Name: DumpRenamedAst.Nat}
+ ,{Name: DumpRenamedAst.Peano}]})
(XValBindsLR
(NValBinds
[((,)
@@ -56,8 +61,7 @@
[]))]})]
[]))
[]
- [(TyClGroup
- (NoExtField)
+ [(TcgRn
[({ DumpRenamedAst.hs:9:1-30 }
(DataDecl
(DataDeclRn
@@ -109,10 +113,18 @@
({ <no location info> }
[]))))]
[]
- []
+ [(DeclSigRnCUSK
+ ({ DumpRenamedAst.hs:9:1-30 }
+ (DeclHeaderRn
+ (DataTypeFlavour)
+ ({ DumpRenamedAst.hs:9:6-10 }
+ {Name: DumpRenamedAst.Peano})
+ (HsQTvs
+ []
+ [])
+ (Nothing))))]
[])
- ,(TyClGroup
- (NoExtField)
+ ,(TcgRn
[({ DumpRenamedAst.hs:11:1-39 }
(FamDecl
(NoExtField)
@@ -229,10 +241,37 @@
{Name: DumpRenamedAst.Peano})))))
(Nothing))))]
[]
- []
+ [(DeclSigRnCUSK
+ ({ DumpRenamedAst.hs:11:1-39 }
+ (DeclHeaderRn
+ (ClosedTypeFamilyFlavour)
+ ({ DumpRenamedAst.hs:11:13-18 }
+ {Name: DumpRenamedAst.Length})
+ (HsQTvs
+ [{Name: k}]
+ [({ DumpRenamedAst.hs:11:21-29 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:11:21-22 }
+ {Name: as})
+ ({ DumpRenamedAst.hs:11:27-29 }
+ (HsListTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:11:28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:11:28 }
+ {Name: k})))))))])
+ (Just
+ ({ DumpRenamedAst.hs:11:35-39 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:11:35-39 }
+ {Name: DumpRenamedAst.Peano})))))))]
[])
- ,(TyClGroup
- (NoExtField)
+ ,(TcgRn
[({ DumpRenamedAst.hs:15:1-33 }
(FamDecl
(NoExtField)
@@ -274,7 +313,41 @@
{Name: GHC.Types.Type})))))))))
(Nothing))))]
[]
- []
+ [(DeclSigRnCUSK
+ ({ DumpRenamedAst.hs:15:1-33 }
+ (DeclHeaderRn
+ (DataFamilyFlavour
+ (Nothing))
+ ({ DumpRenamedAst.hs:15:13-15 }
+ {Name: DumpRenamedAst.Nat})
+ (HsQTvs
+ [{Name: k}]
+ [])
+ (Just
+ ({ DumpRenamedAst.hs:15:20-33 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:15:20 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:20 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:15:25-33 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:15:25 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:25 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:15:30-33 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:30-33 }
+ {Name: GHC.Types.Type})))))))))))]
[({ DumpRenamedAst.hs:(18,1)-(19,45) }
(DataFamInstD
(NoExtField)
@@ -435,8 +508,7 @@
(Nothing)))]
({ <no location info> }
[])))))))])
- ,(TyClGroup
- (NoExtField)
+ ,(TcgRn
[({ DumpRenamedAst.hs:21:1-29 }
(DataDecl
(DataDeclRn
@@ -506,8 +578,7 @@
[]
[]
[])
- ,(TyClGroup
- (NoExtField)
+ ,(TcgRn
[({ DumpRenamedAst.hs:23:1-48 }
(FamDecl
(NoExtField)
@@ -627,7 +698,52 @@
{Name: GHC.Types.Type})))))
(Nothing))))]
[]
- []
+ [(DeclSigRnCUSK
+ ({ DumpRenamedAst.hs:23:1-48 }
+ (DeclHeaderRn
+ (ClosedTypeFamilyFlavour)
+ ({ DumpRenamedAst.hs:23:13-14 }
+ {Name: DumpRenamedAst.F1})
+ (HsQTvs
+ [{Name: k}]
+ [({ DumpRenamedAst.hs:23:17-22 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:17 }
+ {Name: a})
+ ({ DumpRenamedAst.hs:23:22 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:22 }
+ {Name: k})))))
+ ,({ DumpRenamedAst.hs:23:26-39 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:26 }
+ {Name: f})
+ ({ DumpRenamedAst.hs:23:31-39 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:31 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:31 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:23:36-39 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:36-39 }
+ {Name: GHC.Types.Type})))))))])
+ (Just
+ ({ DumpRenamedAst.hs:23:45-48 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:45-48 }
+ {Name: GHC.Types.Type})))))))]
[])]
[]
[]
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -4,14 +4,15 @@
(Just
((,,,)
(HsGroup
- (NoExtField)
+ (KindedDecls
+ {NameSet:
+ []})
(XValBindsLR
(NValBinds
[]
[]))
[]
- [(TyClGroup
- (NoExtField)
+ [(TcgRn
[({ T14189.hs:6:1-42 }
(DataDecl
(DataDeclRn
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/8c28209b53e324fd56fdc184db3e88ea82009b70...2d7968dd8b157b9875a5de475887ab15ac666e23
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/8c28209b53e324fd56fdc184db3e88ea82009b70...2d7968dd8b157b9875a5de475887ab15ac666e23
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/20200319/5d02406d/attachment-0001.html>
More information about the ghc-commits
mailing list