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

This patch addresses #18677.

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

4 files changed, 17 insertions, 19 deletions

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,