[Git][ghc/ghc][wip/T22745] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Jan 17 23:09:50 UTC 2023
Simon Peyton Jones pushed to branch wip/T22745 at Glasgow Haskell Compiler / GHC
Commits:
75e90cf6 by Simon Peyton Jones at 2023-01-17T23:05:49+00:00
Wibbles
- - - - -
8 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/StgToJS/Expr.hs
Changes:
=====================================
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
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -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
=====================================
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.
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -132,6 +132,7 @@ module GHC.Core.Type (
isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
kindBoxedRepLevity_maybe,
mightBeLiftedType, mightBeUnliftedType,
+ definitelyLiftedType, definitelyUnliftedType,
isAlgType, isDataFamilyAppType,
isPrimitiveType, isStrictType, isTerminatingType,
isLevityTy, isLevityVar,
@@ -2253,8 +2254,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:
--
@@ -2264,6 +2264,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
@@ -2272,6 +2275,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
@@ -2368,12 +2374,12 @@ isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of
isStrictType :: HasDebugCallStack => Type -> Bool
isStrictType = isUnliftedType
-isTerminatingType :: Type -> Bool
+isTerminatingType :: HasDebugCallStack => Type -> Bool
-- ^ True <=> every term of this type terminates
-- Includes all unlifted types, since they don't have bottom,
-- and also all non-newtype dictionaries
-- See Note [NON-BOTTOM-DICTS invariant] in GHC.Core
-isTerminatingType ty = isUnliftedType ty || isNonNewtypeClassPred ty
+isTerminatingType ty = definitelyUnliftedType ty || isNonNewtypeClassPred ty
isNonNewtypeClassPred :: PredType -> Bool
isNonNewtypeClassPred ty = case tyConAppTyCon_maybe ty of
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1634,7 +1634,7 @@ app_ok fun_ok primop_ok fun args
primop_arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
primop_arg_ok (Named _) _ = True -- A type argument
primop_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
@@ -1920,7 +1920,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)
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -675,7 +675,7 @@ addPhiTmCt nabla (PhiNotBotCt x) = addNotBotCt nabla x
filterUnliftedFields :: PmAltCon -> [Id] -> [Id]
filterUnliftedFields con args =
[ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)
- , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ]
+ , isBanged bang || definitelyUnliftedType (idType arg) ]
-- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@
-- surely diverges. Quite similar to 'addConCt', only that it only cares about
@@ -687,7 +687,7 @@ addBotCt nabla at MkNabla{ nabla_tm_st = ts at TmSt{ ts_facts=env } } x = do
IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction!
IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do
MaybeBot -- We add x ~ ⊥
- | Just Unlifted <- typeLevity_maybe (idType x)
+ | definitelyUnliftedType (idType x)
-- Case (3) in Note [Strict fields and variables of unlifted type]
-> mzero -- unlifted vars can never be ⊥
| otherwise
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -257,7 +257,7 @@ isTagged v = do
(TagSig TagDunno)
case nameIsLocalOrFrom this_mod (idName v) of
True
- | Just Unlifted <- typeLevity_maybe (idType v)
+ | definitelyUnliftedType (idType v)
-- NB: v might be the Id of a representation-polymorphic join point,
-- so we shouldn't use isUnliftedType here. See T22212.
-> return True
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -484,7 +484,7 @@ genStaticRefs lv
| otherwise = do
unfloated <- State.gets gsUnfloated
let xs = filter (\x -> not (elemUFM x unfloated ||
- typeLevity_maybe (idType x) == Just Unlifted))
+ definitelyUnliftedType (idType x)))
(dVarSetElems sv)
CIStaticRefs . catMaybes <$> mapM getStaticRef xs
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e90cf68234b571931e46fdc8c13016b10c5191
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e90cf68234b571931e46fdc8c13016b10c5191
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/20230117/07f730c6/attachment-0001.html>
More information about the ghc-commits
mailing list