Add some more Integer rules

2 files changed, 69 insertions, 3 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 7c4115c3fb..5af98df4e8 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -254,6 +254,7 @@ basicKnownKeyNames
         -- Integer
         integerTyConName, mkIntegerName,
         integerToWord64Name, integerToInt64Name,
+        word64ToIntegerName, int64ToIntegerName,
         plusIntegerName, timesIntegerName, smallIntegerName,
         wordToIntegerName,
         integerToWordName, integerToIntName, minusIntegerName,
@@ -264,6 +265,7 @@ basicKnownKeyNames
         quotIntegerName, remIntegerName,
         floatFromIntegerName, doubleFromIntegerName,
         encodeFloatIntegerName, encodeDoubleIntegerName,
+        decodeDoubleIntegerName,
         gcdIntegerName, lcmIntegerName,
         andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
         shiftLIntegerName, shiftRIntegerName,
@@ -840,6 +842,7 @@ negateName        = methName gHC_NUM (fsLit "negate") negateClassOpKey
 
 integerTyConName, mkIntegerName,
     integerToWord64Name, integerToInt64Name,
+    word64ToIntegerName, int64ToIntegerName,
     plusIntegerName, timesIntegerName, smallIntegerName,
     wordToIntegerName,
     integerToWordName, integerToIntName, minusIntegerName,
@@ -850,6 +853,7 @@ integerTyConName, mkIntegerName,
     quotIntegerName, remIntegerName,
     floatFromIntegerName, doubleFromIntegerName,
     encodeFloatIntegerName, encodeDoubleIntegerName,
+    decodeDoubleIntegerName,
     gcdIntegerName, lcmIntegerName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName :: Name
@@ -857,6 +861,8 @@ integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           int
 mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey
 integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey
 integerToInt64Name    = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64")    integerToInt64IdKey
+word64ToIntegerName   = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger")   word64ToIntegerIdKey
+int64ToIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger")    int64ToIntegerIdKey
 plusIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "plusInteger")       plusIntegerIdKey
 timesIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "timesInteger")      timesIntegerIdKey
 smallIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "smallInteger")      smallIntegerIdKey
@@ -882,6 +888,7 @@ floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")
 doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger")     doubleFromIntegerIdKey
 encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger")  encodeFloatIntegerIdKey
 encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey
+decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey
 gcdIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger")        gcdIntegerIdKey
 lcmIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger")        lcmIntegerIdKey
 andIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "andInteger")        andIntegerIdKey
@@ -1504,6 +1511,7 @@ runSTRepIdKey                 = mkPreludeMiscIdUnique 45
 mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
     integerToWordIdKey, integerToIntIdKey,
     integerToWord64IdKey, integerToInt64IdKey,
+    word64ToIntegerIdKey, int64ToIntegerIdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
     eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
@@ -1512,6 +1520,7 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
     quotIntegerIdKey, remIntegerIdKey,
     floatFromIntegerIdKey, doubleFromIntegerIdKey,
     encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
+    decodeDoubleIntegerIdKey,
     gcdIntegerIdKey, lcmIntegerIdKey,
     andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
     shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
@@ -1551,6 +1560,9 @@ complementIntegerIdKey        = mkPreludeMiscIdUnique 92
 shiftLIntegerIdKey            = mkPreludeMiscIdUnique 93
 shiftRIntegerIdKey            = mkPreludeMiscIdUnique 94
 wordToIntegerIdKey            = mkPreludeMiscIdUnique 95
+word64ToIntegerIdKey          = mkPreludeMiscIdUnique 96
+int64ToIntegerIdKey           = mkPreludeMiscIdUnique 97
+decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 98
 
 rootMainKey, runMainKey :: Unique
 rootMainKey                   = mkPreludeMiscIdUnique 100
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 467c4c77de..db45bac3d2 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -624,12 +624,12 @@ builtinIntegerRules :: [CoreRule]
 builtinIntegerRules =
  [rule_IntToInteger   "smallInteger"        smallIntegerName,
   rule_WordToInteger  "wordToInteger"       wordToIntegerName,
+  rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,
+  rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,
   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
   rule_convert        "integerToWord64"     integerToWord64Name     mkWord64LitWord64,
-  -- TODO: word64ToInteger rule
   rule_convert        "integerToInt64"      integerToInt64Name      mkInt64LitInt64,
-  -- TODO: int64ToInteger rule
   rule_binop          "plusInteger"         plusIntegerName         (+),
   rule_binop          "minusInteger"        minusIntegerName        (-),
   rule_binop          "timesInteger"        timesIntegerName        (*),
@@ -650,7 +650,7 @@ builtinIntegerRules =
   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
   rule_convert        "floatFromInteger"    floatFromIntegerName    mkFloatLitFloat,
   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
-  -- TODO: decodeDoubleInteger rule
+  rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,
   rule_convert        "doubleFromInteger"   doubleFromIntegerName   mkDoubleLitDouble,
   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
@@ -669,6 +669,12 @@ builtinIntegerRules =
           rule_WordToInteger str name
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_WordToInteger }
+          rule_Int64ToInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_Int64ToInteger }
+          rule_Word64ToInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_Word64ToInteger }
           rule_unop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_Integer_unop op }
@@ -693,6 +699,9 @@ builtinIntegerRules =
           rule_encodeFloat str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_encodeFloat op }
+          rule_decodeDouble str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_decodeDouble }
 
 ---------------------------------------------------
 -- The rule is this:
@@ -782,6 +791,32 @@ match_WordToInteger id id_unf [xl]
         panic "match_WordToInteger: Id has the wrong type"
 match_WordToInteger _ _ _ = Nothing
 
+match_Int64ToInteger :: Id
+                     -> IdUnfoldingFun
+                     -> [Expr CoreBndr]
+                     -> Maybe (Expr CoreBndr)
+match_Int64ToInteger id id_unf [xl]
+  | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
+  = case idType id of
+    FunTy _ integerTy ->
+        Just (Lit (LitInteger x integerTy))
+    _ ->
+        panic "match_Int64ToInteger: Id has the wrong type"
+match_Int64ToInteger _ _ _ = Nothing
+
+match_Word64ToInteger :: Id
+                      -> IdUnfoldingFun
+                      -> [Expr CoreBndr]
+                      -> Maybe (Expr CoreBndr)
+match_Word64ToInteger id id_unf [xl]
+  | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
+  = case idType id of
+    FunTy _ integerTy ->
+        Just (Lit (LitInteger x integerTy))
+    _ ->
+        panic "match_Word64ToInteger: Id has the wrong type"
+match_Word64ToInteger _ _ _ = Nothing
+
 match_Integer_convert :: Num a
                       => (a -> Expr CoreBndr)
                       -> Id
@@ -892,4 +927,23 @@ match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
 match_Integer_Int_encodeFloat _ _ _ _ = Nothing
+
+match_decodeDouble :: Id
+                   -> IdUnfoldingFun
+                   -> [Expr CoreBndr]
+                   -> Maybe (Expr CoreBndr)
+match_decodeDouble fn id_unf [xl]
+  | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
+  = case idType fn of
+    FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
+        case decodeFloat (fromRational x :: Double) of
+        (y, z) ->
+            Just $ mkConApp (tupleCon UnboxedTuple 2)
+                            [Type integerTy,
+                             Type intHashTy,
+                             Lit (LitInteger y integerTy),
+                             Lit (MachInt (toInteger z))]
+    _ ->
+        panic "match_decodeDouble: Id has the wrong type"
+match_decodeDouble _ _ _ = Nothing
 \end{code}