[Git][ghc/ghc][wip/match-datatype] Update Match Datatype
David (@knothed)
gitlab at gitlab.haskell.org
Mon Jun 26 15:16:03 UTC 2023
David pushed to branch wip/match-datatype at Glasgow Haskell Compiler / GHC
Commits:
24e374e6 by David Knothe at 2023-06-26T17:15:47+02:00
Update Match Datatype
- - - - -
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
=====================================
@@ -207,9 +207,7 @@ dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
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 }
+ eqn = EqnMatch upat FromSource (EqnDone $ cantFailMatchResult body)
; var <- selectMatchVar ManyTy upat
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Platform
import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-
import GHC.Types.Basic ( Origin(..), isGenerated )
import GHC.Types.SourceText
import GHC.Driver.DynFlags
@@ -192,11 +191,7 @@ 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 ]
+ combineRHSs (NEL.fromList eqns)
match (v:vs) ty eqns -- Eqns *can* be empty
= assertPpr (all (isInternalName . idName) vars) (ppr vars) $
@@ -239,6 +234,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
PgView {} -> matchView vars ty (dropGroup eqns)
+ PgDistinct-> combineRHSs (dropGroup eqns)
where eqns' = NEL.toList eqns
ne l = case NEL.nonEmpty l of
Just nel -> nel
@@ -309,8 +305,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
-- 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 extract (EqnMatch pat orig rest) = EqnMatch (extract pat) orig rest
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
@@ -404,12 +399,11 @@ 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 _ (EqnDone r) = return (idDsWrapper, EqnDone r)
-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 (EqnMatch pat orig rest) = do
+ (wrap, pat') <- tidy1 v orig pat
+ return (wrap, EqnMatch pat' orig rest)
tidy1 :: Id -- The Id being scrutinised
-> Origin -- Was this a pattern the user wrote?
@@ -814,9 +808,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- 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 FromSource match_result }
discard_warnings_if_generated orig =
if isGenerated orig
@@ -953,9 +945,9 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
addCoreScrutTmCs (maybeToList mb_scrut) [var] $
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
- , eqn_orig = FromSource
- , eqn_rhs = match_result }
+ ; let eqn_info = EqnMatch (unLoc (decideBangHood dflags pat))
+ FromSource
+ (EqnDone match_result)
; match [var] ty [eqn_info] }
@@ -983,6 +975,15 @@ data PatGroup
| PgView (LHsExpr GhcTc) -- view pattern (e -> p):
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
+ | PgDistinct -- Group equations which are Done: no further grouping can be done with them
+
+instance Show PatGroup where
+ show PgAny = "PgAny"
+ show (PgCon _) = "PgCon"
+ show (PgLit _) = "PgLit"
+ show (PgView _ _) = "PgView"
+ show PgDistinct = "PgDistinct"
+ show _ = "PgOther"
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1100,6 +1101,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
-- ViewPats are in the same group iff the expressions
-- are "equal"---conservatively, we use syntactic equality
+sameGroup PgDistinct PgDistinct = True
sameGroup _ _ = False
-- An approximation of syntactic equality used for determining when view
@@ -1226,15 +1228,19 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list _ (_:_) [] = False
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
-patGroup :: Platform -> Pat GhcTc -> PatGroup
-patGroup _ (ConPat { pat_con = L _ con
+patGroup :: Platform -> Maybe (Pat GhcTc) -> PatGroup
+patGroup _ Nothing = PgDistinct
+patGroup p (Just pat) = patGroup' p pat
+
+patGroup' :: Platform -> Pat GhcTc -> PatGroup
+patGroup' _ (ConPat { pat_con = L _ con
, pat_con_ext = ConPatTc { cpt_arg_tys = tys }
})
- | RealDataCon dcon <- con = PgCon dcon
- | PatSynCon psyn <- con = PgSyn psyn tys
-patGroup _ (WildPat {}) = PgAny
-patGroup _ (BangPat {}) = PgBang
-patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
+ | RealDataCon dcon <- con = PgCon dcon
+ | PatSynCon psyn <- con = PgSyn psyn tys
+patGroup' _ (WildPat {}) = PgAny
+patGroup' _ (BangPat {}) = PgBang
+patGroup' _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
case (oval, isJust mb_neg) of
(HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg
then negate (il_value i)
@@ -1244,16 +1250,16 @@ patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
| otherwise -> PgN f
(HsIsString _ s, _) -> assert (isNothing mb_neg) $
PgOverS s
-patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
+patGroup' _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
-patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
-patGroup platform (XPat ext) = case ext of
+patGroup' _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
+patGroup' platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
+patGroup' platform (XPat ext) = case ext of
CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern
- ExpansionPat _ p -> patGroup platform p
-patGroup _ pat = pprPanic "patGroup" (ppr pat)
+ ExpansionPat _ p -> patGroup' platform p
+patGroup' _ pat = pprPanic "patGroup" (ppr pat)
{-
Note [Grouping overloaded literal patterns]
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -153,24 +153,22 @@ 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 (ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind
+ }})
+ _ rest
+ ))
= do dsTcEvBinds bind $ \ds_bind ->
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_orig = Generated
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
+ , mkEqnInfo (conArgPats val_arg_tys args ++ eqn_pats rest) Generated (eqn_rhs 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
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -625,10 +625,10 @@ matchLiterals (var :| vars) ty sub_groups
}
where
match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
- match_group eqns@(firstEqn :| _)
+ match_group eqns
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
- ; let LitPat _ hs_lit = firstPat firstEqn
+ ; let (EqnMatch (LitPat _ hs_lit) _ _) = NEL.head eqns
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
@@ -726,7 +726,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 (NPlusKPat _ (L _ n) _ _ _ _) _ 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
=====================================
@@ -48,7 +48,8 @@ module GHC.HsToCore.Monad (
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
+ EquationInfo(..), mkEqnInfo, eqn_rhs, eqn_pats,
+ MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-- Trace injection
pprRuntimeTrace
@@ -131,14 +132,15 @@ 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?
+ = EqnMatch
+ (Pat GhcTc)
+ -- ^ The first pattern of the equation
+ --
+ -- NB: We have /already/ applied 'decideBangHood' to
+ -- this pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"
+
+ Origin
+ -- ^ Was this equation present in the user source?
--
-- This helps us avoid warnings on patterns that GHC elaborated.
--
@@ -146,12 +148,26 @@ data EquationInfo
-- @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
- }
+ EquationInfo
+ -- ^ The rest of the equation after its first pattern
+
+ | EqnDone -- An empty equation which has no patterns
+ (MatchResult CoreExpr)
+ -- ^ What to do after match
+
+mkEqnInfo :: [Pat GhcTc] -> Origin -> MatchResult CoreExpr -> EquationInfo
+mkEqnInfo [] _ rhs = EqnDone rhs
+mkEqnInfo (pat:pats) orig rhs = EqnMatch pat orig (mkEqnInfo pats orig rhs)
+
+eqn_pats :: EquationInfo -> [Pat GhcTc]
+eqn_pats (EqnDone _) = []
+eqn_pats (EqnMatch pat _ rest) = pat : eqn_pats rest
+eqn_rhs :: EquationInfo -> MatchResult CoreExpr
+eqn_rhs (EqnDone rhs) = rhs
+eqn_rhs (EqnMatch _ _ rest) = eqn_rhs rest
instance Outputable EquationInfo where
- ppr (EqnInfo pats _ _) = ppr pats
+ ppr = ppr . eqn_pats
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, maybeFirstPat, shiftEqns, combineRHSs,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
@@ -195,11 +195,20 @@ 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 (EqnMatch pat _ _) = pat
+firstPat (EqnDone _) = error "firstPat: no patterns"
+
+maybeFirstPat :: EquationInfo -> Maybe (Pat GhcTc)
+maybeFirstPat (EqnMatch pat _ _) = Just pat
+maybeFirstPat (EqnDone _) = Nothing
shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+shiftEqns = fmap $ \case (EqnMatch _ _ rest) -> rest
+ (EqnDone _) -> error "shiftEqn: no patterns"
+
+combineRHSs :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+combineRHSs eqns = return $ foldr1 combineMatchResults $ map eqn_rhs (NEL.toList eqns)
-- Functions on MatchResult CoreExprs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24e374e658acbb80d6b4c70f3efb9f3cdb6ea269
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24e374e658acbb80d6b4c70f3efb9f3cdb6ea269
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/20230626/3a1faf34/attachment-0001.html>
More information about the ghc-commits
mailing list