[Git][ghc/ghc][master] Update Match Datatype
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jul 28 17:13:47 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a5319358 by David Knothe at 2023-07-28T13:13:10-04:00
Update Match Datatype
EquationInfo currently contains a list of the equation's patterns together with a CoreExpr that is to be evaluated after a successful match on this equation.
All the match-functions only operate on the first pattern of an equation - after successfully matching it, match is called recursively on the tail of the pattern list.
We can express this more clearly and make the code a little more elegant by updating the datatype of EquationInfo as follows:
data EquationInfo
= EqnMatch { eqn_pat = Pat GhcTc, eqn_rest = EquationInfo }
| EqnDone { eqn_rhs = MatchResult CoreExpr }
An EquationInfo now explicitly exposes its first pattern which most functions operate on, and exposes the equation that remains after processing the first pattern. An EqnDone signifies an empty equation where the CoreExpr can now be evaluated.
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- 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
=====================================
@@ -206,11 +206,8 @@ dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
-- ==> case rhs of C x# y# -> body
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
- eqn_orig = FromSource,
- eqn_rhs = cantFailMatchResult body }
- ; var <- selectMatchVar ManyTy upat
+ ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) }
+ ; var <- selectMatchVar ManyTy (unLoc pat)
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -29,8 +29,12 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC )
+import GHC.Types.Basic ( Origin(..), requiresPMC )
import GHC.Types.SourceText
+ ( FractionalLit,
+ IntegralLit(il_value),
+ negateFractionalLit,
+ integralFractionalLit )
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Hs.Syn.Type
@@ -193,13 +197,9 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
match [] ty eqns
= assertPpr (not (null eqns)) (ppr ty) $
- return (foldr1 combineMatchResults match_results)
- where
- match_results = [ assert (null (eqn_pats eqn)) $
- eqn_rhs eqn
- | eqn <- eqns ]
+ combineEqnRhss (NEL.fromList eqns)
-match (v:vs) ty eqns -- Eqns *can* be empty
+match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
= assertPpr (all (isInternalName . idName) vars) (ppr vars) $
do { dflags <- getDynFlags
; let platform = targetPlatform dflags
@@ -222,12 +222,11 @@ match (v:vs) ty eqns -- Eqns *can* be empty
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup = fmap snd
- match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
- -- Result list of [MatchResult CoreExpr] is always non-empty
+ match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr))
match_groups [] = matchEmpty v ty
match_groups (g:gs) = mapM match_group $ g :| gs
- match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
+ match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
match_group eqns@((group,_) :| _)
= case group of
PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -267,20 +266,20 @@ matchEmpty var res_ty
mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
[Alt DEFAULT [] fail]
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> 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 CoreExpr)
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> 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 CoreExpr)
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Apply the coercion to the match variable and then match that
-matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
+matchCoercion (var :| vars) ty eqns@(eqn1 :| _)
= do { let XPat (CoPat co pat _) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
@@ -290,9 +289,9 @@ 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 CoreExpr)
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
-- Apply the view function to the match variable and then match that
-matchView (var :| vars) ty (eqns@(eqn1 :| _))
+matchView (var :| vars) ty eqns@(eqn1 :| _)
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
@@ -309,10 +308,9 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
match_result) }
-- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
- = eqn { eqn_pats = extractpat pat : pats}
-decomposeFirstPat _ _ = panic "decomposeFirstPat"
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
+decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
+decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat _ pat _)) = pat
@@ -405,15 +403,14 @@ tidyEqnInfo :: Id -> EquationInfo
-- POST CONDITION: head pattern in the EqnInfo is
-- one of these for which patGroup is defined.
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
- = panic "tidyEqnInfo"
+tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wrap, pat') <- tidy1 v orig pat
- ; return (wrap, eqn { eqn_pats = pat' : pats }) }
+tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
+ (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat
+ return (wrap, eqn{eqn_pat = L loc pat' })
tidy1 :: Id -- The Id being scrutinised
- -> Origin -- Was this a pattern the user wrote?
+ -> Bool -- `True` if the pattern was generated, `False` if it was user-written
-> Pat GhcTc -- The pattern against which it is to be matched
-> DsM (DsWrapper, -- Extra bindings to do before the match
Pat GhcTc) -- Equivalent pattern
@@ -424,10 +421,10 @@ tidy1 :: Id -- The Id being scrutinised
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
-tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
+tidy1 v g (ParPat _ _ pat _) = tidy1 v g (unLoc pat)
+tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat)
tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
+tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
@@ -436,8 +433,8 @@ tidy1 v _ (VarPat _ (L _ var))
-- case v of { x at p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) _ pat)
- = do { (wrap, pat') <- tidy1 v o (unLoc pat)
+tidy1 v g (AsPat _ (L _ var) _ pat)
+ = do { (wrap, pat') <- tidy1 v g (unLoc pat)
; return (wrapBind var v . wrap, pat') }
{- now, here we handle lazy patterns:
@@ -489,22 +486,22 @@ tidy1 _ _ (SumPat tys pat alt arity)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
- = do { unless (isGenerated o) $
+tidy1 _ g (LitPat _ lit)
+ = do { unless g $
warnAboutOverflowedLit lit
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
- = do { unless (isGenerated o) $
+tidy1 _ g (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
+ = do { unless g $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
in warnAboutOverflowedOverLit lit'
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
- = do { unless (isGenerated o) $ do
+tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+ = do { unless g $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
; return (idDsWrapper, n) }
@@ -514,28 +511,28 @@ tidy1 _ _ non_interesting_pat
= return (idDsWrapper, non_interesting_pat)
--------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
+tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v g _ (ParPat _ _ (L l p) _) = tidy_bang_pat v g l p
+tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' at p)
- = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (XPat (CoPat w p t))
- = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v g l (AsPat x v' at p)
+ = tidy1 v g (AsPat x v' at (L l (BangPat noExtField p)))
+tidy_bang_pat v g l (XPat (CoPat w p t))
+ = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
+tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
+tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_con_ext = ConPatTc
{ cpt_arg_tys = arg_tys
@@ -544,8 +541,8 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
-- Newtypes: push bang inwards (#9844)
=
if isNewTyCon (dataConTyCon dc)
- then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
- else tidy1 v o p -- Data types: discard the bang
+ then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
+ else tidy1 v g p -- Data types: discard the bang
where
(ty:_) = dataConInstArgTys dc arg_tys
@@ -808,16 +805,14 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
= do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
+ ; let upats = map (decideBangHood dflags) pats
-- pat_nablas is the covered set *after* matching the pattern, but
-- before any of the GRHSs. We extend the environment with pat_nablas
-- (via updPmNablas) so that the where-clause of 'grhss' can profit
-- from that knowledge (#18533)
; match_result <- updPmNablas pat_nablas $
dsGRHSs ctxt grhss rhs_ty rhss_nablas
- ; return EqnInfo { eqn_pats = upats
- , eqn_orig = FromSource
- , eqn_rhs = match_result } }
+ ; return $ mkEqnInfo upats match_result }
discard_warnings_if_skip_pmc orig =
if requiresPMC orig
@@ -958,10 +953,9 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
else getLdiNablas
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
- , eqn_orig = FromSource
- , eqn_rhs =
- updPmNablasMatchResult ldi_nablas match_result }
+ ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
+ , eqn_rest =
+ EqnDone $ updPmNablasMatchResult ldi_nablas match_result }
-- See Note [Long-distance information in do notation]
-- in GHC.HsToCore.Expr.
@@ -999,6 +993,13 @@ data PatGroup
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
+instance Show PatGroup where
+ show PgAny = "PgAny"
+ show (PgCon _) = "PgCon"
+ show (PgLit _) = "PgLit"
+ show (PgView _ _) = "PgView"
+ show _ = "PgOther"
+
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors
@@ -1019,7 +1020,7 @@ the PgN constructor as a FractionalLit if numeric, and add a PgOverStr construct
for overloaded strings.
-}
-groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
+groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
@@ -1163,8 +1164,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
- exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
- lexp l l' && lexp o o' && lexp ri ri'
+ exp (OpApp _ l g ri) (OpApp _ l' o' ri') =
+ lexp l l' && lexp g o' && lexp ri ri'
exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -21,7 +21,6 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import GHC.Hs
import GHC.HsToCore.Binds
import GHC.Core.ConLike
-import GHC.Types.Basic
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.HsToCore.Monad
@@ -95,7 +94,7 @@ have-we-used-all-the-constructors? question; the local function
matchConFamily :: NonEmpty Id
-> Type
- -> NonEmpty (NonEmpty EquationInfo)
+ -> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
-- Each group of eqns is for a single constructor
matchConFamily (var :| vars) ty groups
@@ -114,7 +113,7 @@ matchConFamily (var :| vars) ty groups
matchPatSyn :: NonEmpty Id
-> Type
- -> NonEmpty EquationInfo
+ -> NonEmpty EquationInfoNE
-> DsM (MatchResult CoreExpr)
matchPatSyn (var :| vars) ty eqns
= do let mult = idMult var
@@ -130,7 +129,7 @@ type ConArgPats = HsConPatDetails GhcTc
matchOneConLike :: [Id]
-> Type
-> Mult
- -> NonEmpty EquationInfo
+ -> NonEmpty EquationInfoNE
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor
= do { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $
@@ -144,7 +143,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- and returns the types of the *value* args, which is what we want
match_group :: [Id]
- -> NonEmpty (ConArgPats, EquationInfo)
+ -> NonEmpty (ConArgPats, EquationInfoNE)
-> DsM (MatchResult CoreExpr)
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
@@ -154,24 +153,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
; return $ foldr1 (.) wraps <$> match_result
}
- shift (_, eqn@(EqnInfo
- { eqn_pats = ConPat
- { pat_args = args
- , pat_con_ext = ConPatTc
- { cpt_tvs = tvs
- , cpt_dicts = ds
- , cpt_binds = bind
- }
- } : pats
- }))
+ shift (_, EqnMatch {
+ eqn_pat = L _ (ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind }})
+ , eqn_rest = rest })
= do dsTcEvBinds bind $ \ds_bind ->
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_orig = Generated SkipPmc
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
+ , prependPats (conArgPats val_arg_tys args) rest
)
- shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+ shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn)
; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
-- The 'val_arg_tys' are taken from the data type definition, they
-- do not take into account the context multiplicity, therefore we
@@ -185,7 +181,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- suggestions for the new variables
-- Divide into sub-groups; see Note [Record patterns]
- ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
+ ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE))
groups = NE.groupBy1 compatible_pats
$ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
@@ -257,14 +253,14 @@ conArgPats :: [Scaled Type]-- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> ConArgPats
- -> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+ -> [LPat GhcTc]
+conArgPats _arg_tys (PrefixCon _ ps) = ps
+conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2]
conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
- | null rpats = map WildPat (map scaledThing arg_tys)
+ | null rpats = map (noLocA . WildPat . scaledThing) arg_tys
-- Important special case for C {}, which can be used for a
-- datacon that isn't declared to have fields at all
- | otherwise = map (unLoc . hfbRHS . unLoc) rpats
+ | otherwise = map (hfbRHS . unLoc) rpats
{-
Note [Record patterns]
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -607,7 +607,7 @@ tidyNPat over_lit mb_neg eq outer_ty
matchLiterals :: NonEmpty Id
-> Type -- ^ Type of the whole case expression
- -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
+ -> NonEmpty (NonEmpty EquationInfoNE) -- ^ All PgLits
-> DsM (MatchResult CoreExpr)
matchLiterals (var :| vars) ty sub_groups
@@ -625,11 +625,11 @@ matchLiterals (var :| vars) ty sub_groups
return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
- match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
- match_group eqns@(firstEqn :| _)
+ match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr)
+ match_group eqns
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
- ; let LitPat _ hs_lit = firstPat firstEqn
+ ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
@@ -682,7 +682,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
************************************************************************
-}
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> 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
@@ -711,7 +711,7 @@ We generate:
\end{verbatim}
-}
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> 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
@@ -727,7 +727,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
fmap (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
- = (wrapBind n n1, eqn { eqn_pats = pats })
+ shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest })
+ = (wrapBind n n1, rest)
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -49,7 +49,8 @@ module GHC.HsToCore.Monad (
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
+ EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult,
+ MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-- Trace injection
pprRuntimeTrace
@@ -92,7 +93,6 @@ import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Var (EvId)
@@ -132,27 +132,42 @@ instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat GhcTc]
- -- ^ The patterns for an equation
- --
- -- NB: We have /already/ applied 'decideBangHood' to
- -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils"
-
- , eqn_orig :: Origin
- -- ^ Was this equation present in the user source?
- --
- -- This helps us avoid warnings on patterns that GHC elaborated.
- --
- -- For instance, the pattern @-1 :: Word@ gets desugared into
- -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
- -- literal for /both/ of these cases.
-
- , eqn_rhs :: MatchResult CoreExpr
- -- ^ What to do after match
- }
+ = EqnMatch { eqn_pat :: LPat GhcTc
+ -- ^ The first pattern of the equation
+ --
+ -- NB: The location info is used to determine whether the
+ -- pattern is generated or not.
+ -- This helps us avoid warnings on patterns that GHC elaborated.
+ --
+ -- NB: We have /already/ applied 'decideBangHood' to this
+ -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"
+
+ , eqn_rest :: EquationInfo }
+ -- ^ The rest of the equation after its first pattern
+
+ | EqnDone
+ -- The empty tail of an equation having no more patterns
+ (MatchResult CoreExpr)
+ -- ^ What to do after match
+
+type EquationInfoNE = EquationInfo
+-- An EquationInfo which has at least one pattern
+
+prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo
+prependPats [] eqn = eqn
+prependPats (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependPats pats eqn }
+
+mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
+mkEqnInfo pats = prependPats pats . EqnDone
+
+eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
+eqnMatchResult (EqnDone rhs) = rhs
+eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq
instance Outputable EquationInfo where
- ppr (EqnInfo pats _ _) = ppr pats
+ ppr = ppr . allEqnPats where
+ allEqnPats (EqnDone {}) = []
+ allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -15,7 +15,7 @@ This module exports some utility functions of no great interest.
-- | Utility functions for constructing Core syntax, principally for desugaring
module GHC.HsToCore.Utils (
EquationInfo(..),
- firstPat, shiftEqns,
+ firstPat, shiftEqns, combineEqnRhss,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
@@ -194,12 +194,16 @@ The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
-}
-firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
+firstPat :: EquationInfoNE -> Pat GhcTc
+firstPat (EqnMatch { eqn_pat = pat }) = unLoc pat
+firstPat (EqnDone {}) = error "firstPat: no patterns"
-shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
+shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo
-- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+shiftEqns = fmap eqn_rest
+
+combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+combineEqnRhss eqns = return $ foldr1 combineMatchResults $ map eqnMatchResult (NEL.toList eqns)
-- Functions on MatchResult CoreExprs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a53193589ac5bd9973711733a7ccd66080dca794
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a53193589ac5bd9973711733a7ccd66080dca794
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/20230728/ddab9826/attachment-0001.html>
More information about the ghc-commits
mailing list