...
 
Commits (47)
......@@ -597,8 +597,7 @@ checkBrokenTablesNextToCode' dflags
setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- liftIO $ interpretPackageEnv dflags'
(dflags''', preload) <- liftIO $ initPackages dflags''
(dflags''', preload) <- liftIO $ initPackages dflags'
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
......@@ -715,7 +714,11 @@ getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags = parseDynamicFlagsCmdLine
parseDynamicFlags dflags cmdline = do
(dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
dflags2 <- liftIO $ interpretPackageEnv dflags1
return (dflags2, leftovers, warns)
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
......
......@@ -511,7 +511,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
......@@ -527,6 +527,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
......
......@@ -399,9 +399,23 @@ funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
-- | The @(->)@ type constructor.
--
-- @
-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
-- TYPE rep1 -> TYPE rep2 -> *
-- (->) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.
-- TYPE rep1 -> TYPE rep2 -> Type
-- @
--
-- The runtime representations quantification is left inferred. This
-- means they cannot be specified with @-XTypeApplications@.
--
-- This is a deliberate choice to allow future extensions to the
-- function arrow. To allow visible application a type synonym can be
-- defined:
--
-- @
-- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
-- TYPE rep1 -> TYPE rep2 -> Type
-- type Arr = (->)
-- @
--
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
where
......
......@@ -459,7 +459,7 @@ type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
mkCAFLabel :: CLabel -> CAFLabel
mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl
mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
-- This is a label that we can put in an SRT. It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
......@@ -736,10 +736,11 @@ getStaticFuns decls =
type SRTMap = Map CAFLabel (Maybe SRTEntry)
-- | Given SRTMap of a module returns the set of non-CAFFY names in the module.
-- Any Names not in the set are CAFFY.
srtMapNonCAFs :: SRTMap -> NameSet
srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap))
-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
-- module. Any 'Name's not in the set are CAFFY.
srtMapNonCAFs :: SRTMap -> NonCaffySet
srtMapNonCAFs srtMap =
NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
where
get_name (CAFLabel l, Nothing) = hasHaskellName l
get_name (_l, Just _srt_entry) = Nothing
......
......@@ -46,9 +46,6 @@ module GHC.Cmm.Utils(
baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
currentTSOExpr, currentNurseryExpr, cccsExpr,
-- Statics
blankWord,
-- Tagging
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
cmmConstrTag1,
......@@ -380,9 +377,6 @@ cmmNegate platform = \case
-> CmmLit (CmmInt (-n) rep)
e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
blankWord :: Platform -> CmmStatic
blankWord platform = CmmUninitialised (platformWordSizeInBytes platform)
cmmToWord :: Platform -> CmmExpr -> CmmExpr
cmmToWord platform e
| w == word = e
......
......@@ -2,8 +2,6 @@ module GHC.CmmToAsm.PPC.Cond (
Cond(..),
condNegate,
condUnsigned,
condToSigned,
condToUnsigned,
)
where
......@@ -47,17 +45,3 @@ condUnsigned LU = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _ = False
condToSigned :: Cond -> Cond
condToSigned GU = GTT
condToSigned LU = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x = x
condToUnsigned :: Cond -> Cond
condToUnsigned GTT = GU
condToUnsigned LTT = LU
condToUnsigned GE = GEU
condToUnsigned LE = LEU
condToUnsigned x = x
......@@ -554,8 +554,9 @@ delAssoc :: (Uniquable a)
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
= nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-- It's OK to use nonDetFoldUFM here because deletion is commutative
= nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-- It's OK to use a non-deterministic fold here because deletion is
-- commutative
| otherwise = m
......
module GHC.CmmToAsm.SPARC.Cond (
Cond(..),
condUnsigned,
condToSigned,
condToUnsigned
)
where
......@@ -28,27 +25,3 @@ data Cond
| VC
| VS
deriving Eq
condUnsigned :: Cond -> Bool
condUnsigned GU = True
condUnsigned LU = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _ = False
condToSigned :: Cond -> Cond
condToSigned GU = GTT
condToSigned LU = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x = x
condToUnsigned :: Cond -> Cond
condToUnsigned GTT = GU
condToUnsigned LTT = LU
condToUnsigned GE = GEU
condToUnsigned LE = LEU
condToUnsigned x = x
module GHC.CmmToAsm.X86.Cond (
Cond(..),
condUnsigned,
condToSigned,
condToUnsigned,
maybeFlipCond,
maybeInvertCond
......@@ -31,22 +29,6 @@ data Cond
| NOTPARITY
deriving Eq
condUnsigned :: Cond -> Bool
condUnsigned GU = True
condUnsigned LU = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _ = False
condToSigned :: Cond -> Cond
condToSigned GU = GTT
condToSigned LU = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x = x
condToUnsigned :: Cond -> Cond
condToUnsigned GTT = GU
condToUnsigned LTT = LU
......
......@@ -32,7 +32,7 @@ module GHC.CmmToLlvm.Base (
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
strCLabel_llvm,
getGlobalPtr, generateExternDecls,
aliasify, llvmDefLabel
......@@ -514,32 +514,6 @@ strCLabel_llvm lbl = do
sdoc
return (fsLit str)
strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit (dropInfoSuffix str))
dropInfoSuffix :: String -> String
dropInfoSuffix = go
where go "_info" = []
go "_static_info" = []
go "_con_info" = []
go (x:xs) = x:go xs
go [] = []
strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle Outp.neverQualify depth
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit str)
-- ----------------------------------------------------------------------------
-- * Global variables / forward references
--
......
......@@ -292,7 +292,9 @@ tidyCoAxBndrsForUser init_env tcvs
Note [Function coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~
Remember that
(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep
(->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep
whose `RuntimeRep' arguments are intentionally marked inferred to
avoid type application.
Hence
FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)
......
......@@ -380,8 +380,8 @@ famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]
-- See Note [FamInstEnv determinism]
famInstEnvSize :: FamInstEnv -> Int
famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
-- It's OK to use nonDetFoldUDFM here since we're just computing the
famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
-- It's OK to use nonDetStrictFoldUDFM here since we're just computing the
-- size.
familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
......
......@@ -735,6 +735,7 @@ errorIds
rEC_CON_ERROR_ID,
rEC_SEL_ERROR_ID,
aBSENT_ERROR_ID,
aBSENT_SUM_FIELD_ERROR_ID,
tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
]
......@@ -746,8 +747,6 @@ absentSumFieldErrorName :: Name
recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey
aBSENT_SUM_FIELD_ERROR_ID
runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
......@@ -774,25 +773,68 @@ tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Absent argument error for unused unboxed sum fields are different than absent
-- error used in dummy worker functions (see `mkAbsentErrorApp`):
--
-- - `absentSumFieldError` can't take arguments because it's used in unarise for
-- unused pointer fields in unboxed sums, and applying an argument would
-- require allocating a thunk.
-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum
-- and fields that can't be reached are filled with rubbish values. It's easy to
-- come up with rubbish literal values: we use 0 (ints/words) and 0.0
-- (floats/doubles). Coming up with a rubbish pointer value is more delicate:
--
-- - `absentSumFieldError` can't be CAFFY because that would mean making some
-- non-CAFFY definitions that use unboxed sums CAFFY in unarise.
-- 1. it needs to be a valid closure pointer for the GC (not a NULL pointer)
--
-- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
-- RtsStartup.c and mark it as non-CAFFY here.
-- 2. it is never used in Core, only in STG; and even then only for filling a
-- GC-ptr slot in an unboxed sum (see GHC.Stg.Unarise.ubxSumRubbishArg).
-- So all we need is a pointer, and its levity doesn't matter. Hence we
-- can safely give it the (lifted) type:
--
-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
-- absentSumFieldError :: forall a. a
--
-- TODO: Remove stable pointer hack after fixing #9718.
-- However, we should still be careful about not making things CAFFY just
-- because they use unboxed sums. Unboxed objects are supposed to be
-- efficient, and none of the other unboxed literals make things CAFFY.
-- despite the fact that Unarise might instantiate it at non-lifted
-- types.
--
-- 3. it can't take arguments because it's used in unarise and applying an
-- argument would require allocating a thunk.
--
-- 4. it can't be CAFFY because that would mean making some non-CAFFY
-- definitions that use unboxed sums CAFFY in unarise.
--
-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
--
-- 5. it can't be defined in `base` package.
--
-- Defining `absentSumFieldError` in `base` package introduces a
-- dependency on `base` for any code using unboxed sums. It became an
-- issue when we wanted to use unboxed sums in boot libraries used by
-- `base`, see #17791.
--
--
-- * Most runtime-error functions throw a proper Haskell exception, which can be
-- caught in the usual way. But these functions are defined in
-- `base:Control.Exception.Base`, hence, they cannot be directly invoked in
-- any library compiled before `base`. Only exceptions that have been wired
-- in the RTS can be thrown (indirectly, via a call into the RTS) by libraries
-- compiled before `base`.
--
-- However wiring exceptions in the RTS is a bit annoying because we need to
-- explicitly import exception closures via their mangled symbol name (e.g.
-- `import CLOSURE base_GHCziIOziException_heapOverflow_closure`) in Cmm files
-- and every imported symbol must be indicated to the linker in a few files
-- (`package.conf`, `rts.cabal`, `win32/libHSbase.def`, `Prelude.h`...). It
-- explains why exceptions are only wired in the RTS when necessary.
--
-- * `absentSumFieldError` is defined in ghc-prim:GHC.Prim.Panic, hence, it can
-- be invoked in libraries compiled before `base`. It does not throw a Haskell
-- exception; instead, it calls `stg_panic#`, which immediately halts
-- execution. A runtime invocation of `absentSumFieldError` indicates a GHC
-- bug. Unlike (say) pattern-match errors, it cannot be caused by a user
-- error. That's why it is OK for it to be un-catchable.
--
absentSumFieldErrorName
= mkWiredInIdName
gHC_PRIM_PANIC
(fsLit "absentSumFieldError")
absentSumFieldErrorIdKey
aBSENT_SUM_FIELD_ERROR_ID
aBSENT_SUM_FIELD_ERROR_ID
= mkVanillaGlobalWithInfo absentSumFieldErrorName
......
......@@ -21,7 +21,6 @@ import GHC.Core.Seq
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Basic
import Data.List
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
......@@ -34,6 +33,9 @@ import GHC.Utils.Misc
import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) )
import GHC.Data.Maybe ( isJust, isNothing )
import Control.Monad ( guard )
import Data.List
{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The goal of Constructed Product Result analysis is to identify functions that
......@@ -231,9 +233,14 @@ cprTransform env id
sig
where
sig
| isGlobalId id -- imported function or data con worker
-- See Note [CPR for expandable unfoldings]
| Just rhs <- cprExpandUnfolding_maybe id
= fst $ cprAnal env rhs
-- Imported function or data con worker
| isGlobalId id
= getCprSig (idCprInfo id)
| Just sig <- lookupSigEnv env id -- local let-bound
-- Local let-bound
| Just sig <- lookupSigEnv env id
= getCprSig sig
| otherwise
= topCprType
......@@ -303,6 +310,8 @@ cprAnalBind top_lvl env id rhs
| stays_thunk = trimCprTy rhs_ty
-- See Note [CPR for sum types]
| returns_sum = trimCprTy rhs_ty
-- See Note [CPR for expandable unfoldings]
| will_expand = topCprType
| otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
sig = mkCprSigForArity (idArity id) rhs_ty'
......@@ -316,6 +325,15 @@ cprAnalBind top_lvl env id rhs
(_, ret_ty) = splitPiTys (idType id)
not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)
returns_sum = not (isTopLevel top_lvl) && not_a_prod
-- See Note [CPR for expandable unfoldings]
will_expand = isJust (cprExpandUnfolding_maybe id)
cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr
cprExpandUnfolding_maybe id = do
guard (idArity id == 0)
-- There are only phase 0 Simplifier runs after CPR analysis
guard (isActiveIn 0 (idInlineActivation id))
expandUnfolding_maybe (idUnfolding id)
{- Note [Arity trimming for CPR signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -626,6 +644,48 @@ fac won't have the CPR property here when we trim every thunk! But the
assumption is that error cases are rarely entered and we are diverging anyway,
so WW doesn't hurt.
Should we also trim CPR on DataCon application bindings?
See Note [CPR for expandable unfoldings]!
Note [CPR for expandable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Long static data structures (whether top-level or not) like
xs = x1 : xs1
xs1 = x2 : xs2
xs2 = x3 : xs3
should not get CPR signatures, because they
* Never get WW'd, so their CPR signature should be irrelevant after analysis
(in fact the signature might even be harmful for that reason)
* Would need to be inlined/expanded to see their constructed product
* Recording CPR on them blows up interface file sizes and is redundant with
their unfolding. In case of Nested CPR, this blow-up can be quadratic!
But we can't just stop giving DataCon application bindings the CPR property,
for example
fac 0 = 1
fac n = n * fac (n-1)
fac certainly has the CPR property and should be WW'd! But FloatOut will
transform the first clause to
lvl = 1
fac 0 = lvl
If lvl doesn't have the CPR property, fac won't either. But lvl doesn't have a
CPR signature to extrapolate into a CPR transformer ('cprTransform'). So
instead we keep on cprAnal'ing through *expandable* unfoldings for these arity
0 bindings via 'cprExpandUnfolding_maybe'.
In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one
for each data declaration. It's wasteful to attach CPR signatures to each of
them (and intractable in case of Nested CPR).
Tracked by #18154.
Note [CPR examples]
~~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
......
......@@ -2245,8 +2245,8 @@ extendFvs env s
= (s `unionVarSet` extras, extras `subVarSet` s)
where
extras :: VarSet -- env(s)
extras = nonDetFoldUFM unionVarSet emptyVarSet $
-- It's OK to use nonDetFoldUFM here because unionVarSet commutes
extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $
-- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes
intersectUFM_C (\x _ -> x) env (getUniqSet s)
{-
......@@ -2567,8 +2567,8 @@ addManyOcc v u | isId v = addManyOccId u v
-- (Same goes for INLINE.)
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs usage id_set = nonDetFoldUniqSet addManyOcc usage id_set
-- It's OK to use nonDetFoldUFM here because addManyOcc commutes
addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set
-- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
delDetails :: UsageDetails -> Id -> UsageDetails
delDetails ud bndr
......
......@@ -83,7 +83,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Unique.Set ( nonDetFoldUniqSet )
import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet )
import GHC.Types.Unique.DSet ( getUniqDSet )
import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
......@@ -1469,8 +1469,8 @@ isFunction (_, AnnLam b e) | isId b = True
isFunction _ = False
countFreeIds :: DVarSet -> Int
countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet
-- It's OK to use nonDetFoldUDFM here because we're just counting things.
countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet
-- It's OK to use nonDetStrictFoldUDFM here because we're just counting things.
where
add :: Var -> Int -> Int
add v n | isId v = n+1
......@@ -1581,12 +1581,14 @@ placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
maxFvLevel max_me env var_set
= foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
= nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
-- It's OK to use a non-deterministic fold here because maxIn commutes.
maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
-- Same but for TyCoVarSet
maxFvLevel' max_me env var_set
= nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
= nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
-- It's OK to use a non-deterministic fold here because maxIn commutes.
maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
......
......@@ -1141,7 +1141,7 @@ specCase env scrut' case_bndr [(con, args, rhs)]
is_flt_sc_arg var = isId var
&& not (isDeadBinder var)
&& isDictTy var_ty
&& not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)
&& tyCoVarsOfType var_ty `disjointVarSet` arg_set
where
var_ty = idType var
......@@ -1362,6 +1362,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
inl_prag = idInlinePragma fn
inl_act = inlinePragmaActivation inl_prag
is_local = isLocalId fn
is_dfun = isDFunId fn
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
......@@ -1384,22 +1385,34 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
spec_call :: SpecInfo -- Accumulating parameter
-> CallInfo -- Call instance
-> SpecM SpecInfo
spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) (CI { ci_key = call_args })
spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })
= -- See Note [Specialising Calls]
do { ( useful, rhs_env2, leftover_bndrs
do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg
| otherwise = call_args
-- See Note [Specialising DFuns]
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
, spec_bndrs, dx_binds, spec_args) <- specHeader env rhs_bndrs call_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
-- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci
-- , text "useful: " <+> ppr useful
-- , text "rule_bndrs:" <+> ppr rule_bndrs
-- , text "lhs_args: " <+> ppr rule_lhs_args
-- , text "spec_bndrs:" <+> ppr spec_bndrs1
-- , text "spec_args: " <+> ppr spec_args
-- , text "dx_binds: " <+> ppr dx_binds
-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
-- , ppr dx_binds ]) $
-- return ()
; dflags <- getDynFlags
; if not useful -- No useful specialisation
|| already_covered dflags rules_acc rule_lhs_args
then return spec_acc
else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
-- , text "rhs_env2" <+> ppr (se_subst rhs_env2)
-- , ppr dx_binds ]) $
else
do { -- Run the specialiser on the specialised RHS
-- The "1" suffix is before we maybe add the void arg
; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs ++ leftover_bndrs) rhs_body
; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body
; let spec_fn_ty1 = exprType spec_rhs1
-- Maybe add a void arg to the specialised function,
......@@ -1407,14 +1420,13 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- See Note [Specialisations Must Be Lifted]
-- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs
add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
(spec_rhs, spec_fn_ty, rule_rhs_args)
| add_void_arg = ( Lam voidArgId spec_rhs1
, mkVisFunTy voidPrimTy spec_fn_ty1
, voidPrimId : spec_bndrs)
| otherwise = (spec_rhs1, spec_fn_ty1, spec_bndrs)
arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args
join_arity_decr = length rule_lhs_args - length rule_rhs_args
(spec_bndrs, spec_rhs, spec_fn_ty)
| add_void_arg = ( voidPrimId : spec_bndrs1
, Lam voidArgId spec_rhs1
, mkVisFunTy voidPrimTy spec_fn_ty1)
| otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
join_arity_decr = length rule_lhs_args - length spec_bndrs
spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
= Just (orig_join_arity - join_arity_decr)
| otherwise
......@@ -1449,7 +1461,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
(idName fn)
rule_bndrs
rule_lhs_args
(mkVarApps (Var spec_fn) rule_rhs_args)
(mkVarApps (Var spec_fn) spec_bndrs)
spec_rule
= case isJoinId_maybe fn of
......@@ -1472,15 +1484,15 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
= (inl_prag, specUnfolding dflags fn spec_bndrs spec_app arity_decr fn_unf)
spec_app e = e `mkApps` spec_args
= (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args)
rule_lhs_args fn_unf)
--------------------------------------
-- Adding arity information just propagates it a bit faster
-- See Note [Arity decrease] in GHC.Core.Opt.Simplify
-- Copy InlinePragma information from the parent Id.
-- So if f has INLINE[1] so does spec_fn
arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
`setInlinePragma` spec_inl_prag
`setIdUnfolding` spec_unf
......@@ -1498,8 +1510,19 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
, spec_uds `plusUDs` uds_acc
) } }
{- Note [Specialisation Must Preserve Sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DFuns have a special sort of unfolding (DFunUnfolding), and these are
hard to specialise a DFunUnfolding to give another DFunUnfolding
unless the DFun is fully applied (#18120). So, in the case of DFunIds
we simply extend the CallKey with trailing UnspecArgs, so we'll
generate a rule that completely saturates the DFun.
There is an ASSERT that checks this, in the DFunUnfolding case of
GHC.Core.Unfold.specUnfolding.
Note [Specialisation Must Preserve Sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function:
f :: forall a. Eq a => a -> blah
......@@ -2089,7 +2112,7 @@ isSpecDict _ = False
-- -- Specialised function helpers
-- , [c, i, x]
-- , [dShow1 = $dfShow dShowT2]
-- , [T1, T2, dEqT1, dShow1]
-- , [T1, T2, c, i, dEqT1, dShow1]
-- )
specHeader
:: SpecEnv
......@@ -2106,12 +2129,13 @@ specHeader
-- RULE helpers
, [OutBndr] -- Binders for the RULE
, [CoreArg] -- Args for the LHS of the rule
, [OutExpr] -- Args for the LHS of the rule
-- Specialised function helpers
, [OutBndr] -- Binders for $sf
, [DictBind] -- Auxiliary dictionary bindings
, [OutExpr] -- Specialised arguments for unfolding
-- Same length as "args for LHS of rule"
)
-- We want to specialise on type 'T1', and so we must construct a substitution
......@@ -2407,8 +2431,8 @@ unionCallInfoSet (CIS f calls1) (CIS _ calls2) =
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs calls =
nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
-- It's OK to use nonDetFoldUDFM here because we forget the ordering
nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
-- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering
-- immediately by converting to a nondeterministic set.
callInfoFVs :: CallInfoSet -> VarSet
......@@ -2721,7 +2745,7 @@ filterCalls (CIS fn call_bag) dbs
= extendVarSetList so_far (bindersOf bind)
| otherwise = so_far
ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
----------------------
splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
......@@ -2752,7 +2776,7 @@ deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning bs calls
= mapDVarEnv (ciSetFilter keep_call) calls
where
keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)
keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
-- Remove calls *for* bs
......
......@@ -441,7 +441,7 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView
closeOverKinds :: TyCoVarSet -> TyCoVarSet
-- For each element of the input set,
-- add the deep free variables of its kind
closeOverKinds vs = nonDetFoldVarSet do_one vs vs
closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs
where
do_one v acc = appEndo (deep_ty (varType v)) acc
......
......@@ -255,12 +255,15 @@ about it!
* FFunTy is the data constructor, meaning "full function type".
* The function type constructor (->) has kind
(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep
(->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> Type LiftedRep
mkTyConApp ensure that we convert a saturated application
TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2
dropping the 'r1' and 'r2' arguments; they are easily recovered
from 't1' and 't2'.
* For the time being its RuntimeRep quantifiers are left
inferred. This is to allow for it to evolve.
* The ft_af field says whether or not this is an invisible argument
VisArg: t1 -> t2 Ordinary function type
InvisArg: t1 => t2 t1 is guaranteed to be a predicate type,
......
......@@ -383,8 +383,8 @@ extendTCvSubstList subst tvs tys
unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst
-- Works when the ranges are disjoint
unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
= ASSERT( not (tenv1 `intersectsVarEnv` tenv2)
&& not (cenv1 `intersectsVarEnv` cenv2) )
= ASSERT( tenv1 `disjointVarEnv` tenv2
&& cenv1 `disjointVarEnv` cenv2 )
TCvSubst (in_scope1 `unionInScope` in_scope2)
(tenv1 `plusVarEnv` tenv2)
(cenv1 `plusVarEnv` cenv2)
......
......@@ -1012,9 +1012,10 @@ Note [Representation of function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Functions (e.g. Int -> Char) can be thought of as being applications
of funTyCon (known in Haskell surface syntax as (->)),
of funTyCon (known in Haskell surface syntax as (->)), (note that
`RuntimeRep' quantifiers are left inferred)
(->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}
(a :: TYPE r1) (b :: TYPE r2).
a -> b -> Type
......@@ -2115,7 +2116,7 @@ isValidJoinPointType arity ty
where
valid_under tvs arity ty
| arity == 0
= isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty)
= tvs `disjointVarSet` tyCoVarsOfType ty
| Just (t, ty') <- splitForAllTy_maybe ty
= valid_under (tvs `extendVarSet` t) (arity-1) ty'
| Just (_, res_ty) <- splitFunTy_maybe ty
......
......@@ -173,47 +173,47 @@ mkInlinableUnfolding dflags expr
where
expr' = simpleOptExpr dflags expr
specUnfolding :: DynFlags -> Id -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
specUnfolding :: DynFlags
-> [Var] -> (CoreExpr -> CoreExpr)
-> [CoreArg] -- LHS arguments in the RULE
-> Unfolding -> Unfolding
-- See Note [Specialising unfoldings]
-- specUnfolding spec_bndrs spec_app arity_decrease unf
-- = \spec_bndrs. spec_app( unf )
-- specUnfolding spec_bndrs spec_args unf
-- = \spec_bndrs. unf spec_args
--
specUnfolding dflags fn spec_bndrs spec_app arity_decrease
specUnfolding dflags spec_bndrs spec_app rule_lhs_args
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
= ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs
, ppr df $$ ppr spec_bndrs $$ ppr (spec_app (Var fn)) $$ ppr arity_decrease )
= ASSERT2( rule_lhs_args `equalLength` old_bndrs
, ppr df $$ ppr rule_lhs_args )
-- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
mkDFunUnfolding spec_bndrs con (map spec_arg args)
-- There is a hard-to-check assumption here that the spec_app has
-- enough applications to exactly saturate the old_bndrs
-- For DFunUnfoldings we transform
-- \old_bndrs. MkD <op1> ... <opn>
-- \obs. MkD <op1> ... <opn>
-- to
-- \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>
-- The ASSERT checks the value part of that
-- \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
where
spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg))
spec_arg arg = simpleOptExpr dflags $
spec_app (mkLams old_bndrs arg)
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
specUnfolding dflags _ spec_bndrs spec_app arity_decrease
specUnfolding dflags spec_bndrs spec_app rule_lhs_args
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl
, uf_guidance = old_guidance })
| isStableSource src -- See Note [Specialising unfoldings]
, UnfWhen { ug_arity = old_arity
, ug_unsat_ok = unsat_ok
, ug_boring_ok = boring_ok } <- old_guidance
= let guidance = UnfWhen { ug_arity = old_arity - arity_decrease
, ug_unsat_ok = unsat_ok
, ug_boring_ok = boring_ok }
new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl))
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
, UnfWhen { ug_arity = old_arity } <- old_guidance
= mkCoreUnfolding src top_lvl new_tmpl
(old_guidance { ug_arity = old_arity - arity_decrease })
where
new_tmpl = simpleOptExpr dflags $
mkLams spec_bndrs $
spec_app tmpl -- The beta-redexes created by spec_app
-- will besimplified away by simplOptExpr
arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
in mkCoreUnfolding src top_lvl new_tmpl guidance
specUnfolding _ _ _ _ _ _ = noUnfolding
specUnfolding _ _ _ _ _ = noUnfolding
{- Note [Specialising unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -658,9 +658,9 @@ niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet
-- remembering that the substitution isn't necessarily idempotent
-- This is used in the occurs check, before extending the substitution
niSubstTvSet tsubst tvs
= nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs
-- It's OK to nonDetFoldUFM here because we immediately forget the
-- ordering by creating a set.
= nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs
-- It's OK to use a non-deterministic fold here because we immediately forget
-- the ordering by creating a set.
where
get tv
| Just ty <- lookupVarEnv tsubst tv
......
......@@ -79,8 +79,8 @@ addNode k node graph
= let
-- add back conflict edges from other nodes to this one
map_conflict =
nonDetFoldUniqSet
-- It's OK to use nonDetFoldUFM here because the
nonDetStrictFoldUniqSet
-- It's OK to use a non-deterministic fold here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeConflicts =
addOneToUniqSet (nodeConflicts n) k}))
......@@ -89,8 +89,8 @@ addNode k node graph
-- add back coalesce edges from other nodes to this one
map_coalesce =
nonDetFoldUniqSet
-- It's OK to use nonDetFoldUFM here because the
nonDetStrictFoldUniqSet
-- It's OK to use a non-deterministic fold here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeCoalesce =
addOneToUniqSet (nodeCoalesce n) k}))
......@@ -492,9 +492,9 @@ freezeNode k
else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set"
-- If the edge isn't actually in the coelesce set then just ignore it.
fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
-- It's OK to use nonDetFoldUFM here because the operation
-- is commutative
fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
-- It's OK to use a non-deterministic fold here because the
-- operation is commutative
$ nodeCoalesce node
in fm2
......
......@@ -1384,7 +1384,7 @@ hscWriteIface dflags iface no_change mod_location = do
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet)
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet)
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts location output_filename = do
let CgGuts{ -- This is the last use of the ModGuts in a compilation.
......@@ -1541,7 +1541,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs NameSet)
-> IO (Stream IO CmmGroupSRTs NonCaffySet)
-- Note we produce a 'Stream' of CmmGroups, so that the
-- backend can be run incrementally. Otherwise it generates all
-- the C-- up front, which has a significant space cost.
......
......@@ -2244,7 +2244,7 @@ type LRuleBndr pass = Located (RuleBndr pass)
-- | Rule Binder
data RuleBndr pass
= RuleBndr (XCRuleBndr pass) (Located (IdP pass))
| RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
| RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)
| XRuleBndr !(XXRuleBndr pass)
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
......@@ -2256,7 +2256,7 @@ type instance XCRuleBndr (GhcPass _) = NoExtField
type instance XRuleBndrSig (GhcPass _) = NoExtField
type instance XXRuleBndr (GhcPass _) = NoExtCon
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
......
......@@ -685,6 +685,11 @@ type family XXHsWildCardBndrs x b
-- -------------------------------------
type family XHsPS x
type family XXHsPatSigType x
-- -------------------------------------
type family XForAllTy x
type family XQualTy x
type family XTyVar x
......
......@@ -386,6 +386,11 @@ deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)
-- deriving instance (DataIdLR p p) => Data (HsPatSigType p)
deriving instance Data (HsPatSigType GhcPs)
deriving instance Data (HsPatSigType GhcRn)
deriving instance Data (HsPatSigType GhcTc)
-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
deriving instance Data (HsTyVarBndr GhcPs)
deriving instance Data (HsTyVarBndr GhcRn)
......
......@@ -240,7 +240,7 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| SigPat (XSigPat p) -- After typechecker: Type
(LPat p) -- Pattern with a type signature
(LHsSigWcType (NoGhcTc p)) -- Signature can bind both
(HsPatSigType (NoGhcTc p)) -- Signature can bind both
-- kind and type vars
-- ^ Pattern with a type signature
......
......@@ -23,6 +23,7 @@ module GHC.Hs.Types (
LHsQTyVars(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
HsPatSigType(..), HsPSRn(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
HsContext, LHsContext, noLHsContext,
......@@ -47,7 +48,7 @@ module GHC.Hs.Types (
mkAnonWildCardTy, pprAnonWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
......@@ -59,7 +60,7 @@ module GHC.Hs.Types (
splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType,
ignoreParens, hsSigType, hsSigWcType, hsPatSigType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
hsTyKindSig,
hsConDetailsArgs,
......@@ -184,6 +185,13 @@ is a bit complicated. Here's how it works.
f :: _a -> _
The enclosing HsWildCardBndrs binds the wildcards _a and _.
* HsSigPatType describes types that appear in pattern signatures and
the signatures of term-level binders in RULES. Like
HsWildCardBndrs/HsImplicitBndrs, they track the names of wildcard
variables and implicitly bound type variables. Unlike
HsImplicitBndrs, however, HsSigPatTypes do not obey the
forall-or-nothing rule. See Note [Pattern signature binders and scoping].
* The explicit presence of these wrappers specifies, in the HsSyn,
exactly where implicit quantification is allowed, and where
wildcards are allowed.
......@@ -225,13 +233,15 @@ Note carefully:
Here _a is an ordinary forall'd binder, but (With NamedWildCards)
_b is a named wildcard. (See the comments in #10982)
* Named wildcards are bound by the HsWildCardBndrs construct, which wraps
types that are allowed to have wildcards. Unnamed wildcards however are left
unchanged until typechecking, where we give them fresh wild tyavrs and
determine whether or not to emit hole constraints on each wildcard
(we don't if it's a visible type/kind argument or a type family pattern).
See related notes Note [Wildcards in visible kind application]
and Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType
* Named wildcards are bound by the HsWildCardBndrs (for types that obey the
forall-or-nothing rule) and HsPatSigType (for type signatures in patterns
and term-level binders in RULES), which wrap types that are allowed to have
wildcards. Unnamed wildcards, however are left unchanged until typechecking,
where we give them fresh wild tyvars and determine whether or not to emit
hole constraints on each wildcard (we don't if it's a visible type/kind
argument or a type family pattern). See related notes
Note [Wildcards in visible kind application] and
Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType.
* After type checking is done, we report what types the wildcards
got unified with.
......@@ -399,6 +409,33 @@ type instance XHsWC GhcTc b = [Name]
type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon
-- | Types that can appear in pattern signatures, as well as the signatures for
-- term-level binders in RULES.
-- See @Note [Pattern signature binders and scoping]@.
--
-- This is very similar to 'HsSigWcType', but with
-- slightly different semantics: see @Note [HsType binders]@.
-- See also @Note [The wildcard story for types]@.
data HsPatSigType pass
= HsPS { hsps_ext :: XHsPS pass -- ^ After renamer: 'HsPSRn'
, hsps_body :: LHsType pass -- ^ Main payload (the type itself)
}
| XHsPatSigType !(XXHsPatSigType pass)
-- | The extension field for 'HsPatSigType', which is only used in the
-- renamer onwards. See @Note [Pattern signature binders and scoping]@.
data HsPSRn = HsPSRn
{ hsps_nwcs :: [Name] -- ^ Wildcard names
, hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names
}
deriving Data
type instance XHsPS GhcPs = NoExtField
type instance XHsPS GhcRn = HsPSRn
type instance XHsPS GhcTc = HsPSRn
type instance XXHsPatSigType (GhcPass _) = NoExtCon
-- | Located Haskell Signature Type
type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only
......@@ -419,6 +456,9 @@ hsSigType = hsImplicitBody
hsSigWcType :: LHsSigWcType pass -> LHsType pass
hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
hsPatSigType :: HsPatSigType pass -> LHsType pass
hsPatSigType = hsps_body
dropWildCards :: LHsSigWcType pass -> LHsSigType pass
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = hswc_body sig_ty
......@@ -441,6 +481,71 @@ we get
, hst_body = blah }
The implicit kind variable 'k' is bound by the HsIB;
the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
Note [Pattern signature binders and scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the pattern signatures like those on `t` and `g` in:
f = let h = \(t :: (b, b) ->
\(g :: forall a. a -> b) ->
...(t :: (Int,Int))...
in woggle
* The `b` in t's pattern signature is implicitly bound and scopes over
the signature and the body of the lambda. It stands for a type (any type);
indeed we subsequently discover that b=Int.
(See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.)
* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by
t's pattern signature.
* The `a` in `forall a` scopes only over the type `a -> b`, not over the body
of the lambda.
* There is no forall-or-nothing rule for pattern signatures, which is why the
type `forall a. a -> b` is permitted in `g`'s pattern signature, even though
`b` is not explicitly bound.
See Note [forall-or-nothing rule] in GHC.Rename.HsType.
Similar scoping rules apply to term variable binders in RULES, like in the
following example:
{-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-}
Just like in pattern signatures, the `b` in t's signature is implicitly bound
and scopes over the remainder of the RULE. As a result, the `b` in g's
signature is an occurrence. Moreover, the `a` in `forall a` scopes only over
the type `a -> b`, and the forall-or-nothing rule does not apply.
While quite similar, RULE term binder signatures behave slightly differently
from pattern signatures in two ways:
1. Unlike in pattern signatures, where type variables can stand for any type,
type variables in RULE term binder signatures are skolems.
See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for
more on this point.
In this sense, type variables in pattern signatures are quite similar to
named wildcards, as both can refer to arbitrary types. The main difference
lies in error reporting: if a named wildcard `_a` in a pattern signature
stands for Int, then by default GHC will emit a warning stating as much.
Changing `_a` to `a`, on the other hand, will cause it not to be reported.
2. In the `h` RULE above, only term variables are explicitly bound, so any free
type variables in the term variables' signatures are implicitly bound.
This is just like how the free type variables in pattern signatures are
implicitly bound. If a RULE explicitly binds both term and type variables,
however, then free type variables in term signatures are /not/ implicitly
bound. For example, this RULE would be ill scoped:
{-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b).
h2 t g = ... #-}
This is because `b` and `c` occur free in the signature for `t`, but only
`b` was explicitly bound, leaving `c` out of scope. If the RULE had started
with `forall b c.`, then it would have been accepted.
The types in pattern signatures and RULE term binder signatures are represented
in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of
type HsPSRn) tracks the names of named wildcards and implicitly bound type
variables so that they can be brought into scope during renaming and
typechecking.
-}
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
......@@ -451,6 +556,10 @@ mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_ext = noExtField }
mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType x = HsPS { hsps_ext = noExtField
, hsps_body = x }
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
......@@ -1408,6 +1517,10 @@ instance Outputable thing