summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Ericson <John.Ericson@Obsidian.Systems>2019-12-16 18:07:13 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-04-22 23:10:28 -0400
commitdcb7fe5aa2bc331fa71b537b042ec08a7c79b1ac (patch)
tree86c990782701159aa962b164da530d8bce61a7ba
parente8a5d81b9358466f8889f679bfea9f796d85f7f3 (diff)
downloadhaskell-dcb7fe5aa2bc331fa71b537b042ec08a7c79b1ac.tar.gz
Remove panic in dsHandleMonadicFailure
Rework dsHandleMonadicFailure to be correct by construction instead of using an unreachable panic.
-rw-r--r--compiler/GHC/HsToCore/Expr.hs34
-rw-r--r--compiler/GHC/HsToCore/Utils.hs45
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~