From 37507b3a4342773030ef538599363a5aff8b666a Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 19:49:08 +0000 Subject: [PATCH] Massive patch for the first months work adding System FC to GHC #9 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- compiler/deSugar/Match.lhs | 365 ++++++++++++++++++++++------------------- compiler/deSugar/MatchCon.lhs | 115 +++++++------ compiler/deSugar/MatchLit.lhs | 244 +++++++++++---------------- 3 files changed, 347 insertions(+), 377 deletions(-) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index b428658..641c2ca 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -10,26 +10,29 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat import DynFlags ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( mkVanillaTuplePat ) +import TcHsSyn ( mkVanillaTuplePat, hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn +import Literal ( Literal ) import CoreUtils ( bindNonRec, exprType ) import DsMonad -import DsBinds ( dsLHsBinds ) +import DsBinds ( dsLHsBinds, dsCoercion ) import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idName, idType, Id ) -import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon ) +import DataCon ( DataCon ) import MatchCon ( matchConFamily ) -import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) +import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, + tidyLitPat, tidyNPat, hsLitKey, hsOverLitKey ) import PrelInfo ( pAT_ERROR_ID ) -import TcType ( Type, tcTyConAppArgs ) -import Type ( splitFunTysN, mkTyVarTys ) +import TcType ( Type ) +import Type ( splitFunTysN, coreEqType ) import TysWiredIn ( consDataCon, mkListTy, unitTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) -import ListSetOps ( runs ) -import SrcLoc ( noLoc, unLoc, Located(..) ) +import ListSetOps ( equivClasses, runs ) +import SrcLoc ( unLoc, Located(..) ) +import Maybes ( isJust ) import Util ( lengthExceeds, notNull ) import Name ( Name ) import Outputable @@ -141,6 +144,12 @@ ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) \end{code} +%************************************************************************ +%* * + The main matching function +%* * +%************************************************************************ + The function @match@ is basically the same as in the Wadler chapter, except it is monadised, to carry around the name supply, info about annotations, etc. @@ -191,13 +200,6 @@ Leaving out this third argument to @match@ (and slamming in lots of impossible to share the default expressions. (Also, it stands no chance of working in our post-upheaval world of @Locals@.) \end{enumerate} -So, the full type signature: -\begin{code} -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! -\end{code} Note: @match@ is often called via @matchWrapper@ (end of this module), a function that does much of the house-keeping that goes with a call @@ -230,35 +232,10 @@ appropriate thing for each kind of column-1 pattern, usually ending up in a recursive call to @match@. \end{enumerate} -%************************************************************************ -%* * -%* match: empty rule * -%* * -%************************************************************************ -\subsection[Match-empty-rule]{The ``empty rule''} - We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. -\begin{code} -match [] ty eqns_info - = ASSERT( not (null eqns_info) ) - returnDs (foldr1 combineMatchResults match_results) - where - match_results = [ ASSERT( null (eqn_pats eqn) ) - adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn) - | eqn <- eqns_info ] -\end{code} - - -%************************************************************************ -%* * -%* match: non-empty rule * -%* * -%************************************************************************ -\subsection[Match-nonempty]{@match@ when non-empty: unmixing} - This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em @@ -271,41 +248,77 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match vars@(v:_) ty eqns_info - = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info - ; let eqns_blks = runs same_family tidy_eqns - ; match_results <- mappM match_block eqns_blks - ; ASSERT( not (null match_results) ) - return (foldr1 combineMatchResults match_results) } +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! + +match [] ty eqns + = ASSERT( not (null eqns) ) + returnDs (foldr1 combineMatchResults match_results) where - same_family eqn1 eqn2 - = samePatFamily (firstPat eqn1) (firstPat eqn2) - - match_block eqns - = case firstPat (head eqns) of - WildPat {} -> matchVariables vars ty eqns - ConPatOut {} -> matchConFamily vars ty eqns - NPlusKPat {} -> matchNPlusKPats vars ty eqns - NPat {} -> matchNPats vars ty eqns - LitPat {} -> matchLiterals vars ty eqns - --- After tidying, there are only five kinds of patterns -samePatFamily (WildPat {}) (WildPat {}) = True -samePatFamily (ConPatOut {}) (ConPatOut {}) = True -samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True -samePatFamily (NPat {}) (NPat {}) = True -samePatFamily (LitPat {}) (LitPat {}) = True -samePatFamily _ _ = False + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] + +match vars@(v:_) ty eqns + = ASSERT( not (null eqns ) ) + do { -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + + -- Group the equations and match each group in turn + ; match_results <- mapM match_group (groupEquations tidy_eqns) + + ; return (adjustMatchResult (foldr1 (.) aux_binds) $ + foldr1 combineMatchResults match_results) } + where + dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] + dropGroup = map snd + + match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult + match_group eqns@((group,_) : _) + = case group of + PgAny -> matchVariables vars ty (dropGroup eqns) + PgCon _ -> matchConFamily vars ty (subGroups eqns) + PgLit _ -> matchLiterals vars ty (subGroups eqns) + PgN lit -> matchNPats vars ty (subGroups eqns) + PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo _ -> matchCoercion vars ty (dropGroup eqns) matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- 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 (var:vars) ty eqns = match vars ty (shiftEqns eqns) -\end{code} - +matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchBangs (var:vars) ty eqns + = do { match_result <- match (var:vars) ty (map shift eqns) + ; return (mkEvalMatchResult var ty match_result) } + where + shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats }) + = eqn { eqn_pats = unLoc pat : pats } + +matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the coercion to the match variable and then match that +matchCoercion (var:vars) ty (eqn1:eqns) + = do { let CoPat co pat _ = firstPat eqn1 + ; var' <- newUniqueId (idName var) (hsPatType pat) + ; match_result <- match (var:vars) ty (map shift (eqn1:eqns)) + ; rhs <- dsCoercion co (return (Var var)) + ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) } + where + shift eqn@(EqnInfo { eqn_pats = CoPat _ pat _ : pats }) + = eqn { eqn_pats = pat : pats } \end{code} +%************************************************************************ +%* * + Tidying patterns +%* * +%************************************************************************ + Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ which will be scrutinised. This means: \begin{itemize} @@ -342,7 +355,8 @@ Float, Double, at least) are converted to unboxed form; e.g., \end{description} \begin{code} -tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) -- DsM'd because of internal call to dsLHsBinds -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at @@ -356,30 +370,15 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- NPlusKPat -- but no other -tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats }) - = tidy1 v wrap pat `thenDs` \ (wrap', pat') -> - returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats }) +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) + = tidy1 v pat `thenDs` \ (wrap, pat') -> + returnDs (wrap, eqn { eqn_pats = pat' : pats }) tidy1 :: Id -- The Id being scrutinised - -> DsWrapper -- Previous wrapping bindings -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings around what to do afterwards + -> DsM (DsWrapper, -- Extra bindings to do before the match Pat Id) -- Equivalent pattern --- The extra bindings etc are all wrapped around the RHS of the match --- so they are only available when matching is complete. But that's ok --- becuase, for example, in the pattern x@(...), the x can only be --- used in the RHS, not in the nested pattern, nor subsquent patterns --- --- However this does have an awkward consequence. The bindings in --- a VarPatOut get wrapped around the result in right to left order, --- rather than left to right. This only matters if one set of --- bindings can mention things used in another, and that can happen --- if we allow equality dictionary bindings of form d1=d2. --- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart. --- (Without this care in bindInstsOfLocalFuns, compiling --- Data.Generics.Schemes.hs fails in function everywhereBut.) - ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' @@ -391,27 +390,25 @@ tidy1 :: Id -- The Id being scrutinised -- NPat -- NPlusKPat -tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat) -tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) -tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty) +tidy1 v (ParPat pat) = tidy1 v (unLoc pat) +tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) +tidy1 v (WildPat ty) = returnDs (idWrapper, WildPat ty) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v wrap (VarPat var) - = returnDs (wrap . wrapBind var v, WildPat (idType var)) +tidy1 v (VarPat var) + = returnDs (wrapBind var v, WildPat (idType var)) -tidy1 v wrap (VarPatOut var binds) +tidy1 v (VarPatOut var binds) = do { prs <- dsLHsBinds binds - ; return (wrap . wrapBind var v . mkDsLet (Rec prs), + ; return (wrapBind var v . mkDsLet (Rec prs), WildPat (idType var)) } -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v wrap (AsPat (L _ var) pat) - = tidy1 v (wrap . wrapBind var v) (unLoc pat) - -tidy1 v wrap (BangPat pat) - = tidy1 v (wrap . seqVar v) (unLoc pat) +tidy1 v (AsPat (L _ var) pat) + = do { (wrap, pat') <- tidy1 v (unLoc pat) + ; return (wrapBind var v . wrap, pat') } {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : @@ -424,22 +421,13 @@ tidy1 v wrap (BangPat pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v wrap (LazyPat pat) - = do { v' <- newSysLocalDs (idType v) - ; sel_prs <- mkSelectorBinds pat (Var v) +tidy1 v (LazyPat pat) + = do { sel_prs <- mkSelectorBinds pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds, - WildPat (idType v)) } + ; returnDs (mkDsLets sel_binds, WildPat (idType v)) } --- re-express as (ConPat ...) [directly] - -tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) - = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty) - where - tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps) - -tidy1 v wrap (ListPat pats ty) - = returnDs (wrap, unLoc list_ConPat) +tidy1 v (ListPat pats ty) + = returnDs (idWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -448,67 +436,39 @@ tidy1 v wrap (ListPat pats ty) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 v wrap (PArrPat pats ty) - = returnDs (wrap, unLoc parrConPat) +tidy1 v (PArrPat pats ty) + = returnDs (idWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v wrap (TuplePat pats boxity ty) - = returnDs (wrap, unLoc tuple_ConPat) +tidy1 v (TuplePat pats boxity ty) + = returnDs (idWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty -tidy1 v wrap (DictPat dicts methods) +tidy1 v (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) - 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) - _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed) + 0 -> tidy1 v (TuplePat [] Boxed unitTy) + 1 -> tidy1 v (unLoc (head dict_and_method_pats)) + _ -> tidy1 v (mkVanillaTuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map nlVarPat (dicts ++ methods) -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 v wrap pat@(LitPat lit) - = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat))) +tidy1 v (LitPat lit) + = returnDs (idWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty) - = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))) - --- and everything else goes through unchanged... - -tidy1 v wrap non_interesting_pat - = returnDs (wrap, non_interesting_pat) +tidy1 v (NPat lit mb_neg eq lit_ty) + = returnDs (idWrapper, tidyNPat lit mb_neg eq lit_ty) +-- Everything else goes through unchanged... -tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps -tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2] -tidy_con data_con ex_tvs pat_ty (RecCon rpats) - | null rpats - = -- Special case for C {}, which can be used for - -- a constructor that isn't declared to have - -- fields at all - map (noLoc . WildPat) con_arg_tys' - - | otherwise - = map mk_pat tagged_arg_tys - where - -- Boring stuff to find the arg-tys of the constructor - - inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque - | otherwise = mkTyVarTys ex_tvs - - con_arg_tys' = dataConInstOrigArgTys data_con inst_tys - tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con - - -- mk_pat picks a WildPat of the appropriate type for absent fields, - -- and the specified pattern for present fields - mk_pat (arg_ty, lbl) = - case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of - (pat:pats) -> ASSERT( null pats ) pat - [] -> noLoc (WildPat arg_ty) +tidy1 v non_interesting_pat + = returnDs (idWrapper, non_interesting_pat) \end{code} \noindent @@ -651,20 +611,18 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) = do { eqns_info <- mapM mk_eqn_info matches - ; new_vars <- selectMatchVars arg_pats pat_tys + ; new_vars <- selectMatchVars arg_pats ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where - arg_pats = map unLoc (hsLMatchPats (head matches)) - n_pats = length arg_pats - (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty + arg_pats = map unLoc (hsLMatchPats (head matches)) + n_pats = length arg_pats + (_, rhs_ty) = splitFunTysN n_pats match_ty mk_eqn_info (L _ (Match pats _ grhss)) = do { let upats = map unLoc pats ; match_result <- dsGRHSs ctxt upats grhss rhs_ty - ; return (EqnInfo { eqn_wrap = idWrapper, - eqn_pats = upats, - eqn_rhs = match_result}) } + ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } matchEquations :: HsMatchContext Name @@ -728,9 +686,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result where ds_ctx = DsMatchContext hs_ctx locn in - match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, - eqn_pats = [pat], - eqn_rhs = match_result }] + match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] matchSinglePat scrut hs_ctx pat ty match_result = selectSimpleMatchVarL pat `thenDs` \ var -> @@ -738,3 +694,82 @@ matchSinglePat scrut hs_ctx pat ty match_result returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} + +%************************************************************************ +%* * + Pattern classification +%* * +%************************************************************************ + +\begin{code} +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgLit Literal -- Literal patterns + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + + +groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +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]] +-- 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) + 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 + +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = True -- Needs conditionals +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant + -- See Note [Order of n+k] +sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 +sameGroup _ _ = False + +patGroup :: Pat Id -> PatGroup +patGroup (WildPat {}) = PgAny +patGroup (BangPat {}) = PgBang +patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) +patGroup (LitPat lit) = PgLit (hsLitKey lit) +patGroup (NPat olit mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of inner pattern +patGroup pat = pprPanic "patGroup" (ppr pat) +\end{code} + +Note [Order of n+k] +~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + 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. diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 6ff502a..2612b50 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -8,24 +8,21 @@ module MatchCon ( matchConFamily ) where #include "HsVersions.h" -import Id( idType ) - import {-# SOURCE #-} Match ( match ) -import HsSyn ( Pat(..), HsConDetails(..) ) +import HsSyn ( Pat(..), LPat, HsConDetails(..) ) import DsBinds ( dsLHsBinds ) -import DataCon ( isVanillaDataCon, dataConInstOrigArgTys ) +import DataCon ( DataCon, dataConInstOrigArgTys, + dataConFieldLabels, dataConSourceArity ) import TcType ( tcTyConAppArgs ) import Type ( mkTyVarTys ) import CoreSyn import DsMonad import DsUtils -import Id ( Id ) +import Id ( Id, idName ) import Type ( Type ) -import ListSetOps ( equivClassesByUniq ) import SrcLoc ( unLoc, Located(..) ) -import Unique ( Uniquable(..) ) import Outputable \end{code} @@ -82,63 +79,61 @@ have-we-used-all-the-constructors? question; the local function \begin{code} matchConFamily :: [Id] -> Type - -> [EquationInfo] + -> [[EquationInfo]] -> DsM MatchResult -matchConFamily (var:vars) ty eqns_info - = let - -- Sort into equivalence classes by the unique on the constructor - -- All the EqnInfos should start with a ConPat - groups = equivClassesByUniq get_uniq eqns_info - get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con - - -- Get the wrapper from the head of each group. We're going to - -- use it as the pattern in this case expression, so we need to - -- ensure that any type variables it mentions in the pattern are - -- in scope. So we put its wrappers outside the case, and - -- zap the wrapper for it. - wraps :: [CoreExpr -> CoreExpr] - wraps = map (eqn_wrap . head) groups - - groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ] - in - -- Now make a case alternative out of each group - mappM (match_con vars ty) groups' `thenDs` \ alts -> - returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $ - mkCoAlgCaseMatchResult var ty alts) -\end{code} - -And here is the local function that does all the work. It is -more-or-less the @matchCon@/@matchClause@ functions on page~94 in -Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the -list comprehension in @matchClause@ (SLPJ, p.~94) does, except things -are trickier in real life. Works for @ConPats@, and we want it to -fail catastrophically for anything else (which a list comprehension -wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@. - -\begin{code} -match_con vars ty eqns - = do { -- Make new vars for the con arguments; avoid new locals where possible - arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys - ; eqns' <- mapM shift eqns +-- Each group of eqns is for a single constructor +matchConFamily (var:vars) ty groups + = do { alts <- mapM (matchOneCon vars ty) groups + ; return (mkCoAlgCaseMatchResult var ty alts) } + +matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor + = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns) + ; arg_vars <- selectMatchVars (take (dataConSourceArity con) + (eqn_pats (head eqns'))) + -- Use the new arugment patterns as a source of + -- suggestions for the new variables ; match_result <- match (arg_vars ++ vars) ty eqns' - ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) } + ; return (con, tvs1 ++ dicts1 ++ arg_vars, + adjustMatchResult (foldr1 (.) wraps) match_result) } where - ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns) - - shift eqn@(EqnInfo { eqn_wrap = wrap, - eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats }) + ConPatOut { pat_con = L _ con, pat_ty = pat_ty1, + pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1 + + arg_tys = dataConInstOrigArgTys con inst_tys + inst_tys = tcTyConAppArgs pat_ty1 ++ mkTyVarTys tvs1 + -- Newtypes opaque, hence tcTyConAppArgs + + shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, + pat_binds = bind, pat_args = args + } : pats }) = do { prs <- dsLHsBinds bind - ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkDsLet (Rec prs), - eqn_pats = map unLoc arg_pats ++ pats }) } - - -- Get the arg types, which we use to type the new vars - -- to match on, from the "outside"; the types of pats1 may - -- be more refined, and hence won't do - arg_tys = dataConInstOrigArgTys con inst_tys - inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque! - | otherwise = mkTyVarTys tvs1 + ; return (wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkDsLet (Rec prs), + eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) } + +conArgPats :: DataCon + -> [Type] -- Instantiated argument types + -> HsConDetails Id (LPat Id) + -> [Pat Id] +conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps +conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] +conArgPats data_con arg_tys (RecCon rpats) + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + map WildPat arg_tys + + | otherwise + = zipWith mk_pat (dataConFieldLabels data_con) arg_tys + where + -- mk_pat picks a WildPat of the appropriate type for absent fields, + -- and the specified pattern for present fields + mk_pat lbl arg_ty + = case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of + (pat:pats) -> ASSERT( null pats ) unLoc pat + [] -> WildPat arg_ty \end{code} Note [Existentials in shift_con_pat] diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 0b7907b..3c10c1c 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -4,8 +4,8 @@ \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -module MatchLit ( dsLit, dsOverLit, - tidyLitPat, tidyNPat, +module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey, + tidyLitPat, tidyNPat, matchLiterals, matchNPlusKPats, matchNPats ) where #include "HsVersions.h" @@ -20,6 +20,7 @@ import HsSyn import Id ( Id, idType ) import CoreSyn import TyCon ( tyConDataCons ) +import DataCon ( DataCon ) import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy, isStringTy ) import Type ( Type ) @@ -29,10 +30,10 @@ import PrelNames ( eqStringName ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import SrcLoc ( noLoc ) -import ListSetOps ( equivClasses, runs ) import Ratio ( numerator, denominator ) -import SrcLoc ( Located(..) ) +import SrcLoc ( Located(..), unLoc ) import Outputable +import Util ( mapAndUnzip ) import FastString ( lengthFS, unpackFS ) \end{code} @@ -59,15 +60,16 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. \begin{code} dsLit :: HsLit -> DsM CoreExpr -dsLit (HsChar c) = returnDs (mkCharExpr c) +dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) +dsLit (HsIntPrim i) = returnDs (mkLit (MachInt i)) +dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) +dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) + +dsLit (HsChar c) = returnDs (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str -dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) dsLit (HsInteger i _) = mkIntegerExpr i dsLit (HsInt i) = returnDs (mkIntExpr i) -dsLit (HsIntPrim i) = returnDs (mkIntLit i) -dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) -dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) dsLit (HsRat r ty) = mkIntegerExpr (numerator r) `thenDs` \ num -> @@ -86,6 +88,28 @@ dsOverLit (HsIntegral _ lit) = dsExpr lit dsOverLit (HsFractional _ lit) = dsExpr lit \end{code} +\begin{code} +hsLitKey :: HsLit -> Literal +-- Get a Core literal to use (only) a grouping key +-- Hence its type doesn't need to match the type of the original literal +-- (and doesn't for strings) +-- It only works for primitive types and strings; +-- others have been removed by tidy +hsLitKey (HsIntPrim i) = mkMachInt i +hsLitKey (HsCharPrim c) = MachChar c +hsLitKey (HsStringPrim s) = MachStr s +hsLitKey (HsFloatPrim f) = MachFloat f +hsLitKey (HsDoublePrim d) = MachDouble d +hsLitKey (HsString s) = MachStr s + +hsOverLitKey :: HsOverLit a -> Bool -> Literal +-- Ditto for HsOverLit; the boolean indicates to negate +hsOverLitKey (HsIntegral i _) False = MachInt i +hsOverLitKey (HsIntegral i _) True = MachInt (-i) +hsOverLitKey (HsFractional r _) False = MachFloat r +hsOverLitKey (HsFractional r _) True = MachFloat (-r) +\end{code} + %************************************************************************ %* * Tidying lit pats @@ -93,30 +117,32 @@ dsOverLit (HsFractional _ lit) = dsExpr lit %************************************************************************ \begin{code} -tidyLitPat :: HsLit -> LPat Id -> LPat Id +tidyLitPat :: HsLit -> Pat Id -- Result has only the following HsLits: -- HsIntPrim, HsCharPrim, HsFloatPrim -- HsDoublePrim, HsStringPrim, HsString -- * HsInteger, HsRat, HsInt can't show up in LitPats -- * We get rid of HsChar right here -tidyLitPat (HsChar c) pat = mkCharLitPat c -tidyLitPat (HsString s) pat +tidyLitPat (HsChar c) = unLoc (mkCharLitPat c) +tidyLitPat (HsString s) | lengthFS s <= 1 -- Short string literals only - = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy) - (mkNilPat stringTy) (unpackFS s) + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) + (mkNilPat stringTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! -tidyLitPat lit pat = pat +tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id -tidyNPat over_lit mb_neg lit_ty default_pat +tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Type -> Pat Id +tidyNPat over_lit mb_neg eq lit_ty | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val) | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val) | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val) - | otherwise = default_pat + | otherwise = NPat over_lit mb_neg eq lit_ty where - mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty + mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty) neg_lit = case (mb_neg, over_lit) of (Nothing, _) -> over_lit (Just _, HsIntegral i s) -> HsIntegral (-i) s @@ -142,44 +168,40 @@ tidyNPat over_lit mb_neg lit_ty default_pat \begin{code} matchLiterals :: [Id] - -> Type -- Type of the whole case expression - -> [EquationInfo] + -> Type -- Type of the whole case expression + -> [[EquationInfo]] -- All PgLits -> DsM MatchResult --- All the EquationInfos have LitPats at the front - -matchLiterals (var:vars) ty eqns - = do { -- Group by literal - let groups :: [[(Literal, EquationInfo)]] - groups = equivClasses cmpTaggedEqn (tagLitEqns eqns) - -- Deal with each group - ; alts <- mapM match_group groups +matchLiterals (var:vars) ty sub_groups + = do { -- Deal with each group + ; alts <- mapM match_group sub_groups -- Combine results. For everything except String -- we can use a case expression; for String we need -- a chain of if-then-else ; if isStringTy (idType var) then - do { mrs <- mapM wrap_str_guard alts + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts ; return (foldr1 combineMatchResults mrs) } else return (mkCoPrimCaseMatchResult var ty alts) } where - match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult) - match_group group - = do { let (lits, eqns) = unzip group + match_group :: [EquationInfo] -> DsM (Literal, MatchResult) + match_group eqns + = do { let LitPat hs_lit = firstPat (head eqns) ; match_result <- match vars ty (shiftEqns eqns) - ; return (head lits, match_result) } + ; return (hsLitKey hs_lit, match_result) } - wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult + wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals - wrap_str_guard (MachStr s, mr) - = do { eq_str <- dsLookupGlobalId eqStringName - ; lit <- mkStringExprFS s + wrap_str_guard eq_str (MachStr s, mr) + = do { lit <- mkStringExprFS s ; let pred = mkApps (Var eq_str) [Var var, lit] ; return (mkGuardedMatchResult pred mr) } \end{code} + %************************************************************************ %* * Pattern matching on NPat @@ -187,35 +209,23 @@ matchLiterals (var:vars) ty eqns %************************************************************************ \begin{code} -matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult --- All the EquationInfos have NPat at the front - -matchNPats (var:vars) ty eqns - = do { let groups :: [[(Literal, EquationInfo)]] - groups = equivClasses cmpTaggedEqn (tagLitEqns eqns) - - ; match_results <- mapM (match_group . map snd) groups - - ; ASSERT( not (null match_results) ) - return (foldr1 combineMatchResults match_results) } - where - match_group :: [EquationInfo] -> DsM MatchResult - match_group (eqn1:eqns) - = do { lit_expr <- dsOverLit lit - ; neg_lit <- case mb_neg of +matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult + -- All NPats, but perhaps for different literals +matchNPats vars ty groups + = do { match_results <- mapM (matchOneNPat vars ty) groups + ; return (foldr1 combineMatchResults match_results) } + +matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal + = do { let NPat lit mb_neg eq_chk _ = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of Nothing -> return lit_expr Just neg -> do { neg_expr <- dsExpr neg ; return (App neg_expr lit_expr) } - ; eq_expr <- dsExpr eq_chk - ; let pred_expr = mkApps eq_expr [Var var, neg_lit] - ; match_result <- match vars ty (eqn1' : shiftEqns eqns) - ; return (adjustMatchResult (eqn_wrap eqn1) $ - -- Bring the eqn1 wrapper stuff into scope because - -- it may be used in pred_expr - mkGuardedMatchResult pred_expr match_result) } - where - NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1 - eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 } + ; eq_expr <- dsExpr eq_chk + ; let pred_expr = mkApps eq_expr [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } \end{code} @@ -235,95 +245,25 @@ We generate: \end{verbatim} -WATCH OUT! Consider - - f (n+1) = ... - f (n+2) = ... - 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 'runs' rather than 'equivClasses' \begin{code} -matchNPlusKPats all_vars@(var:vars) ty eqns - = do { let groups :: [[(Literal, EquationInfo)]] - groups = runs eqTaggedEqn (tagLitEqns eqns) - - ; match_results <- mapM (match_group . map snd) groups - - ; ASSERT( not (null match_results) ) - return (foldr1 combineMatchResults match_results) } +matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult + -- All NPlusKPats, for the *same* literal k +matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns) + = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1 + ; ge_expr <- dsExpr ge + ; minus_expr <- dsExpr minus + ; lit_expr <- dsOverLit lit + ; let pred_expr = mkApps ge_expr [Var var, lit_expr] + minusk_expr = mkApps minus_expr [Var var, lit_expr] + (wraps, eqns') = mapAndUnzip (shift n1) eqns + ; match_result <- match vars ty eqns' + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + adjustMatchResult (foldr1 (.) wraps) $ + match_result) } where - match_group :: [EquationInfo] -> DsM MatchResult - match_group (eqn1:eqns) - = do { ge_expr <- dsExpr ge - ; minus_expr <- dsExpr minus - ; lit_expr <- dsOverLit lit - ; let pred_expr = mkApps ge_expr [Var var, lit_expr] - minusk_expr = mkApps minus_expr [Var var, lit_expr] - ; match_result <- match vars ty (eqn1' : map shift eqns) - ; return (adjustMatchResult (eqn_wrap eqn1) $ - -- Bring the eqn1 wrapper stuff into scope because - -- it may be used in ge_expr, minusk_expr - mkGuardedMatchResult pred_expr $ - mkCoLetMatchResult (NonRec n1 minusk_expr) $ - match_result) } - where - NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1 - eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 } - - shift eqn@(EqnInfo { eqn_wrap = wrap, - eqn_pats = NPlusKPat (L _ n) _ _ _ : pats }) - = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats } -\end{code} - - -%************************************************************************ -%* * - Grouping functions -%* * -%************************************************************************ - -Given a blob of @LitPat@s/@NPat@s, we want to split them into those -that are ``same''/different as one we are looking at. We need to know -whether we're looking at a @LitPat@/@NPat@, and what literal we're after. - -\begin{code} --- Tag equations by the leading literal --- NB: we have ordering on Core Literals, but not on HsLits -cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering -cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2 - -eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool -eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2 - -tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)] -tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns] - -get_lit :: Pat Id -> Literal --- Get a Core literal to use (only) a grouping key --- Hence its type doesn't need to match the type of the original literal -get_lit (LitPat (HsIntPrim i)) = mkMachInt i -get_lit (LitPat (HsCharPrim c)) = MachChar c -get_lit (LitPat (HsStringPrim s)) = MachStr s -get_lit (LitPat (HsFloatPrim f)) = MachFloat f -get_lit (LitPat (HsDoublePrim d)) = MachDouble d -get_lit (LitPat (HsString s)) = MachStr s - -get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i -get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i) -get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r -get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r) - -get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i - --- These ones can't happen --- get_lit (LitPat (HsChar c)) --- get_lit (LitPat (HsInt i)) -get_lit other = pprPanic "get_lit:bad pattern" (ppr other) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats }) + = (wrapBind n n1, eqn { eqn_pats = pats }) + -- The wrapBind is a no-op for the first equation \end{code} - -- 1.7.10.4