Eta expand through CallStackswip/T19918

This patch fixes #20103, by treating HasCallStack constraints as
cheap when eta-expanding.

See Note [Eta expanding through CallStacks] in GHC.Core.Opt.Arity

3 files changed, 55 insertions, 24 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index e5e63aca26..b2476d39f0 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -39,7 +39,7 @@ import GHC.Core.Utils
 import GHC.Core.DataCon
 import GHC.Core.TyCon     ( tyConArity )
 import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )
-import GHC.Core.Predicate ( isDictTy )
+import GHC.Core.Predicate ( isDictTy, isCallStackPredTy )
 import GHC.Core.Multiplicity
 
 -- We have two sorts of substitution:
@@ -835,6 +835,17 @@ topDiv.
 
 Historical note: long ago, we unconditionally switched to topDiv when we
 encountered a cast, but that is far too conservative: see #5475
+
+Note [Eta expanding through CallStacks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Just as it's good to eta-expand through dictionaries, so it is good to
+do so through CallStacks.  #20103 is a case in point, where we got
+  foo :: HasCallStack => Int -> Int
+  foo = \(d::CallStack). let d2 = pushCallStack blah d in
+        \(x:Int). blah
+
+We really want to eta-expand this!  #20103 is quite convincing!
+We do this regardless of -fdicts-cheap; it's not really a dictionary.
 -}
 
 ---------------------------
@@ -963,7 +974,13 @@ myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of
   BotStrictness -> False
   _             -> cheap_dict || cheap_fun e
     where
-      cheap_dict = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True
+      cheap_dict = case mb_ty of
+                     Nothing -> False
+                     Just ty -> (am_dicts_cheap mode && isDictTy ty)
+                                || isCallStackPredTy ty
+        -- See Note [Eta expanding through dictionaries]
+        -- See Note [Eta expanding through CallStacks]
+
       cheap_fun e = case mode of
 #if __GLASGOW_HASKELL__ <= 900
         BotStrictness                -> panic "impossible"
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index 43f52b9b5c..9601a92138 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -24,6 +24,7 @@ module GHC.Core.Predicate (
 
   -- Implicit parameters
   isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,
+  isCallStackTy, isCallStackPred, isCallStackPredTy,
 
   -- Evidence variables
   DictId, isEvVar, isDictId
@@ -44,6 +45,7 @@ import GHC.Builtin.Names
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Panic
+import GHC.Data.FastString( FastString )
 
 
 -- | A predicate in the solver. The solver tries to prove Wanted predicates
@@ -257,6 +259,39 @@ has_ip_super_classes rec_clss cls tys
 initIPRecTc :: RecTcChecker
 initIPRecTc = setRecTcMaxBound 1 initRecTc
 
+-- --------------------- CallStack predicates ---------------------------------
+
+isCallStackPredTy :: Type -> Bool
+-- True of HasCallStack, or IP "blah" CallStack
+isCallStackPredTy ty
+  | Just (tc, tys) <- splitTyConApp_maybe ty
+  , Just cls <- tyConClass_maybe tc
+  , Just {} <- isCallStackPred cls tys
+  = True
+  | otherwise
+  = False
+
+-- | Is a 'PredType' a 'CallStack' implicit parameter?
+--
+-- If so, return the name of the parameter.
+isCallStackPred :: Class -> [Type] -> Maybe FastString
+isCallStackPred cls tys
+  | [ty1, ty2] <- tys
+  , isIPClass cls
+  , isCallStackTy ty2
+  = isStrLitTy ty1
+  | otherwise
+  = Nothing
+
+-- | Is a type a 'CallStack'?
+isCallStackTy :: Type -> Bool
+isCallStackTy ty
+  | Just tc <- tyConAppTyCon_maybe ty
+  = tc `hasKey` callStackTyConKey
+  | otherwise
+  = False
+
+
 {- Note [Local implicit parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The function isIPLikePred tells if this predicate, or any of its
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 9a67143892..367922e3e5 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -80,7 +80,7 @@ module GHC.Tc.Utils.TcType (
   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isNaturalTy,
-  isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
+  isBoolTy, isUnitTy, isCharTy,
   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
   isPredTy, isTyVarClassPred,
   checkValidClsArgs, hasTyVarHead,
@@ -228,7 +228,6 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
 import GHC.Utils.Error( Validity(..), isValid )
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -2120,26 +2119,6 @@ isStringTy ty
       Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
       _                   -> False
 
--- | Is a type a 'CallStack'?
-isCallStackTy :: Type -> Bool
-isCallStackTy ty
-  | Just tc <- tyConAppTyCon_maybe ty
-  = tc `hasKey` callStackTyConKey
-  | otherwise
-  = False
-
--- | Is a 'PredType' a 'CallStack' implicit parameter?
---
--- If so, return the name of the parameter.
-isCallStackPred :: Class -> [Type] -> Maybe FastString
-isCallStackPred cls tys
-  | [ty1, ty2] <- tys
-  , isIPClass cls
-  , isCallStackTy ty2
-  = isStrLitTy ty1
-  | otherwise
-  = Nothing
-
 is_tc :: Unique -> Type -> Bool
 -- Newtypes are opaque to this
 is_tc uniq ty = case tcSplitTyConApp_maybe ty of