X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=0bd25389376c8a77ecd5e7961239fce2aa47dcc2;hp=0b7907b22e9a4881432705fb4718ed9ca16206f4;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 0b7907b..0bd2538 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -1,11 +1,13 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[MatchLit]{Pattern-matching literal patterns} + +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" @@ -17,23 +19,23 @@ import DsMonad import DsUtils import HsSyn -import Id ( Id, idType ) + +import Id import CoreSyn -import TyCon ( tyConDataCons ) -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 SrcLoc ( noLoc ) -import ListSetOps ( equivClasses, runs ) -import Ratio ( numerator, denominator ) -import SrcLoc ( Located(..) ) +import MkCore +import TyCon +import DataCon +import TcHsSyn ( shortCutLit ) +import TcType +import PrelNames +import TysWiredIn +import Literal +import SrcLoc +import Data.Ratio import Outputable -import FastString ( lengthFS, unpackFS ) +import BasicTypes +import Util +import FastString \end{code} %************************************************************************ @@ -59,31 +61,73 @@ 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 (HsCharPrim c) = returnDs (mkLit (MachChar c)) +dsLit (HsStringPrim s) = return (Lit (MachStr s)) +dsLit (HsCharPrim c) = return (Lit (MachChar c)) +dsLit (HsIntPrim i) = return (Lit (MachInt i)) +dsLit (HsWordPrim w) = return (Lit (MachWord w)) +dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) + +dsLit (HsChar c) = return (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 -> - mkIntegerExpr (denominator r) `thenDs` \ denom -> - returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) +dsLit (HsInt i) = return (mkIntExpr i) + +dsLit (HsRat r ty) = do + num <- mkIntegerExpr (numerator (fl_value r)) + denom <- mkIntegerExpr (denominator (fl_value r)) + return (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) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) 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 +dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = witness, ol_type = ty }) + | not rebindable + , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut] + | otherwise = dsExpr witness +\end{code} + +Note [Literal short cut] +~~~~~~~~~~~~~~~~~~~~~~~~ +The type checker tries to do this short-cutting as early as possible, but +becuase of unification etc, more information is available to the desugarer. +And where it's possible to generate the correct literal right away, it's +much better do do so. + + +\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 (HsWordPrim w) = mkMachWord w +hsLitKey (HsCharPrim c) = MachChar c +hsLitKey (HsStringPrim s) = MachStr s +hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) +hsLitKey (HsString s) = MachStr s +hsLitKey l = pprPanic "hsLitKey" (ppr l) + +hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal +-- Ditto for HsOverLit; the boolean indicates to negate +hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg + +litValKey :: OverLitVal -> Bool -> Literal +litValKey (HsIntegral i) False = MachInt i +litValKey (HsIntegral i) True = MachInt (-i) +litValKey (HsFractional r) False = MachFloat (fl_value r) +litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) +litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s \end{code} %************************************************************************ @@ -93,44 +137,71 @@ 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 +-- HsIntPrim, HsWordPrim, 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 - | 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 +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Pat Id +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for wierd cases like Trac #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we hvae 'instance IsString Int' + -- + + | isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit) + | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit) + | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit) + | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit) + | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit) 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" + mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) + + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just i + (Just _, HsIntegral i) -> Just (-i) + _ -> Nothing - rat_val :: Rational - rat_val = case neg_lit of - HsIntegral i _ -> fromInteger i - HsFractional f _ -> f + mb_rat_lit :: Maybe FractionalLit + mb_rat_lit = case (mb_neg, val) of + (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) + (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) + (Nothing, HsFractional f) -> Just f + (Just _, HsFractional f) -> Just (negateFractionalLit f) + _ -> Nothing + + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString s) -> Just s + _ -> Nothing + +tidyNPat _ over_lit mb_neg eq + = NPat over_lit mb_neg eq \end{code} @@ -142,44 +213,44 @@ 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 + = ASSERT( all notNull 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) } + wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) + +matchLiterals [] _ _ = panic "matchLiterals []" \end{code} + %************************************************************************ %* * Pattern matching on NPat @@ -188,34 +259,18 @@ 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 (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) } +matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) \end{code} @@ -235,95 +290,28 @@ 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 (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) (eqn1: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} + 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 + shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) - -%************************************************************************ -%* * - 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) +matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) \end{code} -