X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=24c4680f7dddfe45696ebadf56dff5e802bcaf39;hb=b5a73581d0c03b9d44a77706b5973d74074aa6c1;hp=f545930a48c44826faf1a38aaf5de112a27d880d;hpb=860e92c1dd65f2a7a617c253849d7ce84ed9bbc9;p=ghc-hetmet.git diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index f545930..24c4680 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -26,6 +26,7 @@ import Check import CoreSyn import Literal import CoreUtils +import MkCore import DsMonad import DsBinds import DsGRHSs @@ -42,6 +43,7 @@ import SrcLoc import Maybes import Util import Name +import FiniteMap import Outputable import FastString \end{code} @@ -242,7 +244,7 @@ Make all constructor patterns in column~1 into @ConPats@, notably Handle any irrefutable (or ``twiddle'') @LazyPats@. \end{itemize} \item -Now {\em unmix} the equations into {\em blocks} [w/ local function +Now {\em unmix} the equations into {\em blocks} [w\/ local function @unmix_eqns@], in which the equations in a block all have variable patterns in column~1, or they all have constructor patterns in ... (see ``the mixture rule'' in SLPJ). @@ -268,7 +270,7 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match :: [Id] -- Variables rep'ing the exprs we're matching with +match :: [Id] -- Variables rep\'ing the exprs we\'re matching with -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! @@ -288,8 +290,7 @@ match vars@(v:_) ty eqns (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - - ; let grouped = (groupEquations tidy_eqns) + ; let grouped = groupEquations tidy_eqns -- print the view patterns that are commoned up to help debug ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped) @@ -304,10 +305,11 @@ match vars@(v:_) ty eqns match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult match_group eqns@((group,_) : _) = case group of + PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns]) + PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns]) + PgAny -> matchVariables vars ty (dropGroup eqns) - PgCon _ -> matchConFamily vars ty (subGroups eqns) - PgLit _ -> matchLiterals vars ty (subGroups eqns) - PgN _ -> matchNPats vars ty (subGroups eqns) + PgN _ -> matchNPats vars ty (dropGroup eqns) PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns) PgBang -> matchBangs vars ty (dropGroup eqns) PgCo _ -> matchCoercion vars ty (dropGroup eqns) @@ -462,7 +464,7 @@ tidy1 v (VarPat var) tidy1 v (VarPatOut var binds) = do { prs <- dsLHsBinds binds - ; return (wrapBind var v . mkDsLet (Rec prs), + ; return (wrapBind var v . mkCoreLet (Rec prs), WildPat (idType var)) } -- case v of { x@p -> mr[] } @@ -485,7 +487,7 @@ tidy1 v (AsPat (L _ var) pat) tidy1 v (LazyPat pat) = do { sel_prs <- mkSelectorBinds pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkDsLets sel_binds, WildPat (idType v)) } + ; return (mkCoreLets sel_binds, WildPat (idType v)) } tidy1 _ (ListPat pats ty) = return (idDsWrapper, unLoc list_ConPat) @@ -685,11 +687,11 @@ matchEquations ctxt vars eqns_info rhs_ty = do { dflags <- getDOptsDs ; locn <- getSrcSpanDs ; let ds_ctxt = DsMatchContext ctxt locn - error_string = matchContextErrString ctxt + error_doc = matchContextErrString ctxt ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } where match_fun dflags ds_ctxt @@ -771,24 +773,39 @@ groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- 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 +-- The ordering of equations is unchanged groupEquations eqns = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 -subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]] +subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] -- Input is a particular group. The result sub-groups the -- equations by with particular constructor, literal etc they match. --- The order may be swizzled, so the matching should be order-independent -subGroups groups = map (map snd) (equivClasses cmp groups) +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +subGroup group + = map reverse $ eltsFM $ foldl accumulate emptyFM group where - (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2 - (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2 - (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2 - (PgN l1) `cmp_pg` (PgN l2) = l1 `compare` l2 - -- These are the only cases that are every sub-grouped + accumulate pg_map (pg, eqn) + = case lookupFM pg_map pg of + Just eqns -> addToFM pg_map pg (eqn:eqns) + Nothing -> addToFM pg_map pg [eqn] + + -- pg_map :: FiniteMap a [EquationInfo] + -- Equations seen so far in reverse order of appearance +\end{code} +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! + + +\begin{code} sameGroup :: PatGroup -> PatGroup -> Bool -- Same group means that a single case expression -- or test will suffice to match both, *and* the order @@ -797,9 +814,8 @@ sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True sameGroup (PgCon _) (PgCon _) = True -- One case expression sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN _) (PgN _) = True -- Needs conditionals -sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant - -- See Note [Order of n+k] +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 -- CoPats are in the same goup only if the type of the -- enclosed pattern is the same. The patterns outside the CoPat @@ -904,8 +920,8 @@ patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup pat = pprPanic "patGroup" (ppr pat) \end{code} -Note [Order of n+k] -~~~~~~~~~~~~~~~~~~~ +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WATCH OUT! Consider f (n+1) = ... @@ -913,9 +929,11 @@ WATCH OUT! Consider f (n+1) = ... We can't group the first and third together, because the second may match -the same thing as the first. Contrast - f 1 = ... - f 2 = ... - f 1 = ... -where we can group the first and third. Hence we don't regard (n+1) and -(n+2) as part of the same group. +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.