diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 310a05e1a95e7fc885077cbb8e6048cc4d9764f9..98149a4f79b373e3fbee2d60cdbdaf76e688ba2e 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -26,6 +26,7 @@ module CoreSyn (
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
+ mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
@@ -104,6 +105,7 @@ import Outputable
import Util
import Data.Data hiding (TyCon)
+import Data.Int
import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
@@ -1044,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b
mkWordLit w = Lit (mkMachWord w)
mkWordLitWord w = Lit (mkMachWord (toInteger w))
+mkWord64LitWord64 :: Word64 -> Expr b
+mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
+
+mkInt64LitInt64 :: Int64 -> Expr b
+mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
+
-- | Create a machine character literal expression of type @Char#@.
-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
mkCharLit :: Char -> Expr b
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 98460561c8b08665ff99d4839ea4025f0f7b287b..705782c27243f0eeba0b23eadc85f8f2608c0c64 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 6a3d90a2189033a6719efa66d10eaab38af175e8..2de75d1b34a04054d27d38cff50b23945e45e52a 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}