2 files changed, 42 insertions, 37 deletions

diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 2432680900..54f17b712e 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -1017,23 +1017,23 @@ dsDo stmts
 dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match m_fail_op
-  | matchCanFail match = do
-    fail_op <- case m_fail_op of
-      -- Note that (non-monadic) list comprehension, pattern guards, etc could
-      -- have fallible bindings without an explicit failure op, but this is
-      -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-      -- breakdown of regular and special binds.
-      Nothing -> pprPanic "missing fail op" $
-        text "Pattern match:" <+> ppr pat <+>
-        text "is failable, and fail_expr was left unset"
-      Just fail_op -> pure fail_op
-    dflags <- getDynFlags
-    fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-    fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-    extractMatchResult match fail_expr
-  | otherwise =
-    extractMatchResult match (error "It can't fail")
+dsHandleMonadicFailure pat match m_fail_op =
+  case shareFailureHandler match of
+    MR_Infallible body -> body
+    MR_Fallible body -> do
+      fail_op <- case m_fail_op of
+        -- Note that (non-monadic) list comprehension, pattern guards, etc could
+        -- have fallible bindings without an explicit failure op, but this is
+        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+        -- breakdown of regular and special binds.
+        Nothing -> pprPanic "missing fail op" $
+          text "Pattern match:" <+> ppr pat <+>
+          text "is failable, and fail_expr was left unset"
+        Just fail_op -> pure fail_op
+      dflags <- getDynFlags
+      fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+      fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+      body fail_expr
 
 mk_fail_msg :: DynFlags -> Located e -> String
 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 74c31f0a0f..5982a07dde 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -23,6 +23,7 @@ module GHC.HsToCore.Utils (
         cantFailMatchResult, alwaysFailMatchResult,
         extractMatchResult, combineMatchResults,
         adjustMatchResult,  adjustMatchResultDs,
+        shareFailureHandler,
         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
         matchCanFail, mkEvalMatchResult,
         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
@@ -207,30 +208,22 @@ cantFailMatchResult :: CoreExpr -> MatchResult
 cantFailMatchResult expr = MR_Infallible $ return expr
 
 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
-extractMatchResult (MR_Infallible match_fn) _
-  = match_fn
-extractMatchResult (MR_Fallible match_fn) fail_expr = do
-    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
-    body <- match_fn if_it_fails
-    return (mkCoreLet fail_bind body)
+extractMatchResult match_result failure_expr =
+  runMatchResult
+    failure_expr
+    (shareFailureHandler match_result)
 
 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
-combineMatchResults (MR_Fallible body_fn1)
-                    (MR_Fallible body_fn2)
-  = MR_Fallible $ \fail -> do
-      body2 <- body_fn2 fail
-      (fail_bind, duplicatable_expr) <- mkFailurePair body2
-      body1 <- body_fn1 duplicatable_expr
-      return (Let fail_bind body1)
-combineMatchResults (MR_Fallible body_fn1)
-                    (MR_Infallible body_fn2)
-  = MR_Infallible $ do
-      body2 <- body_fn2
-      (fail_bind, duplicatable_expr) <- mkFailurePair body2
-      body1 <- body_fn1 duplicatable_expr
-      return (Let fail_bind body1)
 combineMatchResults match_result1@(MR_Infallible _) _
   = match_result1
+combineMatchResults match_result1 match_result2 =
+  -- if the first pattern needs a failure handler (i.e. if it is is fallible),
+  -- make it let-bind it bind it with `shareFailureHandler`.
+  case shareFailureHandler match_result1 of
+    MR_Infallible _ -> match_result1
+    MR_Fallible body_fn1 -> MR_Fallible $ \fail_expr ->
+      -- Before actually failing, try the next match arm.
+      body_fn1 =<< runMatchResult fail_expr match_result2
 
 adjustMatchResult :: (a -> b) -> MatchResult' a -> MatchResult' b
 adjustMatchResult = fmap
@@ -861,6 +854,18 @@ mkFailurePair expr
   where
     ty = exprType expr
 
+-- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have
+-- neither a failure arg or failure "hole", so nothing is let-bound, and no
+-- extraneous Core is produced.
+shareFailureHandler :: MatchResult -> MatchResult
+shareFailureHandler = \case
+  mr@(MR_Infallible _) -> mr
+  MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do
+    (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr
+    body <- match_fn shared_failure_handler
+    -- Never unboxed, per the above, so always OK for `let` not `case`.
+    return $ Let fail_bind body
+
 {-
 Note [Failure thunks and CPR]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~