Commit dcb7fe5a authored by John Ericson's avatar John Ericson Committed by Marge Bot
Browse files

Remove panic in dsHandleMonadicFailure

Rework dsHandleMonadicFailure to be correct by construction instead of
using an unreachable panic.
parent e8a5d81b
......@@ -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 " ++
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment