X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=5e30f327781d33b0a9b5e45ed542ae90d7748530;hb=7583384214ed6aa4a90d77c5975728a9b06149f2;hp=31d3c28b2e8670991a9a7a14744a8e6f26011aef;hpb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;p=ghc-hetmet.git diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 31d3c28..5e30f32 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -6,13 +6,6 @@ Pattern-matching literal patterns \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey, tidyLitPat, tidyNPat, matchLiterals, matchNPlusKPats, matchNPats ) where @@ -26,10 +19,13 @@ import DsMonad import DsUtils import HsSyn + import Id import CoreSyn +import MkCore import TyCon import DataCon +import TcHsSyn ( shortCutLit ) import TcType import Type import PrelNames @@ -66,12 +62,12 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. \begin{code} dsLit :: HsLit -> DsM CoreExpr -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 (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 f)) +dsLit (HsDoublePrim d) = return (Lit (MachDouble d)) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str @@ -87,15 +83,26 @@ dsLit (HsRat r ty) = do = 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 (HsIsString _ 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 @@ -110,15 +117,18 @@ 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 :: HsOverLit a -> Bool -> Literal +hsOverLitKey :: OutputableBndr a => 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) -hsOverLitKey (HsIsString s _ _) False = MachStr s --- negated string should never happen +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} %************************************************************************ @@ -145,36 +155,43 @@ tidyLitPat lit = LitPat lit ---------------- tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id -tidyNPat over_lit mb_neg eq - | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val) - | isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val) - | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val) - | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val) +tidyNPat (OverLit val False _ ty) mb_neg _ + -- 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) - | otherwise = NPat over_lit mb_neg eq where mk_con_pat :: DataCon -> HsLit -> Pat Id - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit)) + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) - neg_lit = case (mb_neg, over_lit) of - (Nothing, _) -> over_lit - (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty - (Just _, HsFractional f s ty) -> HsFractional (-f) s 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 neg_lit of - HsIsString s _ _ -> s - _ -> error "tidyNPat" + str_val = case val of + HsIsString s -> s + _ -> panic "tidyNPat" +-} + +tidyNPat over_lit mb_neg eq + = NPat over_lit mb_neg eq \end{code} @@ -218,6 +235,9 @@ matchLiterals (var:vars) ty sub_groups = 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} @@ -234,6 +254,7 @@ 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 @@ -245,6 +266,7 @@ matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal ; 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} @@ -267,8 +289,8 @@ We generate: \begin{code} matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult - -- All NPlusKPats, for the *same* literal k -matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns) +-- 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 @@ -285,4 +307,7 @@ matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns) 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) + +matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) \end{code}