Account for RULES that destroy ok-for-speculationwip/T18677

This patch addresses #18677.

I'll write a proper commit message in due course.

9 files changed, 81 insertions, 48 deletions

diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index c242c776e6..8fc840fdec 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -6,7 +6,7 @@
 module GHC.Core.Make (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
-        mkCoreApp, mkCoreApps, mkCoreConApps,
+        mkCoreApp, mkCoreApps, mkCoreAppTyped, mkCoreConApps,
         mkCoreLams, mkWildCase, mkIfThenElse,
         mkWildValBinder, mkWildEvBinder,
         mkSingleAltCase,
@@ -139,19 +139,24 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
 --   See Note [Core let/app invariant] in "GHC.Core"
 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
 mkCoreApps fun args
-  = fst $
-    foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
+  = fst $ foldl' mk_core_app (fun, fun_ty) args
   where
-    doc_string = ppr fun_ty $$ ppr fun $$ ppr args
     fun_ty = exprType fun
 
 -- | Construct an expression which represents the application of one expression
 -- to the other
 -- Respects the let/app invariant by building a case expression where necessary
 --   See Note [Core let/app invariant] in "GHC.Core"
-mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreApp s fun arg
-  = fst $ mkCoreAppTyped s (fun, exprType fun) arg
+mkCoreApp :: HasDebugCallStack => CoreExpr -> CoreExpr -> CoreExpr
+mkCoreApp fun arg = mkCoreAppTyped fun (exprType fun) arg
+
+-- | Construct an expression which represents the application of one expression
+-- to the other.
+-- Precondition:  fun :: fun_ty
+-- Respects the let/app invariant by building a case expression where necessary
+--   See Note [Core let/app invariant] in "GHC.Core"
+mkCoreAppTyped :: HasDebugCallStack => CoreExpr -> Type -> CoreExpr -> CoreExpr
+mkCoreAppTyped fun fun_ty arg = fst $ mk_core_app (fun, fun_ty) arg
 
 -- | Construct an expression which represents the application of one expression
 -- paired with its type to an argument. The result is paired with its type. This
@@ -159,23 +164,24 @@ mkCoreApp s fun arg
 -- 'mkCoreApps'.
 -- Respects the let/app invariant by building a case expression where necessary
 --   See Note [Core let/app invariant] in "GHC.Core"
-mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
-mkCoreAppTyped _ (fun, fun_ty) (Type ty)
+mk_core_app :: HasDebugCallStack => (CoreExpr, Type) -> CoreExpr
+                                 -> (CoreExpr, Type)
+mk_core_app (fun, fun_ty) (Type ty)
   = (App fun (Type ty), piResultTy fun_ty ty)
-mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
+mk_core_app (fun, fun_ty) (Coercion co)
   = (App fun (Coercion co), funResultTy fun_ty)
-mkCoreAppTyped d (fun, fun_ty) arg
-  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
-    (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty)
+mk_core_app (fun, fun_ty) arg
+  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
+    (mkValApp fun arg arg_mult arg_ty res_ty, res_ty)
   where
-    (mult, arg_ty, res_ty) = splitFunTy fun_ty
+    (arg_mult, arg_ty, res_ty) = splitFunTy fun_ty
 
-mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
+mkValApp :: CoreExpr -> CoreExpr -> Mult -> Type -> Type -> CoreExpr
 -- Build an application (e1 e2),
 -- or a strict binding  (case e2 of x -> e1 x)
 -- using the latter when necessary to respect the let/app invariant
 --   See Note [Core let/app invariant] in GHC.Core
-mkValApp fun arg (Scaled w arg_ty) res_ty
+mkValApp fun arg w arg_ty res_ty
   | not (needsCaseBinding arg_ty arg)
   = App fun arg                -- The vastly common case
   | otherwise
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index e219a0dba9..23e4063786 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -27,7 +27,7 @@ import GHC.Core.FamInstEnv ( FamInstEnv )
 import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
 import GHC.Types.Id
 import GHC.Types.Id.Make   ( seqId )
-import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )
+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr, mkCoreAppTyped )
 import qualified GHC.Core.Make
 import GHC.Types.Id.Info
 import GHC.Types.Name           ( mkSystemVarName, isExternalName, getOccFS )
