2 files changed, 54 insertions, 2 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