WIP on isLiftedType_maybe

3 files changed, 24 insertions, 17 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 85cc635791..6261c2a16b 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -741,26 +741,33 @@ isLiftedRuntimeRep rep
   | otherwise
   = False
 
-isUnliftedRuntimeRep :: Type -> Bool
--- PRECONDITION: The type has kind RuntimeRep
--- True of definitely-unlifted RuntimeReps
--- False of           (LiftedRep :: RuntimeRep)
---   and of variables (a :: RuntimeRep)
-isUnliftedRuntimeRep rep
-  | TyConApp rr_tc args <- coreFullView rep -- NB: args might be non-empty
-                                            --     e.g. TupleRep [r1, .., rn]
+isLiftedRuntimeRep_maybe :: Type -> Maybe Bool
+-- isLiftedRuntimeRep rr returns
+-- * Just True  if rr is LiftedRep :: RuntimeRep
+-- * Just False if rr is definitely not lifted, e.g. IntRep
+-- * Nothing    if not known (e.g. (a :: RuntimeRep))
+isLiftedRuntimeRep_maybe rep
+  | TyConApp rr_tc args <- coreFullView rep
   , isPromotedDataCon rr_tc =
       -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]
       if (rr_tc `hasKey` boxedRepDataConKey)
         then case args of
-          [lev] -> isUnliftedLevity lev
-          _     -> False
-        else True
+          [lev] | isLiftedLevity lev   -> Just True
+                | isUnliftedLevity lev -> Just False
+          _                            -> Nothing
+        else Just False
         -- Avoid searching all the unlifted RuntimeRep type cons
         -- In the RuntimeRep data type, only LiftedRep is lifted
         -- But be careful of type families (F tys) :: RuntimeRep,
         -- hence the isPromotedDataCon rr_tc
-isUnliftedRuntimeRep _ = False
+isLiftedRuntimeRep_maybe _ = Nothing
+
+isUnliftedRuntimeRep :: Type -> Bool
+-- PRECONDITION: The type has kind RuntimeRep
+-- True of definitely-unlifted RuntimeReps
+-- False of           (LiftedRep :: RuntimeRep)
+--   and of variables (a :: RuntimeRep)
+isUnliftedRuntimeRep rep = isLiftedRuntimeRep_maybe rep == Just False
 
 -- | An INLINE helper for function such as 'isLiftedRuntimeRep' below.
 isNullaryTyConKeyApp :: Unique -> Type -> Bool
@@ -2397,10 +2404,7 @@ buildSynTyCon name binders res_kind roles rhs
 -- representation-polymorphic), and panics if the kind does not have the shape
 -- TYPE r.
 isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool
-isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of
-  ty' | isLiftedRuntimeRep ty'  -> Just True
-  TyConApp {}                   -> Just False  -- Everything else is unlifted
-  _                             -> Nothing     -- representation-polymorphic
+isLiftedType_maybe ty = isLiftedRuntimeRep_maybe (getRuntimeRep ty)
 
 -- | See "Type#type_classification" for what an unlifted type is.
 -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 7623c6e710..ddaa543f26 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -674,7 +674,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 || isUnliftedType (idType arg) ]
+        , isBanged bang || isLiftedType_maybe (idType arg) == Just False ]
 
 -- | 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
diff --git a/testsuite/tests/rep-poly/Makefile b/testsuite/tests/rep-poly/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/rep-poly/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk