Add some more Integer rules

Also renumbered the IDs and alined some things properly

2 files changed, 100 insertions, 71 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 77c5499265..e7eca77def 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -208,7 +208,7 @@ basicKnownKeyNames
         negateIntegerName, eqIntegerName, neqIntegerName,
         absIntegerName, signumIntegerName,
         leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
-        compareIntegerName,
+        compareIntegerName, quotRemIntegerName, divModIntegerName,
         gcdIntegerName, lcmIntegerName,
         andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
         shiftLIntegerName, shiftRIntegerName,
@@ -790,7 +790,7 @@ integerTyConName, mkIntegerName,
     negateIntegerName, eqIntegerName, neqIntegerName,
     absIntegerName, signumIntegerName,
     leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
-    compareIntegerName,
+    compareIntegerName, quotRemIntegerName, divModIntegerName,
     gcdIntegerName, lcmIntegerName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName :: Name
@@ -812,6 +812,8 @@ gtIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "gtInteger")         gtI
 ltIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "ltInteger")         ltIntegerIdKey
 geIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "geInteger")         geIntegerIdKey
 compareIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "compareInteger")    compareIntegerIdKey
+quotRemIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger")    quotRemIntegerIdKey
+divModIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "divModInteger")     divModIntegerIdKey
 gcdIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger")        gcdIntegerIdKey
 lcmIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger")        lcmIntegerIdKey
 andIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "andInteger")        andIntegerIdKey
@@ -1416,40 +1418,42 @@ otherwiseIdKey                = mkPreludeMiscIdUnique 43
 assertIdKey                   = mkPreludeMiscIdUnique 44
 runSTRepIdKey                 = mkPreludeMiscIdUnique 45
 
-smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
+mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
     eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
     leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
-    compareIntegerIdKey,
+    compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
     gcdIntegerIdKey, lcmIntegerIdKey,
     andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
-    shiftLIntegerIdKey, shiftRIntegerIdKey, mkIntegerIdKey :: Unique
-smallIntegerIdKey             = mkPreludeMiscIdUnique 60
-integerToWordIdKey            = mkPreludeMiscIdUnique 61
-integerToIntIdKey             = mkPreludeMiscIdUnique 62
-plusIntegerIdKey              = mkPreludeMiscIdUnique 63
-timesIntegerIdKey             = mkPreludeMiscIdUnique 64
-minusIntegerIdKey             = mkPreludeMiscIdUnique 65
-negateIntegerIdKey            = mkPreludeMiscIdUnique 66
-eqIntegerIdKey                = mkPreludeMiscIdUnique 67
-neqIntegerIdKey               = mkPreludeMiscIdUnique 68
-absIntegerIdKey               = mkPreludeMiscIdUnique 69
-signumIntegerIdKey            = mkPreludeMiscIdUnique 70
-leIntegerIdKey                = mkPreludeMiscIdUnique 71
-gtIntegerIdKey                = mkPreludeMiscIdUnique 72
-ltIntegerIdKey                = mkPreludeMiscIdUnique 73
-geIntegerIdKey                = mkPreludeMiscIdUnique 74
-compareIntegerIdKey           = mkPreludeMiscIdUnique 75
-gcdIntegerIdKey               = mkPreludeMiscIdUnique 85
-lcmIntegerIdKey               = mkPreludeMiscIdUnique 86
-andIntegerIdKey               = mkPreludeMiscIdUnique 87
-orIntegerIdKey                = mkPreludeMiscIdUnique 88
-xorIntegerIdKey               = mkPreludeMiscIdUnique 89
-complementIntegerIdKey        = mkPreludeMiscIdUnique 90
-shiftLIntegerIdKey            = mkPreludeMiscIdUnique 91
-shiftRIntegerIdKey            = mkPreludeMiscIdUnique 92
-mkIntegerIdKey                = mkPreludeMiscIdUnique 93
+    shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
+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
+gcdIntegerIdKey               = mkPreludeMiscIdUnique 79
+lcmIntegerIdKey               = mkPreludeMiscIdUnique 80
+andIntegerIdKey               = mkPreludeMiscIdUnique 81
+orIntegerIdKey                = mkPreludeMiscIdUnique 82
+xorIntegerIdKey               = mkPreludeMiscIdUnique 83
+complementIntegerIdKey        = mkPreludeMiscIdUnique 84
+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 85
+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 86
 
 rootMainKey, runMainKey :: Unique
 rootMainKey                   = mkPreludeMiscIdUnique 100
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index e8467aa27d..13e3a9cfb8 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -30,6 +30,7 @@ import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
 import CoreUtils   ( cheapEqExpr, exprIsHNF )
 import CoreUnfold  ( exprIsConApp_maybe )
 import Type
+import TypeRep
 import OccName     ( occNameFS )
 import PrelNames
 import Maybes      ( orElse )
@@ -605,57 +606,61 @@ are explicit.)
 builtinRules :: [CoreRule]
 -- Rules for non-primops that can't be expressed using a RULE pragma
 builtinRules
-  = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
-                    ru_nargs = 4, ru_try = match_append_lit },
-      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                    ru_nargs = 2, ru_try = match_eq_string },
-      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
-                    ru_nargs = 2, ru_try = match_inline },
-      rule_Integer_convert    "integerToWord" integerToWordName mkWordLitWord,
-      rule_Integer_convert    "integerToInt"  integerToIntName  mkIntLitInt,
-      rule_Integer_binop      "plusInteger"   plusIntegerName   (+),
-      rule_Integer_binop      "timesInteger"  timesIntegerName  (*),
-      rule_Integer_binop      "minusInteger"  minusIntegerName  (-),
-      rule_Integer_unop       "negateInteger" negateIntegerName negate,
-      rule_Integer_binop_Bool "eqInteger"     eqIntegerName     (==),
-      rule_Integer_binop_Bool "neqInteger"    neqIntegerName    (/=),
-      rule_Integer_unop       "absInteger"    absIntegerName    abs,
-      rule_Integer_unop       "signumInteger" signumIntegerName signum,
-      rule_Integer_binop_Bool "leInteger"     leIntegerName     (<=),
-      rule_Integer_binop_Bool "gtInteger"     gtIntegerName     (>),
-      rule_Integer_binop_Bool "ltInteger"     ltIntegerName     (<),
-      rule_Integer_binop_Bool "geInteger"     geIntegerName     (>=),
-      rule_Integer_binop_Ordering "compareInteger" compareIntegerName compare,
-      -- TODO: divMod/quoteRem/quot/rem rules. Due to the 0 check we
-      -- need rules for the generic functions, rather than the
-      -- Integer-specific functions
-      rule_Integer_binop      "gcdInteger"    gcdIntegerName    gcd,
-      rule_Integer_binop      "lcmInteger"    lcmIntegerName    lcm,
-      rule_Integer_binop      "andInteger"    andIntegerName    (.&.),
-      rule_Integer_binop      "orInteger"     orIntegerName     (.|.),
-      rule_Integer_binop      "xorInteger"    xorIntegerName    xor,
-      rule_Integer_unop       "complementInteger" complementIntegerName complement,
-      -- TODO: Likewise, these rules currently don't do anything, due to
-      -- the sign test in shift's definition
-      rule_Integer_Int_binop  "shiftLInteger" shiftLIntegerName shiftL,
-      rule_Integer_Int_binop  "shiftRInteger" shiftRIntegerName shiftR
-    ]
-    where rule_Integer_convert str name convert
+  = [BuiltinRule { ru_name = fsLit "AppendLitString",
+                   ru_fn = unpackCStringFoldrName,
+                   ru_nargs = 4, ru_try = match_append_lit },
+     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
+                   ru_nargs = 2, ru_try = match_eq_string },
+     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
+                   ru_nargs = 2, ru_try = match_inline }]
+ ++ builtinIntegerRules
+
+builtinIntegerRules :: [CoreRule]
+builtinIntegerRules =
+ [rule_convert        "integerToWord"     integerToWordName     mkWordLitWord,
+  rule_convert        "integerToInt"      integerToIntName      mkIntLitInt,
+  rule_binop          "plusInteger"       plusIntegerName       (+),
+  rule_binop          "timesInteger"      timesIntegerName      (*),
+  rule_binop          "minusInteger"      minusIntegerName      (-),
+  rule_unop           "negateInteger"     negateIntegerName     negate,
+  rule_binop_Bool     "eqInteger"         eqIntegerName         (==),
+  rule_binop_Bool     "neqInteger"        neqIntegerName        (/=),
+  rule_unop           "absInteger"        absIntegerName        abs,
+  rule_unop           "signumInteger"     signumIntegerName     signum,
+  rule_binop_Bool     "leInteger"         leIntegerName         (<=),
+  rule_binop_Bool     "gtInteger"         gtIntegerName         (>),
+  rule_binop_Bool     "ltInteger"         ltIntegerName         (<),
+  rule_binop_Bool     "geInteger"         geIntegerName         (>=),
+  rule_binop_Ordering "compareInteger"    compareIntegerName    compare,
+  rule_divop          "quotRemInteger"    quotRemIntegerName    quotRem,
+  rule_divop          "divModInteger"     divModIntegerName     divMod,
+  rule_binop          "gcdInteger"        gcdIntegerName        gcd,
+  rule_binop          "lcmInteger"        lcmIntegerName        lcm,
+  rule_binop          "andInteger"        andIntegerName        (.&.),
+  rule_binop          "orInteger"         orIntegerName         (.|.),
+  rule_binop          "xorInteger"        xorIntegerName        xor,
+  rule_unop           "complementInteger" complementIntegerName complement,
+  rule_Int_binop      "shiftLInteger"     shiftLIntegerName     shiftL,
+  rule_Int_binop      "shiftRInteger"     shiftRIntegerName     shiftR]
+    where rule_convert str name convert
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_Integer_convert convert }
-          rule_Integer_unop str name op
+          rule_unop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_Integer_unop op }
-          rule_Integer_binop str name op
+          rule_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop op }
-          rule_Integer_Int_binop str name op
+          rule_divop str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Integer_divop op }
+          rule_Int_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_binop op }
-          rule_Integer_binop_Bool str name op
+          rule_binop_Bool str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Bool op }
-          rule_Integer_binop_Ordering str name op
+          rule_binop_Ordering str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Ordering op }
 
