Add prelude rules for encode{Float,Double}Integer and integerTo{Int,Word}64

2 files changed, 59 insertions, 31 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 98460561c8..705782c272 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -253,6 +253,7 @@ basicKnownKeyNames
 
         -- Integer
         integerTyConName, mkIntegerName,
+        integerToWord64Name, integerToInt64Name,
         plusIntegerName, timesIntegerName, smallIntegerName,
         integerToWordName, integerToIntName, minusIntegerName,
         negateIntegerName, eqIntegerName, neqIntegerName,
@@ -261,6 +262,7 @@ basicKnownKeyNames
         compareIntegerName, quotRemIntegerName, divModIntegerName,
         quotIntegerName, remIntegerName,
         floatFromIntegerName, doubleFromIntegerName,
+        encodeFloatIntegerName, encodeDoubleIntegerName,
         gcdIntegerName, lcmIntegerName,
         andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
         shiftLIntegerName, shiftRIntegerName,
@@ -822,6 +824,7 @@ minusName         = methName gHC_NUM (fsLit "-") minusClassOpKey
 negateName        = methName gHC_NUM (fsLit "negate") negateClassOpKey
 
 integerTyConName, mkIntegerName,
+    integerToWord64Name, integerToInt64Name,
     plusIntegerName, timesIntegerName, smallIntegerName,
     integerToWordName, integerToIntName, minusIntegerName,
     negateIntegerName, eqIntegerName, neqIntegerName,
@@ -830,11 +833,14 @@ integerTyConName, mkIntegerName,
     compareIntegerName, quotRemIntegerName, divModIntegerName,
     quotIntegerName, remIntegerName,
     floatFromIntegerName, doubleFromIntegerName,
+    encodeFloatIntegerName, encodeDoubleIntegerName,
     gcdIntegerName, lcmIntegerName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName :: Name
 integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey
 mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey
+integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey
+integerToInt64Name    = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64")    integerToInt64IdKey
 plusIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "plusInteger")       plusIntegerIdKey
 timesIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "timesInteger")      timesIntegerIdKey
 smallIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "smallInteger")      smallIntegerIdKey
@@ -857,6 +863,8 @@ quotIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "quotInteger")       quo
 remIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "remInteger")        remIntegerIdKey
 floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromIntegerName")     floatFromIntegerIdKey
 doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromIntegerName")    doubleFromIntegerIdKey
+encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatIntegerName")   encodeFloatIntegerIdKey
+encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleIntegerName")  encodeDoubleIntegerIdKey
 gcdIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger")        gcdIntegerIdKey
 lcmIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger")        lcmIntegerIdKey
 andIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "andInteger")        andIntegerIdKey
@@ -1445,6 +1453,7 @@ assertIdKey                   = mkPreludeMiscIdUnique 44
 runSTRepIdKey                 = mkPreludeMiscIdUnique 45
 
 mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
+    integerToWord64IdKey, integerToInt64IdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
     eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
@@ -1452,6 +1461,7 @@ mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
     compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
     quotIntegerIdKey, remIntegerIdKey,
     floatFromIntegerIdKey, doubleFromIntegerIdKey,
+    encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
     gcdIntegerIdKey, lcmIntegerIdKey,
     andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
     shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
@@ -1459,33 +1469,37 @@ mkIntegerIdKey                = mkPreludeMiscIdUnique 60
 smallIntegerIdKey             = mkPreludeMiscIdUnique 61
 integerToWordIdKey            = mkPreludeMiscIdUnique 62
 integerToIntIdKey             = mkPreludeMiscIdUnique 63
