Ticket #7295: 0001-add-GHC.Float.rationalToFloat-rationalToDouble-fixes.patch

File 0001-add-GHC.Float.rationalToFloat-rationalToDouble-fixes.patch, 4.5 KB (added by jwlato, 7 months ago)

  • compiler/prelude/PrelNames.lhs 

    From 2c5c56e4b0ba37d5d04b62ebd8440790baead26e Mon Sep 17 00:00:00 2001
From: John Lato <jwlato@gmail.com>
Date: Mon, 8 Oct 2012 12:54:55 +0800
Subject: [PATCH] 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(+)

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 3174974..4394309 100644
    a b  
    270270        andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, 
    271271        shiftLIntegerName, shiftRIntegerName, 
    272272 
     273        -- Float/Double 
     274        rationalToFloatName, 
     275        rationalToDoubleName, 
     276 
    273277        -- MonadFix 
    274278        monadFixClassName, mfixName, 
    275279 
    … …  
    932936floatingClassName  = clsQual  gHC_FLOAT (fsLit "Floating") floatingClassKey 
    933937realFloatClassName = clsQual  gHC_FLOAT (fsLit "RealFloat") realFloatClassKey 
    934938 
     939-- other GHC.Float functions 
     940rationalToFloatName, rationalToDoubleName :: Name 
     941rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey 
     942rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey 
     943 
    935944-- Class Ix 
    936945ixClassName :: Name 
    937946ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey 
    … …  
    16141623coercionTokenIdKey :: Unique 
    16151624coercionTokenIdKey    = mkPreludeMiscIdUnique 124 
    16161625 
     1626rationalToFloatIdKey, rationalToDoubleIdKey :: Unique 
     1627rationalToFloatIdKey   = mkPreludeMiscIdUnique 130 
     1628rationalToDoubleIdKey  = mkPreludeMiscIdUnique 131 
     1629 
    16171630-- dotnet interop 
    16181631unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, 
    16191632    unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique 

  • compiler/prelude/PrelRules.lhs 

    diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index aa4156b..338203e 100644
    a b  
    798798  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, 
    799799  rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName, 
    800800  rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble), 
     801  rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr, 
     802  rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr, 
    801803  rule_binop          "gcdInteger"          gcdIntegerName          gcd, 
    802804  rule_binop          "lcmInteger"          lcmIntegerName          lcm, 
    803805  rule_binop          "andInteger"          andIntegerName          (.&.), 
    … …  
    865867          rule_smallIntegerTo str name primOp 
    866868           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, 
    867869                           ru_try = match_smallIntegerTo primOp } 
     870          rule_rationalTo str name mkLit 
     871           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, 
     872                           ru_try = match_rationalTo mkLit } 
    868873 
    869874--------------------------------------------------- 
    870875-- The rule is this: 
    … …  
    11091114  = Just (mkLit $ encodeFloat x (fromInteger y)) 
    11101115match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing 
    11111116 
     1117--------------------------------------------------- 
     1118-- constant folding for Float/Double 
     1119-- 
     1120-- This turns 
     1121--      rationalToFloat n d 
     1122-- into a literal Float, and similarly for Doubles. 
     1123-- 
     1124-- it's important to not match d == 0, because that may represent a 
     1125-- literal "0/0" or similar, and we can't produce a literal value for 
     1126-- NaN or +-Inf 
     1127match_rationalTo :: RealFloat a 
     1128                 => (a -> Expr CoreBndr) 
     1129                 -> DynFlags 
     1130                 -> Id 
     1131                 -> IdUnfoldingFun 
     1132                 -> [Expr CoreBndr] 
     1133                 -> Maybe (Expr CoreBndr) 
     1134match_rationalTo mkLit _ _ id_unf [xl, yl] 
     1135  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl 
     1136  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl 
     1137  , y /= 0 
     1138  = Just (mkLit (fromInteger x/fromInteger y)) 
     1139match_rationalTo _ _ _ _ _ = Nothing 
     1140 
    11121141match_decodeDouble :: DynFlags 
    11131142                   -> Id 
    11141143                   -> IdUnfoldingFun