X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatchLit.lhs;h=0b7907b22e9a4881432705fb4718ed9ca16206f4;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=287d730f7d5283178f1e50f850600aa87f3a6d38;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 287d730..0b7907b 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -4,7 +4,9 @@ \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -module MatchLit ( dsLit, matchLiterals ) where +module MatchLit ( dsLit, dsOverLit, + tidyLitPat, tidyNPat, + matchLiterals, matchNPlusKPats, matchNPats ) where #include "HsVersions.h" @@ -12,24 +14,26 @@ import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr ) import DsMonad -import DsCCall ( resultWrapper ) import DsUtils -import HsSyn ( HsLit(..), Pat(..), HsExpr(..) ) -import TcHsSyn ( TypecheckedPat ) -import Id ( Id ) +import HsSyn +import Id ( Id, idType ) import CoreSyn import TyCon ( tyConDataCons ) -import TcType ( tcSplitTyConApp, isIntegerTy ) - +import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, + isFloatTy, isDoubleTy, isStringTy ) +import Type ( Type ) import PrelNames ( ratioTyConKey ) +import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon ) +import PrelNames ( eqStringName ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) -import Maybes ( catMaybes ) -import Type ( isUnLiftedType ) -import Panic ( panic, assertPanic ) -import Maybe ( isJust ) +import SrcLoc ( noLoc ) +import ListSetOps ( equivClasses, runs ) import Ratio ( numerator, denominator ) +import SrcLoc ( Located(..) ) +import Outputable +import FastString ( lengthFS, unpackFS ) \end{code} %************************************************************************ @@ -57,19 +61,13 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. dsLit :: HsLit -> DsM CoreExpr dsLit (HsChar c) = returnDs (mkCharExpr c) dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) -dsLit (HsString str) = mkStringLitFS str +dsLit (HsString str) = mkStringExprFS str dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) -dsLit (HsInteger i) = mkIntegerExpr i +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 (HsLitLit str ty) - = ASSERT( isJust maybe_ty ) - returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) - where - (maybe_ty, wrap_fn) = resultWrapper ty - Just rep_ty = maybe_ty dsLit (HsRat r ty) = mkIntegerExpr (numerator r) `thenDs` \ num -> @@ -80,84 +78,152 @@ dsLit (HsRat r ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (head (tyConDataCons tycon), i_ty) + +dsOverLit :: HsOverLit Id -> DsM CoreExpr +-- Post-typechecker, the SyntaxExpr field of an OverLit contains +-- (an expression for) the literal value itself +dsOverLit (HsIntegral _ lit) = dsExpr lit +dsOverLit (HsFractional _ lit) = dsExpr lit +\end{code} + +%************************************************************************ +%* * + Tidying lit pats +%* * +%************************************************************************ + +\begin{code} +tidyLitPat :: HsLit -> LPat Id -> LPat 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 + | lengthFS s <= 1 -- Short string literals only + = 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 + +---------------- +tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id +tidyNPat over_lit mb_neg lit_ty default_pat + | 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 + where + mk_con_pat con lit = 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 + (Just _, HsFractional f s) -> HsFractional (-f) s + + int_val :: Integer + int_val = case neg_lit of + HsIntegral i _ -> i + HsFractional f _ -> panic "tidyNPat" + + rat_val :: Rational + rat_val = case neg_lit of + HsIntegral i _ -> fromInteger i + HsFractional f _ -> f \end{code} + %************************************************************************ %* * - Pattern matching on literals + Pattern matching on LitPat %* * %************************************************************************ \begin{code} matchLiterals :: [Id] + -> Type -- Type of the whole case expression -> [EquationInfo] -> 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 + + -- 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 + ; 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_result <- match vars ty (shiftEqns eqns) + ; return (head lits, match_result) } + + wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult + -- Equality check for string literals + wrap_str_guard (MachStr s, mr) + = do { eq_str <- dsLookupGlobalId eqStringName + ; lit <- mkStringExprFS s + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } \end{code} -This first one is a {\em special case} where the literal patterns are -unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@). We -want to avoid using the ``equality'' stuff provided by the -typechecker, and do a real ``case'' instead. In that sense, the code -is much like @matchConFamily@, which uses @match_cons_used@ to create -the alts---here we use @match_prims_used@. +%************************************************************************ +%* * + Pattern matching on NPat +%* * +%************************************************************************ \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns) - = -- GENERATE THE ALTS - match_prims_used vars eqns_info `thenDs` \ prim_alts -> +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 - -- MAKE THE PRIMITIVE CASE - returnDs (mkCoPrimCaseMatchResult var prim_alts) + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } where - match_prims_used _ [{-no more eqns-}] = returnDs [] - - match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - -- recursive call to make other alts... - match_prims_used vars eqns_not_for_this_lit `thenDs` \ rest_of_alts -> - - -- (prim pats have no args; no selectMatchVars as in match_cons_used) - -- now do the business to make the alt for _this_ LitPat ... - match vars shifted_eqns_for_this_lit `thenDs` \ match_result -> - returnDs ( - (mk_core_lit literal, match_result) - : rest_of_alts - ) - where - mk_core_lit :: HsLit -> Literal - - mk_core_lit (HsIntPrim i) = mkMachInt i - mk_core_lit (HsCharPrim c) = MachChar c - mk_core_lit (HsStringPrim s) = MachStr s - mk_core_lit (HsFloatPrim f) = MachFloat f - mk_core_lit (HsDoublePrim d) = MachDouble d - mk_core_lit (HsLitLit s ty) = ASSERT(isUnLiftedType ty) - MachLitLit s ty - mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled" + match_group :: [EquationInfo] -> DsM MatchResult + match_group (eqn1:eqns) + = do { 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 } \end{code} -\begin{code} -matchLiterals all_vars@(var:vars) - eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> - match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - let - match_result1 = mkGuardedMatchResult pred_expr inner_match_result - in - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - returnDs (combineMatchResults match_result1 match_result2) -\end{code} + +%************************************************************************ +%* * + Pattern matching on n+k patterns +%* * +%************************************************************************ For an n+k pattern, we use the various magic expressions we've been given. We generate: @@ -169,74 +235,95 @@ 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} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - - dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr -> - dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr -> - - let - match_result1 = mkGuardedMatchResult ge_expr $ - mkCoLetsMatchResult [NonRec master_n nminusk_expr] $ - inner_match_result - in - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - returnDs (combineMatchResults match_result1 match_result2) +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) } + 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} -partitionEqnsByLit :: TypecheckedPat - -> [EquationInfo] - -> ([EquationInfo], -- These ones are for this lit, AND - -- they've been "shifted" by stripping - -- off the first pattern - [EquationInfo] -- These are not for this lit; they - -- are exactly as fed in. - ) - -partitionEqnsByLit master_pat eqns - = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn master_pat) eqns)) - where - partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - - partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn (NPlusKPatOut master_n k1 _ _) - (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - where - new_match_result | master_n == n' = match_result - | otherwise = mkCoLetsMatchResult - [NonRec n' (Var master_n)] match_result - - -- Wild-card patterns, which will only show up in the shadows, - -- go into both groups - partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result) - = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn) - - -- Default case; not for this pattern - partition_eqn master_pat eqn = (Nothing, Just eqn) +-- 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) \end{code}