X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=6d7db7cce87a8056d6452b7f5bd36447fd7d9893;hp=0b7907b22e9a4881432705fb4718ed9ca16206f4;hb=ecdaf6bc29d23bd704df8c65442ee08032a585fc;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 0b7907b..6d7db7c 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 TyCon +import DataCon +import TcHsSyn ( shortCutLit ) +import TcType +import Type +import PrelNames +import TysWiredIn +import Unique +import Literal +import SrcLoc +import Ratio import Outputable -import FastString ( lengthFS, unpackFS ) +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 (mkLit (MachStr s)) +dsLit (HsCharPrim c) = return (mkLit (MachChar c)) +dsLit (HsIntPrim i) = return (mkLit (MachInt i)) +dsLit (HsWordPrim w) = return (mkLit (MachWord w)) +dsLit (HsFloatPrim f) = return (mkLit (MachFloat f)) +dsLit (HsDoublePrim d) = return (mkLit (MachDouble 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 r) + denom <- mkIntegerExpr (denominator 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 f +hsLitKey (HsDoublePrim d) = MachDouble 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 r +litValKey (HsFractional r) True = MachFloat (-r) +litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s \end{code} %************************************************************************ @@ -93,44 +137,60 @@ 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 :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id +tidyNPat over_lit@(OverLit val False _ ty) mb_neg eq + -- Take short cuts only if the literal is not using rebindable syntax + | isIntTy ty = mk_con_pat intDataCon (HsIntPrim int_val) + | isWordTy ty = mk_con_pat wordDataCon (HsWordPrim int_val) + | isFloatTy ty = mk_con_pat floatDataCon (HsFloatPrim rat_val) + | isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val) +-- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val) 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 + mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) + + neg_val = case (mb_neg, val) of + (Nothing, _) -> val + (Just _, HsIntegral i) -> HsIntegral (-i) + (Just _, HsFractional f) -> HsFractional (-f) + (Just _, HsIsString _) -> panic "tidyNPat" int_val :: Integer - int_val = case neg_lit of - HsIntegral i _ -> i - HsFractional f _ -> panic "tidyNPat" + int_val = case neg_val of + HsIntegral i -> i + _ -> panic "tidyNPat" rat_val :: Rational - rat_val = case neg_lit of - HsIntegral i _ -> fromInteger i - HsFractional f _ -> f + rat_val = case neg_val of + HsIntegral i -> fromInteger i + HsFractional f -> f + _ -> panic "tidyNPat" + +{- + str_val :: FastString + str_val = case val of + HsIsString s -> s + _ -> panic "tidyNPat" +-} + +tidyNPat over_lit mb_neg eq + = NPat over_lit mb_neg eq \end{code} @@ -142,44 +202,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 @@ -187,35 +247,25 @@ 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 :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +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) } +matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) \end{code} @@ -235,95 +285,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} - - -%************************************************************************ -%* * - 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 + 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) -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} -