Commit 333a855f authored by John Ericson's avatar John Ericson

Get rid of failure

parent 2e6155e1
Pipeline #13782 failed with stages
in 479 minutes and 2 seconds
......@@ -994,14 +994,14 @@ dsDo stmts
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure pat match fail_op
| matchCanFail match
= do { 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 fail_op =
case shareFailureHandler match of
MatchResult_Unfailable body -> body
MatchResult_Failable body -> do
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 DsUtils (
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
shareFailureHandler,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
......@@ -206,30 +207,22 @@ cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr = MatchResult_Unfailable $ return expr
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult (MatchResult_Unfailable match_fn) _
= match_fn
extractMatchResult (MatchResult_Failable 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 (MatchResult_Failable body_fn1)
(MatchResult_Failable body_fn2)
= MatchResult_Failable $ \fail -> do
body2 <- body_fn2 fail
(fail_bind, duplicatable_expr) <- mkFailurePair body2
body1 <- body_fn1 duplicatable_expr
return (Let fail_bind body1)
combineMatchResults (MatchResult_Failable body_fn1)
(MatchResult_Unfailable body_fn2)
= MatchResult_Unfailable $ do
body2 <- body_fn2
(fail_bind, duplicatable_expr) <- mkFailurePair body2
body1 <- body_fn1 duplicatable_expr
return (Let fail_bind body1)
combineMatchResults match_result1@(MatchResult_Unfailable _) _
= 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
MatchResult_Unfailable _ -> match_result1
MatchResult_Failable body_fn1 -> MatchResult_Failable $ \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
......@@ -858,6 +851,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@(MatchResult_Unfailable _) -> mr
MatchResult_Failable match_fn -> MatchResult_Failable $ \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