X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=5e30f327781d33b0a9b5e45ed542ae90d7748530;hb=ed8a98a544e23108c09c4b6b5411d30795ce2a5f;hp=4deb51c9d1daa85b752e41e922ff0429521e6627;hpb=46ce6c02e9153cd68a04bc86174f7db730f32785;p=ghc-hetmet.git diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 4deb51c..5e30f32 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -19,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 @@ -59,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 @@ -85,11 +88,21 @@ dsLit (HsRat r ty) = do 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 @@ -108,13 +121,14 @@ hsLitKey l = pprPanic "hsLitKey" (ppr l) 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 -hsOverLitKey l _ = pprPanic "hsOverLitKey" (ppr l) --- 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} %************************************************************************ @@ -141,41 +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 - (Just _, HsIsString {}) -> panic "tidyNPat/neg_lit HsIsString" + 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 {} -> panic "tidyNPat/int_val HsFractional" - HsIsString {} -> panic "tidyNPat/int_val HsIsString" + 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 - HsIsString {} -> panic "tidyNPat/rat_val HsIsString" + 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}