[commit: ghc] master: add GHC.Float.rationalToFloat, rationalToDouble (fixes #7295) (771d376)

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