Play around with Match

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

 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

@@ -609,7 +609,7 @@ matchLiterals :: NonEmpty Id
               -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
               -> DsM (MatchResult CoreExpr)
 
-matchLiterals (var :| vars) ty sub_groups
+matchLiterals (var :| _) ty sub_groups
   = do  {       -- Deal with each group
         ; alts <- mapM match_group sub_groups
 
@@ -625,12 +625,11 @@ matchLiterals (var :| vars) ty sub_groups
         }
   where
     match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
-    match_group eqns@(firstEqn :| _)
+    match_group (firstEqn :| _)
         = 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