-plusIntegerIdKey              = mkPreludeMiscIdUnique 64
-timesIntegerIdKey             = mkPreludeMiscIdUnique 65
-minusIntegerIdKey             = mkPreludeMiscIdUnique 66
-negateIntegerIdKey            = mkPreludeMiscIdUnique 67
-eqIntegerIdKey                = mkPreludeMiscIdUnique 68
-neqIntegerIdKey               = mkPreludeMiscIdUnique 69
-absIntegerIdKey               = mkPreludeMiscIdUnique 70
-signumIntegerIdKey            = mkPreludeMiscIdUnique 71
-leIntegerIdKey                = mkPreludeMiscIdUnique 72
-gtIntegerIdKey                = mkPreludeMiscIdUnique 73
-ltIntegerIdKey                = mkPreludeMiscIdUnique 74
-geIntegerIdKey                = mkPreludeMiscIdUnique 75
-compareIntegerIdKey           = mkPreludeMiscIdUnique 76
-quotRemIntegerIdKey           = mkPreludeMiscIdUnique 77
-divModIntegerIdKey            = mkPreludeMiscIdUnique 78
-quotIntegerIdKey              = mkPreludeMiscIdUnique 79
-remIntegerIdKey               = mkPreludeMiscIdUnique 80
-floatFromIntegerIdKey         = mkPreludeMiscIdUnique 81
-doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 82
-gcdIntegerIdKey               = mkPreludeMiscIdUnique 83
-lcmIntegerIdKey               = mkPreludeMiscIdUnique 84
-andIntegerIdKey               = mkPreludeMiscIdUnique 85
-orIntegerIdKey                = mkPreludeMiscIdUnique 86
-xorIntegerIdKey               = mkPreludeMiscIdUnique 87
-complementIntegerIdKey        = mkPreludeMiscIdUnique 88
-shiftLIntegerIdKey            = mkPreludeMiscIdUnique 89
-shiftRIntegerIdKey            = mkPreludeMiscIdUnique 90
+integerToWord64IdKey          = mkPreludeMiscIdUnique 64
+integerToInt64IdKey           = mkPreludeMiscIdUnique 65
+plusIntegerIdKey              = mkPreludeMiscIdUnique 66
+timesIntegerIdKey             = mkPreludeMiscIdUnique 67
+minusIntegerIdKey             = mkPreludeMiscIdUnique 68
+negateIntegerIdKey            = mkPreludeMiscIdUnique 69
+eqIntegerIdKey                = mkPreludeMiscIdUnique 70
+neqIntegerIdKey               = mkPreludeMiscIdUnique 71
+absIntegerIdKey               = mkPreludeMiscIdUnique 72
+signumIntegerIdKey            = mkPreludeMiscIdUnique 73
+leIntegerIdKey                = mkPreludeMiscIdUnique 74
+gtIntegerIdKey                = mkPreludeMiscIdUnique 75
+ltIntegerIdKey                = mkPreludeMiscIdUnique 76
+geIntegerIdKey                = mkPreludeMiscIdUnique 77
+compareIntegerIdKey           = mkPreludeMiscIdUnique 78
+quotRemIntegerIdKey           = mkPreludeMiscIdUnique 79
+divModIntegerIdKey            = mkPreludeMiscIdUnique 80
+quotIntegerIdKey              = mkPreludeMiscIdUnique 81
+remIntegerIdKey               = mkPreludeMiscIdUnique 82
+floatFromIntegerIdKey         = mkPreludeMiscIdUnique 83
+doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 84
+encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 85
+encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 86
+gcdIntegerIdKey               = mkPreludeMiscIdUnique 87
+lcmIntegerIdKey               = mkPreludeMiscIdUnique 88
+andIntegerIdKey               = mkPreludeMiscIdUnique 89
+orIntegerIdKey                = mkPreludeMiscIdUnique 90
+xorIntegerIdKey               = mkPreludeMiscIdUnique 91
+complementIntegerIdKey        = mkPreludeMiscIdUnique 92
+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 93
+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 94
 
 rootMainKey, runMainKey :: Unique
 rootMainKey                   = mkPreludeMiscIdUnique 100
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 6a3d90a218..2de75d1b34 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -625,9 +625,9 @@ builtinIntegerRules =
   -- TODO: wordToInteger rule
   rule_convert        "integerToWord"     integerToWordName     mkWordLitWord,
   rule_convert        "integerToInt"      integerToIntName      mkIntLitInt,
-  -- TODO: integerToWord64 rule
+  rule_convert        "integerToWord64"   integerToWord64Name   mkWord64LitWord64,
   -- TODO: word64ToInteger rule
-  -- TODO: integerToInt64 rule
+  rule_convert        "integerToInt64"    integerToInt64Name    mkInt64LitInt64,
   -- TODO: int64ToInteger rule
   rule_binop          "plusInteger"       plusIntegerName       (+),
   rule_binop          "minusInteger"      minusIntegerName      (-),
@@ -646,9 +646,9 @@ builtinIntegerRules =
   rule_divop_both     "quotRemInteger"    quotRemIntegerName    quotRem,
   rule_divop_one      "quotInteger"       quotIntegerName       quot,
   rule_divop_one      "remInteger"        remIntegerName        rem,
-  -- TODO: encodeFloatInteger rule
+  rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
   rule_convert        "floatFromInteger"  floatFromIntegerName  mkFloatLitFloat,
-  -- TODO: encodeDoubleInteger rule
+  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
   -- TODO: decodeDoubleInteger rule
   rule_convert        "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble,
   rule_binop          "gcdInteger"        gcdIntegerName        gcd,
@@ -683,6 +683,9 @@ builtinIntegerRules =
           rule_binop_Ordering str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Ordering op }
+          rule_encodeFloat str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Integer_Int_encodeFloat op }
 
 ---------------------------------------------------
 -- The rule is this:
@@ -839,4 +842,15 @@ match_Integer_binop_Ordering binop id_unf [xl, yl]
              EQ -> eqVal
              GT -> gtVal
 match_Integer_binop_Ordering _ _ _ = Nothing
+
+match_Integer_Int_encodeFloat :: RealFloat a
+                              => (a -> Expr CoreBndr)
+                              -> IdUnfoldingFun
+                              -> [Expr CoreBndr]
+                              -> Maybe (Expr CoreBndr)
+match_Integer_Int_encodeFloat mkLit id_unf [xl,yl]
+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
+  = Just (mkLit $ encodeFloat x (fromInteger y))
+match_Integer_Int_encodeFloat _ _ _ = Nothing
 \end{code}