@@ -1335,13 +1335,21 @@ rebuild env expr cont
               ; (floats2, expr') <- simplLam env' bs body cont
               ; return (floats1 `addFloats` floats2, expr') }
 
+      -- These next cases two don't happen much, because a call with
+      -- a variable at the head (f e1 ... en) is handled via rebuildCall,
+      -- which constructs ArgInfo, and with the final result being built
+      -- by argInfoExpr.  We only get here for non-variable heads, like
+      --     (case blah of alts) e1 e2
       ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}
         -> rebuild env (App expr (Type ty)) cont
 
-      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
+      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag
+                 , sc_cont = cont, sc_hole_ty = fun_ty }
         -- See Note [Avoid redundant simplification]
         -> do { (_, _, arg') <- simplArg env dup_flag se arg
-              ; rebuild env (App expr arg') cont }
+              ; rebuild env (mkCoreAppTyped expr fun_ty arg') cont }
+                 -- mkCoreAppTyped: see Note [RULEs can break let/app]
+                 -- in GHC.Core.Opt.Simplify.Env
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 4ceaf637ed..304c3e5b83 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -615,9 +615,9 @@ mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff
 wrapFloats :: SimplFloats -> OutExpr -> OutExpr
 -- Wrap the floats around the expression; they should all
 -- satisfy the let/app invariant, so mkLets should do the job just fine
-wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _
+wrapFloats (SimplFloats { sfLetFloats  = lbs
                         , sfJoinFloats = jbs }) body
-  = foldrOL Let (wrapJoinFloats jbs body) bs
+  = wrapLetFloats lbs $ wrapJoinFloats jbs body
      -- Note: Always safe to put the joins on the inside
      -- since the values can't refer to them
 
@@ -640,6 +640,20 @@ getTopFloatBinds (SimplFloats { sfLetFloats  = lbs
   = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
     letFloatBinds lbs
 
+wrapLetFloats :: LetFloats -> OutExpr -> OutExpr
+wrapLetFloats (LetFloats bs _) body
+  = foldr wrap_bind body bs
+  where
+    wrap_bind bind body
+      | -- Horrid special case for a binding that doesn't satisfy
+        -- the let/app invariant; see Note [RULEs can break let/app]
+        NonRec bndr rhs <- bind
+      , isUnliftedType (idType bndr)
+      , not (exprOkForSpeculation rhs)
+      = Case rhs bndr (exprType rhs) [(DEFAULT, [], body)]
+      | otherwise
+      = Let bind body
+
 mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
 mapLetFloats (LetFloats fs ff) fun
    = LetFloats (mapOL app fs) ff
@@ -647,8 +661,11 @@ mapLetFloats (LetFloats fs ff) fun
     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
     app (Rec bs)     = Rec (map fun bs)
 
-{-
-************************************************************************
+{- Note [RULEs can break let/app]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+{- *********************************************************************
 *                                                                      *
                 Substitution of Vars
 *                                                                      *
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 420d406eed..df03ffc4fd 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -51,6 +51,7 @@ import GHC.Core.Ppr
 import GHC.Core.TyCo.Ppr ( pprParendType )
 import GHC.Core.FVs
 import GHC.Core.Utils
+import GHC.Core.Make     ( mkCoreAppTyped )
 import GHC.Core.Opt.Arity
 import GHC.Core.Unfold
 import GHC.Core.Unfold.Make
@@ -124,7 +125,7 @@ data SimplCont
 
   | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
       { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]
-      , sc_hole_ty :: OutType   -- Type of the function, presumably (forall a. blah)
+      , sc_hole_ty :: OutType   -- Type of the function, presumably (t1 -> t2)
                                 -- See Note [The hole type in ApplyToTy/Val]
       , sc_arg  :: InExpr       -- The argument,
       , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
@@ -358,10 +359,13 @@ argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
 argInfoExpr fun rev_args
   = go rev_args
   where
-    go []                              = Var fun
-    go (ValArg { as_arg = arg }  : as) = go as `App` arg
-    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty
-    go (CastBy co                : as) = mkCast (go as) co
+    go []                                     = Var fun
+    go (ValArg { as_arg = arg
+               , as_hole_ty = fun_ty } : as) = mkCoreAppTyped (go as) fun_ty arg
+       -- mkCoreAppTyped: see Note [RULEs can break let/app]
+       -- in GHC.Core.Opt.Simplify.Env
+    go (TyArg { as_arg_ty = ty }       : as) = go as `App` Type ty
+    go (CastBy co                      : as) = mkCast (go as) co
 
 
 type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 8cc0eaa503..d74ba30895 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -469,7 +469,7 @@ mkWWargs subst fun_ty demands
     apply_or_bind_then k arg (Lam bndr body)
       = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!
     apply_or_bind_then k arg fun
-      = k $ mkCoreApp (text "mkWWargs") fun arg
+      = k $ mkCoreApp fun arg
 applyToVars :: [Var] -> CoreExpr -> CoreExpr
 applyToVars vars fn = mkVarApps fn vars
 
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 3adecc0d5b..8081d921ac 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -1136,7 +1136,7 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)
                               = do { x <- newSysLocalDsNoLP w t1
                                    ; w1 <- dsHsWrapper c1
                                    ; w2 <- dsHsWrapper c2
-                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+                                   ; let app f a = mkCoreAppDs f a
                                          arg     = w1 (Var x)
                                    ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
                                    ; if ok
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index be61777722..0e0402077a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -315,10 +315,10 @@ dsExpr (HsLamCase _ matches)
   = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
        ; return $ Lam discrim_var matching_code }
 
-dsExpr e@(HsApp _ fun arg)
+dsExpr (HsApp _ fun arg)
   = do { fun' <- dsLExpr fun
        ; dsWhenNoErrs (dsLExprNoLP arg)
-                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
+                      (\arg' -> mkCoreAppDs fun' arg') }
 
 dsExpr (HsAppType ty e _)
   = do { e' <- dsLExpr e
@@ -384,11 +384,11 @@ bindNonRec will automatically do the right thing, giving us:
 See #18151.
 -}
 
-dsExpr e@(OpApp _ e1 op e2)
+dsExpr (OpApp _ e1 op e2)
   = -- for the type of y, we need the type of op's 2nd argument
     do { op' <- dsLExpr op
        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
-                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
+                      (\exprs' -> mkCoreAppsDs op' exprs') }
 
 -- dsExpr (SectionL op expr)  ===  (expr `op`)  ~>  \y -> op expr y
 --
@@ -404,26 +404,24 @@ dsExpr e@(SectionL _ expr op) = do
           (newSysLocalsDsNoLP [x_ty, y_ty])
           (\[x_id, y_id] ->
             bindNonRec x_id x_core
-            $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)
-                                     core_op [Var x_id, Var y_id]))
+            $ Lam y_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 
       -- Postfix operator section
       (_:_, _) -> do
-        return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core
+        return $ mkCoreAppDs core_op x_core
 
       _ -> pprPanic "dsExpr(SectionL)" (ppr e)
 
 -- dsExpr (SectionR op expr)  === (`op` expr)  ~>  \x -> op x expr
 --
 -- See Note [Desugaring operator sections].
-dsExpr e@(SectionR _ op expr) = do
+dsExpr (SectionR _ op expr) = do
     core_op <- dsLExpr op
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
     y_core <- dsLExpr expr
     dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty])
                  (\[x_id, y_id] -> bindNonRec y_id y_core $
-                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
-                                                          core_op [Var x_id, Var y_id]))
+                                   Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 
 dsExpr (ExplicitTuple _ tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty)))
@@ -1083,7 +1081,7 @@ dsConLike :: ConLike -> DsM CoreExpr
 dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)
 dsConLike (PatSynCon ps)   = return $ case patSynBuilder ps of
   Just (id, add_void)
-    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+    | add_void  -> App (Var id) (Var voidPrimId)
     | otherwise -> Var id
   _ -> pprPanic "dsConLike" (ppr ps)
 
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a33e3d9b41..660b942525 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -300,7 +300,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
          -- compile the view expressions
         ; viewExpr' <- dsLExpr viewExpr
         ; return (mkViewMatchResult var'
-                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    (mkCoreAppDs viewExpr' (Var var))
                     match_result) }
 
 matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index b4d1b1b761..bb8a869b09 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -326,7 +326,7 @@ mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $
                          nlHsTyApp matcher [getRuntimeRep ty, ty]
     cont <- mkCoreLams bndrs <$> runMatchResult fail match_result
-    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
@@ -485,8 +485,8 @@ There are a few subtleties in the desugaring of `seq`:
 -}
 
 -- NB: Make sure the argument is not levity polymorphic
-mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+mkCoreAppDs  :: HasDebugCallStack => CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)
   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
   where
@@ -495,11 +495,11 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg
                           -> v1        -- Note [Desugaring seq], points (2) and (3)
                    _      -> mkWildValBinder Many ty1
 
-mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make
+mkCoreAppDs fun arg = mkCoreApp fun arg  -- The rest is done in GHC.Core.Make
 
 -- NB: No argument can be levity polymorphic
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
+mkCoreAppsDs :: HasDebugCallStack => CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs fun args = foldl' mkCoreAppDs fun args
 
 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
 -- We define a desugarer-specific version of GHC.Core.Utils.mkCast,