Commit 771d376b authored by jwlato's avatar jwlato Committed by ian@well-typed.com

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.
parent 4f83f541
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment