Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/771d376bb6d2ab524741c6d0732718ac2613d2a1 >--------------------------------------------------------------- commit 771d376bb6d2ab524741c6d0732718ac2613d2a1 Author: John Lato <[email protected]> Date: Mon Oct 8 12:54:55 2012 +0800 add GHC.Float.rationalToFloat, rationalToDouble (fixes #7295) Adds better support for constant folding of Float/Double literals. - add rationalToFloat, rationalToDouble with associated Name/Id's in PrelNames. - add a matching rule in PrelRules for rationalTo* functions. >--------------------------------------------------------------- compiler/prelude/PrelNames.lhs | 13 +++++++++++++ compiler/prelude/PrelRules.lhs | 29 +++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 0 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3174974..4394309 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -270,6 +270,10 @@ basicKnownKeyNames andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, + -- Float/Double + rationalToFloatName, + rationalToDoubleName, + -- MonadFix monadFixClassName, mfixName, @@ -932,6 +936,11 @@ floatingClassName, realFloatClassName :: Name floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey +-- other GHC.Float functions +rationalToFloatName, rationalToDoubleName :: Name +rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + -- Class Ix ixClassName :: Name ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey @@ -1614,6 +1623,10 @@ dollarIdKey = mkPreludeMiscIdUnique 123 coercionTokenIdKey :: Unique coercionTokenIdKey = mkPreludeMiscIdUnique 124 +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 130 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 + -- dotnet interop unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index dcfb530..2f4d62f 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -840,6 +840,8 @@ builtinIntegerRules = rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), + rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, + rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, rule_binop "gcdInteger" gcdIntegerName gcd, rule_binop "lcmInteger" lcmIntegerName lcm, rule_binop "andInteger" andIntegerName (.&.), @@ -907,6 +909,9 @@ builtinIntegerRules = rule_smallIntegerTo str name primOp = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_smallIntegerTo primOp } + rule_rationalTo str name mkLit + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_rationalTo mkLit } --------------------------------------------------- -- The rule is this: @@ -1151,6 +1156,30 @@ match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl] = Just (mkLit $ encodeFloat x (fromInteger y)) match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing +--------------------------------------------------- +-- constant folding for Float/Double +-- +-- This turns +-- rationalToFloat n d +-- into a literal Float, and similarly for Doubles. +-- +-- it's important to not match d == 0, because that may represent a +-- literal "0/0" or similar, and we can't produce a literal value for +-- NaN or +-Inf +match_rationalTo :: RealFloat a + => (a -> Expr CoreBndr) + -> DynFlags + -> Id + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_rationalTo mkLit _ _ id_unf [xl, yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (mkLit (fromInteger x/fromInteger y)) +match_rationalTo _ _ _ _ _ = Nothing + match_decodeDouble :: DynFlags -> Id -> IdUnfoldingFun _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