@@ -746,6 +751,26 @@ match_Integer_binop binop _ [Lit (LitInteger x i), Lit (LitInteger y _)]
     = Just (Lit (LitInteger (x `binop` y) i))
 match_Integer_binop _ _ _ = Nothing
 
+-- This helper is used for the quotRem and divMod functions
+match_Integer_divop :: (Integer -> Integer -> (Integer, Integer))
+                    -> IdUnfoldingFun
+                    -> [Expr CoreBndr]
+                    -> Maybe (Expr CoreBndr)
+match_Integer_divop divop _ [Lit (LitInteger x i), Lit (LitInteger y _)]
+ | y /= 0
+    = case x `divop` y of
+      (r, s) ->
+          case idType i of
+          FunTy _ (FunTy _ integerTy) ->
+              Just $ mkConApp (tupleCon UnboxedTuple 2)
+                              [Type integerTy,
+                               Type integerTy,
+                               Lit (LitInteger r i),
+                               Lit (LitInteger s i)]
+          _ -> panic "match_Integer_divop: mkIntegerId has the wrong type"
+
+match_Integer_divop _ _ _ = Nothing
+
 match_Integer_Int_binop :: (Integer -> Int -> Integer)
                         -> IdUnfoldingFun
                         -> [Expr CoreBndr]