X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatchLit.lhs;h=5ca0569d648e8e08ce79321457b34947546d00b8;hb=6d36af4aff6e12afa50dae2fad3993c385f8081d;hp=b3e645d4a1675eeebd3c24717e9f02c1a937d9e2;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index b3e645d..5ca0569 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -1,102 +1,191 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -module MatchLit ( matchLiterals ) where +module MatchLit ( dsLit, tidyLitPat, tidyNPat, + matchLiterals, matchNPlusKPats, matchNPats ) where #include "HsVersions.h" import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr ) -import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, - Match, HsBinds, Stmt(..), DoOrListComp, HsType, ArithSeqInfo ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, - TypecheckedPat - ) -import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) ) -import Id ( GenId {- instance Eq -}, Id ) - import DsMonad import DsUtils +import HsSyn +import Id ( Id ) +import CoreSyn +import TyCon ( tyConDataCons ) +import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy ) +import Type ( Type ) +import PrelNames ( ratioTyConKey ) +import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon ) +import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) -import Maybes ( catMaybes ) -import Type ( isUnpointedType, Type ) -import Util ( panic, assertPanic ) +import SrcLoc ( noLoc ) +import ListSetOps ( equivClasses, runs ) +import Ratio ( numerator, denominator ) +import SrcLoc ( Located(..) ) +import Outputable +import FastString ( lengthFS, unpackFS ) \end{code} +%************************************************************************ +%* * + Desugaring literals + [used to be in DsExpr, but DsMeta needs it, + and it's nice to avoid a loop] +%* * +%************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. + \begin{code} -matchLiterals :: [Id] - -> [EquationInfo] - -> DsM MatchResult +dsLit :: HsLit -> DsM CoreExpr +dsLit (HsChar c) = returnDs (mkCharExpr c) +dsLit (HsCharPrim c) = returnDs (mkLit (MachChar 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 -> + mkIntegerExpr (denominator r) `thenDs` \ denom -> + returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) + where + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) \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@. +%************************************************************************ +%* * + Tidying lit pats +%* * +%************************************************************************ \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_ty : ps1) _ : eqns) - = -- GENERATE THE ALTS - match_prims_used vars eqns_info `thenDs` \ prim_alts -> +tidyLitPat :: HsLit -> LPat Id -> LPat Id +-- Result has only the following HsLits: +-- HsIntPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim ? +-- * HsInteger, HsRat, HsInt can't show up in LitPats, +-- * HsString has been turned into an NPat in tcPat +-- and we get rid of HsChar right here +tidyLitPat (HsChar c) pat = mkCharLitPat c +tidyLitPat lit pat = pat + +tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id +tidyNPat (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! + +tidyNPat lit lit_ty default_pat + | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty + | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty + | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty + | otherwise = default_pat - -- MAKE THE PRIMITIVE CASE - mkCoPrimCaseMatchResult var prim_alts where - match_prims_used _ [{-no more eqns-}] = returnDs [] - - match_prims_used vars eqns_info@(EqnInfo n ctx ((LitPat literal lit_ty):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit Nothing literal 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 lit_ty literal, match_result) - : rest_of_alts - ) - where - mk_core_lit :: Type -> HsLit -> Literal - - mk_core_lit ty (HsIntPrim i) = mkMachInt i - mk_core_lit ty (HsCharPrim c) = MachChar c - mk_core_lit ty (HsStringPrim s) = MachStr s - mk_core_lit ty (HsFloatPrim f) = MachFloat f - mk_core_lit ty (HsDoublePrim d) = MachDouble d - mk_core_lit ty (HsLitLit s) = ASSERT(isUnpointedType ty) - MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") - mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled" + mk_int (HsInteger i _) = HsIntPrim i + + mk_float (HsInteger i _) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f + + mk_double (HsInteger i _) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} + +%************************************************************************ +%* * + Pattern matching on LitPat +%* * +%************************************************************************ + \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPat literal lit_ty eq_chk):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit Nothing literal eqns_info - in - dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> - match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - mkGuardedMatchResult pred_expr inner_match_result `thenDs` \ match_result1 -> - - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 +matchLiterals :: [Id] -> Type -> [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) + + -- DO THE MATCHING FOR EACH GROUP + ; alts <- mapM match_group groups + + -- MAKE THE PRIMITIVE CASE + ; 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) } +\end{code} + +%************************************************************************ +%* * + Pattern matching on NPat +%* * +%************************************************************************ + +\begin{code} +matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- All the EquationInfos have NPatOut 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 { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var)) + ; 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 + NPatOut _ _ eq_chk : pats1 = eqn_pats eqn1 + eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 } \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: \begin{verbatim} @@ -107,89 +196,94 @@ 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 ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit (Just master_n) k 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 -> - - mkGuardedMatchResult - ge_expr - (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result) - `thenDs` \ match_result1 -> - - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - 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 (HsApp (noLoc ge) (nlHsVar var)) + ; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var)) + ; 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 ge_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + match_result) } + where + NPlusKPatOut (L _ n1) _ ge sub : pats1 = eqn_pats eqn1 + eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 } + + shift eqn@(EqnInfo { eqn_wrap = wrap, + eqn_pats = NPlusKPatOut (L _ n) _ _ _ : pats }) + = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats } \end{code} -Given a blob of LitPats/NPats, we want to split them into those + +%************************************************************************ +%* * + 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. +whether we're looking at a @LitPat@/@NPat@, and what literal we're after. \begin{code} -partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v - -- is the "master" variable; - -- Nothing for NPats and LitPats - -> HsLit - -> [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 nPlusK lit eqns - = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn nPlusK lit) eqns)) +-- 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 eqn, eqn) | eqn <- eqns] where - partition_eqn :: Maybe Id -> HsLit -> EquationInfo -> - (Maybe EquationInfo, Maybe EquationInfo) - - partition_eqn Nothing lit (EqnInfo n ctx (LitPat k _ : remaining_pats) match_result) - | lit `eq_lit` k = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn Nothing lit (EqnInfo n ctx (NPat k _ _ : remaining_pats) match_result) - | lit `eq_lit` k = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn (Just master_n) lit (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result) - | lit `eq_lit` k = (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 nPlusK lit 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 nPlusK lit eqn = (Nothing, Just eqn) - --- ToDo: meditate about this equality business... - -eq_lit (HsInt i1) (HsInt i2) = i1 == i2 -eq_lit (HsFrac f1) (HsFrac f2) = f1 == f2 - -eq_lit (HsIntPrim i1) (HsIntPrim i2) = i1 == i2 -eq_lit (HsFloatPrim f1) (HsFloatPrim f2) = f1 == f2 -eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2 -eq_lit (HsChar c1) (HsChar c2) = c1 == c2 -eq_lit (HsCharPrim c1) (HsCharPrim c2) = c1 == c2 -eq_lit (HsString s1) (HsString s2) = s1 == s2 -eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2 -eq_lit (HsLitLit s1) (HsLitLit s2) = s1 == s2 -- ToDo: ??? (dubious) -eq_lit other1 other2 = panic "matchLiterals:eq_lit" + get_lit eqn = case firstPat eqn of + LitPat hs_lit -> mk_core_lit hs_lit + NPatOut hs_lit _ _ -> mk_core_lit hs_lit + NPlusKPatOut _ i _ _ -> MachInt i + other -> panic "tagLitEqns:bad pattern" + +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 + + -- These ones are only needed in the NPatOut case, + -- and the Literal is only used as a key for grouping, + -- so the type doesn't matter. Actually I think HsInt, HsChar + -- can't happen, but it does no harm to include them +mk_core_lit (HsString s) = MachStr s +mk_core_lit (HsRat r _) = MachFloat r +mk_core_lit (HsInteger i _) = MachInt i +mk_core_lit (HsInt i) = MachInt i +mk_core_lit (HsChar c) = MachChar c \end{code} +