[Git][ghc/ghc][wip/or-pats] Play around with Match
David (@knothed)
gitlab at gitlab.haskell.org
Fri Jun 2 11:30:52 UTC 2023
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
20a338b1 by David Knothe at 2023-06-02T13:30:46+02:00
Play around with Match
- - - - -
3 changed files:
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Match/Literal.hs
Changes:
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -21,13 +21,15 @@ module GHC.HsToCore.Match
)
where
+import GHC.Stack
import GHC.Prelude
import GHC.Platform
import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-
+import Data.List (intercalate)
+import Debug.Trace
import GHC.Types.Basic ( Origin(..), isGenerated )
import GHC.Types.SourceText
import GHC.Driver.DynFlags
@@ -178,9 +180,20 @@ with External names (#13043).
See also Note [Localise pattern binders] in GHC.HsToCore.Utils
-}
+-- input: equationInfo
+-- output: do call to `match` (recursing into matchNew) but group the first var beforehand
+-- for the call to match, construct a EqnInfo with only a single pattern and put the recursive call into the eqn_rhs.
+
+--matchNew :: [MatchId]
+-- -> Type
+-- -> [EquationInfo]
+-- -> Dsm (MatchResult CoreExpr)
+
+
+
type MatchId = Id -- See Note [Match Ids]
-match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
+match :: HasCallStack => [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
-- ^ See Note [Match Ids]
--
-- ^ Note that the Match Ids carry not only a name, but
@@ -204,14 +217,22 @@ match (v:vs) ty eqns -- Eqns *can* be empty
; let platform = targetPlatform dflags
-- Tidy the first pattern, generating
-- auxiliary bindings if necessary
+ -- ; traceM ("tidy " ++ show (length eqns) ++ " " ++ (show . length . eqn_pats . head) eqns)
; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
; let grouped = groupEquations platform tidy_eqns
+ ; grouped' <- mapM (moveGroupVarsIntoRhs vs ty) grouped
+
+ ; traceM ("Before moving: " ++ show (length grouped) ++ " groups:")
+ ; testPrint grouped
+ ; traceM ("After moving: " ++ show (length grouped') ++ " groups:")
+ ; testPrint grouped'
+ ; traceM ""
-- print the view patterns that are commoned up to help debug
- ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+ ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped')
- ; match_results <- match_groups grouped
+ ; match_results <- match_groups grouped'
; return $ foldr (.) id aux_binds <$>
foldr1 combineMatchResults match_results
}
@@ -248,6 +269,15 @@ match (v:vs) ty eqns -- Eqns *can* be empty
-- FIXME: we should also warn about view patterns that should be
-- commoned up but are not
+ testPrint :: Applicative f => [NonEmpty (PatGroup, EquationInfo)] -> f ()
+ testPrint groups =
+ traceM $ intercalate "\n" $ map
+ (\group -> intercalate " ; " $ map
+ (\(pg, eqn) -> (show pg ++ " " ++ (intercalate " " $ map (showSDocUnsafe . pprLPat . mklpat) (eqn_pats eqn))))
+ (NEL.toList group))
+ groups
+ mklpat pat = L noSrcSpanA pat
+
-- print some stuff to see what's getting grouped
-- use -dppr-debug to see the resolution of overloaded literals
debug eqns =
@@ -267,10 +297,25 @@ matchEmpty var res_ty
mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
[Alt DEFAULT [] fail]
+{-
+f 1 2 3 = a
+f 1 3 4 = b
+f (1|2) 4 5 = c
+
+Eqn 1 2 3 -> a
+Eqn 1 3 4 -> b
+Eqn 1 -> $
+Eqn 2 -> $
+where $ = match 4 5 c
+
+match 1 -> [match {Eqn 2 3 a, Eqn 3 4 b}]
+-}
+
+
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
+matchVariables (_ :| vars) ty eqns = return (eqn_rhs (NEL.head eqns)) -- match vars ty $ NEL.toList $ shiftEqns eqns
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs (var :| vars) ty eqns
@@ -408,7 +453,29 @@ only these which can be assigned a PatternGroup (see patGroup).
-}
-tidyEqnInfo :: Id -> EquationInfo
+moveGroupVarsIntoRhs :: HasCallStack => [Id] -> Type -> NonEmpty (PatGroup, EquationInfo) -> DsM (NonEmpty (PatGroup, EquationInfo))
+moveGroupVarsIntoRhs vs ty group = do
+ if (length . eqn_pats . snd . NEL.head) group == 1
+ then return group
+ else do
+ let rest = NEL.map (\(_, eqn) -> eqn { eqn_pats = tail (eqn_pats eqn) }) group
+ rhs <- match vs ty (NEL.toList rest)
+ let (gp, eq) = NEL.head group
+ return $ NEL.singleton (gp, EqnInfo { eqn_pats = [head (eqn_pats eq)], eqn_orig = eqn_orig eq, eqn_rhs = rhs })
+ --return $ NEL.map (\(gp, eqn) -> (gp, eqn { eqn_pats = [head (eqn_pats eqn)], eqn_rhs = combineMatchResults rhs (eqn_rhs eqn) })) group
+
+{-
+moveVarsIntoRhs :: HasCallStack => [Id] -> Type -> EquationInfo -> DsM EquationInfo
+moveVarsIntoRhs vs ty eqn
+ | length (eqn_pats eqn) == 0 = fail "argh"
+ | length (eqn_pats eqn) == 1 = do pure eqn
+ | otherwise = do
+ let eq' = eqn { eqn_pats = tail (eqn_pats eqn) }
+ rhs <- match vs ty [eq']
+ return eqn { eqn_pats = [head (eqn_pats eqn)], eqn_rhs = combineMatchResults rhs (eqn_rhs eqn) }
+-}
+
+tidyEqnInfo :: HasCallStack => Id -> EquationInfo
-> DsM (DsWrapper, EquationInfo)
-- DsM'd because of internal call to dsLHsBinds
-- and mkSelectorBinds.
@@ -1004,6 +1071,14 @@ data PatGroup
Type -- the Type is the type of p (equivalently, the result type of e)
| PgOr -- Or pattern
+instance Show PatGroup where
+ show PgAny = "PgAny"
+ show (PgCon _) = "PgCon"
+ show (PgLit _) = "PgLit"
+ show (PgView _ _) = "PgView"
+ show PgOr = "PgOr"
+ show _ = "PgOther"
+
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -1,5 +1,6 @@
module GHC.HsToCore.Match where
+import GHC.Stack (HasCallStack)
import GHC.Prelude
import GHC.Types.Var ( Id )
import GHC.Tc.Utils.TcType ( Type )
@@ -8,7 +9,7 @@ import GHC.Core ( CoreExpr )
import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
import GHC.Hs.Extension ( GhcTc, GhcRn )
-match :: [Id]
+match :: HasCallStack => [Id]
-> Type
-> [EquationInfo]
-> DsM (MatchResult CoreExpr)
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -629,8 +629,7 @@ matchLiterals (var :| vars) ty sub_groups
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; let LitPat _ hs_lit = firstPat firstEqn
- ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
- ; return (hsLitKey platform hs_lit, match_result) }
+ ; return (hsLitKey platform hs_lit, eqn_rhs firstEqn) }
wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
-- Equality check for string literals
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20a338b132d1f66bff193192aa65d40f2a90b900
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20a338b132d1f66bff193192aa65d40f2a90b900
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/20230602/4c40ef8e/attachment-0001.html>
More information about the ghc-commits
mailing list