SetLevels: Fix potential panic in lvlBind

3b31a94d introduced a use of isUnliftedType which can panic in the case
of levity-polymorphic types. Fix this by introducing mightBeUnliftedType
which returns whether the type is *guaranteed* to be lifted.

2 files changed, 14 insertions, 4 deletions

diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index e7187b3..8918725 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -89,7 +89,7 @@ import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increa
 import Name             ( getOccName, mkSystemVarName )
 import OccName          ( occNameString )
 import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
-                        , isUnliftedType, closeOverKindsDSet )
+                        , mightBeUnliftedType, closeOverKindsDSet )
 import BasicTypes       ( Arity, RecFlag(..), isRec )
 import DataCon          ( dataConOrigResTy )
 import TysWiredIn
@@ -1099,8 +1099,8 @@ lvlBind env (AnnRec pairs)
   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
          -- Only floating to the top level is allowed.
   || not (profitableFloat env dest_lvl)
-  || (isTopLvl dest_lvl && any (isUnliftedType . idType) bndrs)
-       -- This isUnliftedType stuff is the same test as in the non-rec case
+  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)
+       -- This mightBeUnliftedType stuff is the same test as in the non-rec case
        -- You might wonder whether we can have a recursive binding for
        -- an unlifted value -- but we can if it's a /join binding/ (#16978)
        -- (Ultimately I think we should not use SetLevels to
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index e65861a..94ee5af 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -126,7 +126,7 @@ module Type (
         tyConAppNeedsKindSig,
 
         -- (Lifting and boxity)
-        isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType,
+        isLiftedType_maybe, isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,
         isAlgType, isDataFamilyAppType,
         isPrimitiveType, isStrictType,
         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
@@ -2225,6 +2225,16 @@ isUnliftedType ty
   = not (isLiftedType_maybe ty `orElse`
          pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))
 
+-- | Returns:
+--
+-- * 'False' if the type is /guaranteed/ lifted or
+-- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case)
+mightBeUnliftedType :: Type -> Bool
+mightBeUnliftedType ty
+  = case isLiftedType_maybe ty of
+      Just is_lifted -> not is_lifted
+      Nothing -> True
+
 -- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)
 isRuntimeRepKindedTy :: Type -> Bool
 isRuntimeRepKindedTy = isRuntimeRepTy . typeKind