From 0d4ad83ea32b4798e85d3410157e5e1fe34f927a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 16 Sep 2020 13:28:19 +0100 Subject: Account for RULES that destroy ok-for-speculation This patch addresses #18677. I'll write a proper commit message in due course. --- compiler/GHC/HsToCore/Binds.hs | 2 +- compiler/GHC/HsToCore/Expr.hs | 20 +++++++++----------- compiler/GHC/HsToCore/Match.hs | 2 +- compiler/GHC/HsToCore/Utils.hs | 12 ++++++------ 4 files changed, 17 insertions(+), 19 deletions(-) (limited to 'compiler/GHC/HsToCore') 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, -- cgit v1.2.1