[Git][ghc/ghc][master] 5 commits: Refactor the `MatchResult` type in the desugarer
Marge Bot
gitlab at gitlab.haskell.org
Thu Apr 23 03:10:40 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e8a5d81b by Jonathan DK Gibbons at 2020-04-22T23:10:28-04:00
Refactor the `MatchResult` type in the desugarer
This way, it does a better job of proving whether or not the fail operator is used.
- - - - -
dcb7fe5a by John Ericson at 2020-04-22T23:10:28-04:00
Remove panic in dsHandleMonadicFailure
Rework dsHandleMonadicFailure to be correct by construction instead of
using an unreachable panic.
- - - - -
cde23cd4 by John Ericson at 2020-04-22T23:10:28-04:00
Inline `adjustMatchResult`
It is just `fmap`
- - - - -
72cb6bcc by John Ericson at 2020-04-22T23:10:28-04:00
Generalize type of `matchCanFail`
- - - - -
401f7bb3 by John Ericson at 2020-04-22T23:10:28-04:00
`MatchResult'` -> `MatchResult`
Inline `MatchResult` alias accordingly.
- - - - -
9 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Expr.hs-boot
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Utils.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -1014,26 +1014,26 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> 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 " ++
=====================================
compiler/GHC/HsToCore/Expr.hs-boot
=====================================
@@ -9,4 +9,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -52,7 +52,7 @@ dsGuarded grhss rhs_ty mb_rhss_deltas = do
error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
extractMatchResult match_result error_expr
--- In contrast, @dsGRHSs@ produces a @MatchResult at .
+-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr at .
dsGRHSs :: HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
@@ -60,7 +60,7 @@ dsGRHSs :: HsMatchContext GhcRn
-> Maybe (NonEmpty Deltas) -- ^ Refined pattern match checking
-- models, one for each GRHS. Defaults
-- to 'initDeltas' if 'Nothing'.
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas
= ASSERT( notNull grhss )
do { match_results <- case toList <$> mb_rhss_deltas of
@@ -73,14 +73,14 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas
; return match_result2 }
dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc)
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs))
= updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty)
{-
************************************************************************
* *
-* matchGuard : make a MatchResult from a guarded RHS *
+* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS *
* *
************************************************************************
-}
@@ -89,7 +89,7 @@ matchGuards :: [GuardStmt GhcTc] -- Guard
-> HsStmtContext GhcRn -- Context
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
-- See comments with HsExpr.Stmt re what a BodyStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
@@ -130,7 +130,7 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
match_result
- pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
+ pure $ bindNonRec match_var core_rhs <$> match_result'
matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -174,7 +174,7 @@ type MatchId = Id -- See Note [Match Ids]
match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids]
-> Type -- ^ Type of the case expression
-> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
- -> DsM MatchResult -- ^ Desugared result!
+ -> DsM (MatchResult CoreExpr) -- ^ Desugared result!
match [] ty eqns
= ASSERT2( not (null eqns), ppr ty )
@@ -198,20 +198,21 @@ match (v:vs) ty eqns -- Eqns *can* be empty
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- match_groups grouped
- ; return (adjustMatchResult (foldr (.) id aux_binds) $
- foldr1 combineMatchResults match_results) }
+ ; return $ foldr (.) id aux_binds <$>
+ foldr1 combineMatchResults match_results
+ }
where
vars = v :| vs
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup = fmap snd
- match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)
- -- Result list of [MatchResult] is always non-empty
+ match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
+ -- Result list of [MatchResult CoreExpr] is always non-empty
match_groups [] = matchEmpty v ty
match_groups (g:gs) = mapM match_group $ g :| gs
- match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult
+ match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
match_group eqns@((group,_) :| _)
= case group of
PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -245,26 +246,26 @@ match (v:vs) ty eqns -- Eqns *can* be empty
maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
(filter (not . null) gs))
-matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult)
+matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
-- See Note [Empty case expressions]
matchEmpty var res_ty
- = return [MatchResult CanFail mk_seq]
+ = return [MR_Fallible mk_seq]
where
mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
[(DEFAULT, [], fail)]
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
-matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs (var :| vars) ty eqns
= do { match_result <- match (var:vars) ty $ NEL.toList $
decomposeFirstPat getBangPat <$> eqns
; return (mkEvalMatchResult var ty match_result) }
-matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- Apply the coercion to the match variable and then match that
matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
= do { let CoPat _ co pat _ = firstPat eqn1
@@ -276,7 +277,7 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
; let bind = NonRec var' (core_wrap (Var var))
; return (mkCoLetMatchResult bind match_result) }
-matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- Apply the view function to the match variable and then match that
matchView (var :| vars) ty (eqns@(eqn1 :| _))
= do { -- we could pass in the expr from the PgView,
@@ -294,7 +295,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
(mkCoreAppDs (text "matchView") viewExpr' (Var var))
match_result) }
-matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
@@ -829,7 +830,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
- -> Type -> MatchResult -> DsM MatchResult
+ -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
--
@@ -844,11 +845,12 @@ matchSinglePat (Var var) ctx pat ty match_result
matchSinglePat scrut hs_ctx pat ty match_result
= do { var <- selectSimpleMatchVarL pat
; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
- ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+ ; return $ bindNonRec var scrut <$> match_result'
+ }
matchSinglePatVar :: Id -- See Note [Match Ids]
-> HsMatchContext GhcRn -> LPat GhcTc
- -> Type -> MatchResult -> DsM MatchResult
+ -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var ctx pat ty match_result
= ASSERT2( isInternalName (idName var), ppr var )
do { dflags <- getDynFlags
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -11,7 +11,7 @@ import GHC.Hs.Extension ( GhcRn, GhcTc )
match :: [Id]
-> Type
-> [EquationInfo]
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
matchWrapper
:: HsMatchContext GhcRn
@@ -32,5 +32,5 @@ matchSinglePatVar
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
- -> MatchResult
- -> DsM MatchResult
+ -> MatchResult CoreExpr
+ -> DsM (MatchResult CoreExpr)
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -27,6 +27,7 @@ import GHC.Types.Basic ( Origin(..) )
import GHC.Tc.Utils.TcType
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
+import GHC.Core ( CoreExpr )
import GHC.Core.Make ( mkCoreLets )
import Util
import GHC.Types.Id
@@ -94,7 +95,7 @@ have-we-used-all-the-constructors? question; the local function
matchConFamily :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfo)
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
-- Each group of eqns is for a single constructor
matchConFamily (var :| vars) ty groups
= do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
@@ -107,7 +108,7 @@ matchConFamily (var :| vars) ty groups
matchPatSyn :: NonEmpty Id
-> Type
-> NonEmpty EquationInfo
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
matchPatSyn (var :| vars) ty eqns
= do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
return (mkCoSynCaseMatchResult var ty alt)
@@ -134,14 +135,15 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
-- and returns the types of the *value* args, which is what we want
match_group :: [Id]
- -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
+ -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
= ASSERT( notNull arg_eqn_prs )
do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
- ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+ ; return $ foldr1 (.) wraps <$> match_result
+ }
shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -407,7 +407,7 @@ tidyNPat over_lit mb_neg eq outer_ty
matchLiterals :: NonEmpty Id
-> Type -- ^ Type of the whole case expression
-> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
- -> DsM MatchResult
+ -> DsM (MatchResult CoreExpr)
matchLiterals (var :| vars) ty sub_groups
= do { -- Deal with each group
@@ -424,7 +424,7 @@ matchLiterals (var :| vars) ty sub_groups
return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
- match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)
+ match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
match_group eqns@(firstEqn :| _)
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
@@ -432,7 +432,7 @@ matchLiterals (var :| vars) ty sub_groups
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
- wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
+ wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
-- Equality check for string literals
wrap_str_guard eq_str (LitString s, mr)
= do { -- We now have to convert back to FastString. Perhaps there
@@ -473,7 +473,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
************************************************************************
-}
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
= do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
@@ -502,7 +502,7 @@ We generate:
\end{verbatim}
-}
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
= do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
@@ -515,7 +515,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
- adjustMatchResult (foldr1 (.) wraps) $
+ fmap (foldr1 (.) wraps) $
match_result) }
where
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -6,10 +6,14 @@
Monadery used in desugaring
-}
-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
+
module GHC.HsToCore.Monad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
@@ -42,8 +46,7 @@ module GHC.HsToCore.Monad (
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
- CanItFail(..), orFail,
+ EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-- Levity polymorphism
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
@@ -119,7 +122,7 @@ data EquationInfo
-- @W# -1## :: Word@, but we shouldn't warn about an overflowed
-- literal for /both/ of these cases.
- , eqn_rhs :: MatchResult
+ , eqn_rhs :: MatchResult CoreExpr
-- ^ What to do after match
}
@@ -130,25 +133,38 @@ type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper e = e
--- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
-- \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap
-
--- A MatchResult is an expression with a hole in it
-data MatchResult
- = MatchResult
- CanItFail -- Tells whether the failure expression is used
- (CoreExpr -> DsM CoreExpr)
- -- Takes a expression to plug in at the
- -- failure point(s). The expression should
- -- be duplicatable!
-
-data CanItFail = CanFail | CantFail
-
-orFail :: CanItFail -> CanItFail -> CanItFail
-orFail CantFail CantFail = CantFail
-orFail _ _ = CanFail
+-- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
+-- This is used to deal with cases where we are potentially handling pattern
+-- match failure, and want to later specify how failure is handled.
+data MatchResult a
+ -- | We represent the case where there is no hole without a function from
+ -- 'CoreExpr', like this, because sometimes we have nothing to put in the
+ -- hole and so want to be sure there is in fact no hole.
+ = MR_Infallible (DsM a)
+ | MR_Fallible (CoreExpr -> DsM a)
+ deriving (Functor)
+
+-- | Product is an "or" on falliblity---the combined match result is infallible
+-- only if the left and right argument match results both were.
+--
+-- This is useful for combining a bunch of alternatives together and then
+-- getting the overall falliblity of the entire group. See 'mkDataConCase' for
+-- an example.
+instance Applicative MatchResult where
+ pure v = MR_Infallible (pure v)
+ MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
+ f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x
+
+-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
+-- the MatchResult CoreExpr was failable or not.
+runMatchResult :: CoreExpr -> MatchResult a -> DsM a
+runMatchResult fail = \case
+ MR_Infallible body -> body
+ MR_Fallible body_fn -> body_fn fail
{-
************************************************************************
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -10,6 +10,7 @@ This module exports some utility functions of no great interest.
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -18,10 +19,11 @@ module GHC.HsToCore.Utils (
EquationInfo(..),
firstPat, shiftEqns,
- MatchResult(..), CanItFail(..), CaseAlt(..),
+ MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
- adjustMatchResult, adjustMatchResultDs,
+ adjustMatchResultDs,
+ shareFailureHandler,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
@@ -85,6 +87,7 @@ import GHC.Tc.Types.Evidence
import Control.Monad ( zipWithM )
import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe (maybeToList)
import qualified Data.List.NonEmpty as NEL
{-
@@ -192,48 +195,42 @@ shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
--- Functions on MatchResults
+-- Functions on MatchResult CoreExprs
-matchCanFail :: MatchResult -> Bool
-matchCanFail (MatchResult CanFail _) = True
-matchCanFail (MatchResult CantFail _) = False
+matchCanFail :: MatchResult a -> Bool
+matchCanFail (MR_Fallible {}) = True
+matchCanFail (MR_Infallible {}) = False
-alwaysFailMatchResult :: MatchResult
-alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
+alwaysFailMatchResult :: MatchResult CoreExpr
+alwaysFailMatchResult = MR_Fallible $ \fail -> return fail
-cantFailMatchResult :: CoreExpr -> MatchResult
-cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
+cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr
+cantFailMatchResult expr = MR_Infallible $ return expr
-extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
-extractMatchResult (MatchResult CantFail match_fn) _
- = match_fn (error "It can't fail!")
+extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
+extractMatchResult match_result failure_expr =
+ runMatchResult
+ failure_expr
+ (shareFailureHandler match_result)
-extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
- (fail_bind, if_it_fails) <- mkFailurePair fail_expr
- body <- match_fn if_it_fails
- return (mkCoreLet fail_bind body)
-
-
-combineMatchResults :: MatchResult -> MatchResult -> MatchResult
-combineMatchResults (MatchResult CanFail body_fn1)
- (MatchResult can_it_fail2 body_fn2)
- = MatchResult can_it_fail2 body_fn
- where
- body_fn fail = do body2 <- body_fn2 fail
- (fail_bind, duplicatable_expr) <- mkFailurePair body2
- body1 <- body_fn1 duplicatable_expr
- return (Let fail_bind body1)
-
-combineMatchResults match_result1@(MatchResult CantFail _) _
+combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
+combineMatchResults match_result1@(MR_Infallible _) _
= match_result1
-
-adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
-adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
- = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
-
-adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
-adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
- = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
+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
+
+adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b
+adjustMatchResultDs encl_fn = \case
+ MR_Infallible body_fn -> MR_Infallible $
+ encl_fn =<< body_fn
+ MR_Fallible body_fn -> MR_Fallible $ \fail ->
+ encl_fn =<< body_fn fail
wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
@@ -247,51 +244,50 @@ wrapBind new old body -- NB: this function must deal with term
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = mkDefaultCase (Var var) var body
-mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
-mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
+mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
+mkCoLetMatchResult bind = fmap (mkCoreLet bind)
-- (mkViewMatchResult var' viewExpr mr) makes the expression
-- let var' = viewExpr in mr
-mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr =
- adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
+mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr
-mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
-mkEvalMatchResult var ty
- = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr
+mkEvalMatchResult var ty = fmap $ \e ->
+ Case (Var var) var ty [(DEFAULT, [], e)]
-mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
-mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
- = MatchResult CanFail (\fail -> do body <- body_fn fail
- return (mkIfThenElse pred_expr body fail))
+mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
+mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do
+ body <- runMatchResult fail mr
+ return (mkIfThenElse pred_expr body fail)
mkCoPrimCaseMatchResult :: Id -- Scrutinee
-> Type -- Type of the case
- -> [(Literal, MatchResult)] -- Alternatives
- -> MatchResult -- Literals are all unlifted
+ -> [(Literal, MatchResult CoreExpr)] -- Alternatives
+ -> MatchResult CoreExpr -- Literals are all unlifted
mkCoPrimCaseMatchResult var ty match_alts
- = MatchResult CanFail mk_case
+ = MR_Fallible mk_case
where
mk_case fail = do
alts <- mapM (mk_alt fail) sorted_alts
return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
sorted_alts = sortWith fst match_alts -- Right order for a Case
- mk_alt fail (lit, MatchResult _ body_fn)
+ mk_alt fail (lit, mr)
= ASSERT( not (litIsLifted lit) )
- do body <- body_fn fail
+ do body <- runMatchResult fail mr
return (LitAlt lit, [], body)
data CaseAlt a = MkCaseAlt{ alt_pat :: a,
alt_bndrs :: [Var],
alt_wrapper :: HsWrapper,
- alt_result :: MatchResult }
+ alt_result :: MatchResult CoreExpr }
mkCoAlgCaseMatchResult
:: Id -- ^ Scrutinee
-> Type -- ^ Type of exp
-> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
- -> MatchResult
+ -> MatchResult CoreExpr
mkCoAlgCaseMatchResult var ty match_alts
| isNewtype -- Newtype case; use a let
= ASSERT( null match_alts_tail && null (tail arg_ids1) )
@@ -314,15 +310,14 @@ mkCoAlgCaseMatchResult var ty match_alts
-- (not that splitTyConApp does, these days)
newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
-mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
+mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr
+mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
nlHsTyApp matcher [getRuntimeRep ty, ty]
- let MatchResult _ mkCont = match_result
- cont <- mkCoreLams bndrs <$> mkCont fail
+ cont <- mkCoreLams bndrs <$> runMatchResult fail match_result
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
@@ -336,49 +331,47 @@ mkPatSynCase var ty alt fail = do
ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
| otherwise = cont
-mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult
-mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case
+mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
+mkDataConCase var ty alts@(alt1 :| _)
+ = liftA2 mk_case mk_default mk_alts
+ -- The liftA2 combines the failability of all the alternatives and the default
where
con1 = alt_pat alt1
tycon = dataConTyCon con1
data_cons = tyConDataCons tycon
- match_results = fmap alt_result alts
- sorted_alts :: NonEmpty (CaseAlt DataCon)
- sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts
+ sorted_alts :: [ CaseAlt DataCon ]
+ sorted_alts = sortWith (dataConTag . alt_pat) $ NEL.toList alts
var_ty = idType var
(_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
-- (not that splitTyConApp does, these days)
- mk_case :: CoreExpr -> DsM CoreExpr
- mk_case fail = do
- alts <- mapM (mk_alt fail) sorted_alts
- return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts)
-
- mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
- mk_alt fail MkCaseAlt{ alt_pat = con,
- alt_bndrs = args,
- alt_result = MatchResult _ body_fn }
- = do { body <- body_fn fail
- ; case dataConBoxer con of {
- Nothing -> return (DataAlt con, args, body) ;
- Just (DCB boxer) ->
- do { us <- newUniqueSupply
- ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
- ; return (DataAlt con, rep_ids, mkLets binds body) } } }
-
- mk_default :: CoreExpr -> [CoreAlt]
- mk_default fail | exhaustive_case = []
- | otherwise = [(DEFAULT, [], fail)]
-
- fail_flag :: CanItFail
- fail_flag | exhaustive_case
- = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results]
- | otherwise
- = CanFail
-
- mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts
+ mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr
+ mk_case def alts = mkWildCase (Var var) (idType var) ty $
+ maybeToList def ++ alts
+
+ mk_alts :: MatchResult [CoreAlt]
+ mk_alts = traverse mk_alt sorted_alts
+
+ mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt
+ mk_alt MkCaseAlt { alt_pat = con
+ , alt_bndrs = args
+ , alt_result = match_result } =
+ flip adjustMatchResultDs match_result $ \body -> do
+ case dataConBoxer con of
+ Nothing -> return (DataAlt con, args, body)
+ Just (DCB boxer) -> do
+ us <- newUniqueSupply
+ let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+ return (DataAlt con, rep_ids, mkLets binds body)
+
+ mk_default :: MatchResult (Maybe CoreAlt)
+ mk_default
+ | exhaustive_case = MR_Infallible $ return Nothing
+ | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail)
+
+ mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts
un_mentioned_constructors
= mkUniqSet data_cons `minusUniqSet` mentioned_constructors
exhaustive_case = isEmptyUniqSet un_mentioned_constructors
@@ -857,6 +850,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 CoreExpr -> MatchResult CoreExpr
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ffd7eef22f197ba44f0ced97ebc988f2d7d643a4...401f7bb312aa6c570287d313f8b587aaebca72b2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ffd7eef22f197ba44f0ced97ebc988f2d7d643a4...401f7bb312aa6c570287d313f8b587aaebca72b2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200422/6f23c273/attachment-0001.html>
More information about the ghc-commits
mailing list