summaryrefslogtreecommitdiff
path: root/compiler/GHC/Core
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Core')
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs2
-rw-r--r--compiler/GHC/Core/Opt/FloatIn.hs4
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs2
-rw-r--r--compiler/GHC/Core/Predicate.hs8
-rw-r--r--compiler/GHC/Core/Type.hs46
-rw-r--r--compiler/GHC/Core/Unfold.hs2
-rw-r--r--compiler/GHC/Core/Utils.hs66
7 files changed, 93 insertions, 37 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index fbe843cff8..0bcabf55d3 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -395,7 +395,7 @@ dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
anticipateANF :: CoreExpr -> Card -> Card
anticipateANF e n
| exprIsTrivial e = n -- trivial expr won't have a binding
- | Just Unlifted <- typeLevity_maybe (exprType e)
+ | definitelyUnliftedType (exprType e)
, not (isAbs n && exprOkForSpeculation e) = case_bind n
| otherwise = let_bind n
where
diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs
index 2feef8a617..b35e655a87 100644
--- a/compiler/GHC/Core/Opt/FloatIn.hs
+++ b/compiler/GHC/Core/Opt/FloatIn.hs
@@ -28,7 +28,7 @@ import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Type
-import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) )
+import GHC.Types.Basic ( RecFlag(..), isRec )
import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe )
import GHC.Types.Tickish
import GHC.Types.Var
@@ -618,7 +618,7 @@ noFloatIntoRhs is_rec bndr rhs
| isJoinId bndr
= isRec is_rec -- Joins are one-shot iff non-recursive
- | Just Unlifted <- typeLevity_maybe (idType bndr)
+ | definitelyUnliftedType (idType bndr)
= True -- Preserve let-can-float invariant, see Note [noFloatInto considerations]
| otherwise
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index dfca4bc0ce..39263455c0 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -685,7 +685,7 @@ mkArgInfo env rule_base fun cont
| Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info
, dmd : rest_dmds <- dmds
, let dmd'
- | Just Unlifted <- typeLevity_maybe arg_ty
+ | definitelyUnliftedType arg_ty
= strictifyDmd dmd
| otherwise
-- Something that's not definitely unlifted.
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index 9751724d56..c8d280259a 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -224,11 +224,12 @@ isEqPredClass :: Class -> Bool
isEqPredClass cls = cls `hasKey` eqTyConKey
|| cls `hasKey` heqTyConKey
-isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool
+isClassPred :: PredType -> Bool
isClassPred ty = case tyConAppTyCon_maybe ty of
- Just tyCon | isClassTyCon tyCon -> True
- _ -> False
+ Just tc -> isClassTyCon tc
+ _ -> False
+isEqPred :: PredType -> Bool
isEqPred ty -- True of (a ~ b) and (a ~~ b)
-- ToDo: should we check saturation?
| Just tc <- tyConAppTyCon_maybe ty
@@ -237,6 +238,7 @@ isEqPred ty -- True of (a ~ b) and (a ~~ b)
| otherwise
= False
+isEqPrimPred :: PredType -> Bool
isEqPrimPred ty = isCoVarType ty
-- True of (a ~# b) (a ~R# b)
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 9e0d95b0d9..8bab8462be 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -132,8 +132,9 @@ module GHC.Core.Type (
isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
kindBoxedRepLevity_maybe,
mightBeLiftedType, mightBeUnliftedType,
+ definitelyLiftedType, definitelyUnliftedType,
isAlgType, isDataFamilyAppType,
- isPrimitiveType, isStrictType,
+ isPrimitiveType, isStrictType, isTerminatingType,
isLevityTy, isLevityVar,
isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
dropRuntimeRepArgs,
@@ -2198,18 +2199,6 @@ isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty
isFamFreeTy (CastTy ty _) = isFamFreeTy ty
isFamFreeTy (CoercionTy _) = False -- Not sure about this
--- | Does this type classify a core (unlifted) Coercion?
--- At either role nominal or representational
--- (t1 ~# t2) or (t1 ~R# t2)
--- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep"
-isCoVarType :: Type -> Bool
- -- ToDo: should we check saturation?
-isCoVarType ty
- | Just tc <- tyConAppTyCon_maybe ty
- = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey
- | otherwise
- = False
-
buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> KnotTied Type -> TyCon
-- This function is here because here is where we have
@@ -2256,8 +2245,7 @@ isUnliftedType ty =
case typeLevity_maybe ty of
Just Lifted -> False
Just Unlifted -> True
- Nothing ->
- pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))
+ Nothing -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))
-- | Returns:
--
@@ -2267,6 +2255,9 @@ isUnliftedType ty =
mightBeLiftedType :: Type -> Bool
mightBeLiftedType = mightBeLifted . typeLevity_maybe
+definitelyLiftedType :: Type -> Bool
+definitelyLiftedType = not . mightBeUnliftedType
+
-- | Returns:
--
-- * 'False' if the type is /guaranteed/ lifted or
@@ -2275,6 +2266,9 @@ mightBeLiftedType = mightBeLifted . typeLevity_maybe
mightBeUnliftedType :: Type -> Bool
mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe
+definitelyUnliftedType :: Type -> Bool
+definitelyUnliftedType = not . mightBeLiftedType
+
-- | See "Type#type_classification" for what a boxed type is.
-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for
-- a more approximate predicate that behaves better in the presence of
@@ -2371,6 +2365,28 @@ isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of
isStrictType :: HasDebugCallStack => Type -> Bool
isStrictType = isUnliftedType
+isTerminatingType :: HasDebugCallStack => Type -> Bool
+-- ^ True <=> a term of this type cannot be bottom
+-- This identifies the types described by
+-- Note [NON-BOTTOM-DICTS invariant] in GHC.Core
+-- NB: unlifted types are not terminating types!
+-- e.g. you can write a term (loop 1)::Int# that diverges.
+isTerminatingType ty = case tyConAppTyCon_maybe ty of
+ Just tc -> isClassTyCon tc && not (isNewTyCon tc)
+ _ -> False
+
+-- | Does this type classify a core (unlifted) Coercion?
+-- At either role nominal or representational
+-- (t1 ~# t2) or (t1 ~R# t2)
+-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep"
+isCoVarType :: Type -> Bool
+ -- ToDo: should we check saturation?
+isCoVarType ty
+ | Just tc <- tyConAppTyCon_maybe ty
+ = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey
+ | otherwise
+ = False
+
isPrimitiveType :: Type -> Bool
-- ^ Returns true of types that are opaque to Haskell.
isPrimitiveType ty = case splitTyConApp_maybe ty of
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 48a7e5e82f..3663e50bf1 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -593,7 +593,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
FCallId _ -> sizeN (callSize (length val_args) voids)
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op _ -> primOpSize op (length val_args)
- ClassOpId _ -> classOpSize opts top_args val_args
+ ClassOpId {} -> classOpSize opts top_args val_args
_ -> funSize opts top_args fun (length val_args) voids
------------
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index a0d3bc9c44..35023c6576 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -91,8 +91,7 @@ import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Basic( Arity, Levity(..)
- )
+import GHC.Types.Basic( Arity )
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Demand
@@ -1574,6 +1573,13 @@ app_ok fun_ok primop_ok fun args
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
+ ClassOpId _ is_terminating_result
+ | is_terminating_result -- See Note [exprOkForSpeculation and type classes]
+ -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $
+ True
+ -- assert: terminating result type => can't be applied;
+ -- c.f the _other case below
+
PrimOpId op _
| primOpIsDiv op
, [arg1, Lit lit] <- args
@@ -1596,14 +1602,16 @@ app_ok fun_ok primop_ok fun args
-> primop_ok op -- Check the primop itself
&& and (zipWith arg_ok arg_tys args) -- Check the arguments
- _ -- Unlifted types
- -- c.f. the Var case of exprIsHNF
- | Just Unlifted <- typeLevity_maybe (idType fun)
+ _other -- Unlifted and terminating types;
+ -- Also c.f. the Var case of exprIsHNF
+ | isTerminatingType fun_ty -- See Note [exprOkForSpeculation and type classes]
+ || definitelyUnliftedType fun_ty
-> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)
- True -- Our only unlifted types are Int# etc, so will have
- -- no value args. The assert is just to check this.
- -- If we added unlifted function types this would change,
- -- and we'd need to actually test n_val_args == 0.
+ True -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)
+ -- are non-functions and so will have no value args. The assert is
+ -- just to check this.
+ -- (If we added unlifted function types this would change,
+ -- and we'd need to actually test n_val_args == 0.)
-- Partial applications
| idArity fun > n_val_args ->
@@ -1618,14 +1626,15 @@ app_ok fun_ok primop_ok fun args
-- for evaluated-ness of the fun;
-- see Note [exprOkForSpeculation and evaluated variables]
where
+ fun_ty = idType fun
n_val_args = valArgCount args
- (arg_tys, _) = splitPiTys (idType fun)
+ (arg_tys, _) = splitPiTys fun_ty
-- Used for arguments to primops and to partial applications
arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
arg_ok (Named _) _ = True -- A type argument
arg_ok (Anon ty _) arg -- A term argument
- | Just Lifted <- typeLevity_maybe (scaledThing ty)
+ | definitelyLiftedType (scaledThing ty)
= True -- See Note [Primops with lifted arguments]
| otherwise
= expr_ok fun_ok primop_ok arg
@@ -1655,8 +1664,36 @@ etaExpansionTick id t
= hasNoBinding id &&
( tickishFloatable t || isProfTick t )
-{- Note [exprOkForSpeculation: case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [exprOkForSpeculation and type classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#22745, #15205)
+
+ \(d :: C a b). case eq_sel (sc_sel d) of
+ (co :: t1 ~# t2) [Dead] -> blah
+
+We know that
+* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates
+ (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core)
+* eq_sel is simply a superclass selector, and hence is fast
+* The field that eq_sel picks is of unlifted type, and hence can't be bottom
+ (remember the dictionary argument itself is non-bottom)
+
+So we can treat (eq_sel (sc_sel d)) as ok-for-speculation. We must check
+
+a) That the function is a class-op, with IdDetails of ClassOpId
+
+b) That the result type of the class-op is terminating or unlifted. E.g. for
+ class C a => D a where ...
+ class C a where { op :: a -> a }
+ Since C is represented by a newtype, (sc_sel (d :: D a)) might
+ not be terminating.
+
+Rather than repeatedly test if the result of the class-op is a
+terminating/unlifted type, we cache it as a field of ClassOpId. See
+GHC.Types.Id.Make.mkDictSelId for where this field is initialised.
+
+Note [exprOkForSpeculation: case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
exprOkForSpeculation accepts very special case expressions.
Reason: (a ==# b) is ok-for-speculation, but the litEq rules
in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to
@@ -1881,7 +1918,8 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
-- We don't look through loop breakers here, which is a bit conservative
-- but otherwise I worry that if an Id's unfolding is just itself,
-- we could get an infinite loop
- || ( typeLevity_maybe (idType v) == Just Unlifted )
+
+ || definitelyUnliftedType (idType v)
-- Unlifted binders are always evaluated (#20140)
is_hnf_like (Lit l) = not (isLitRubbish l)
View Lorry Controller Status