[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