From 10916ab567e80151d8e30800e4a96263092a0367 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Tue, 10 Jan 2012 22:08:23 +0000
Subject: [PATCH] Add prelude rules for quotInteger, remInteger
---
compiler/prelude/PrelNames.lhs | 27 ++++++++++++++---------
compiler/prelude/PrelRules.lhs | 40 +++++++++++++++++++++++-----------
2 files changed, 44 insertions(+), 23 deletions(-)
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index a88e536eb214..98460561c8b0 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -259,6 +259,7 @@ basicKnownKeyNames
absIntegerName, signumIntegerName,
leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
+ quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
@@ -827,6 +828,7 @@ integerTyConName, mkIntegerName,
absIntegerName, signumIntegerName,
leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
compareIntegerName, quotRemIntegerName, divModIntegerName,
+ quotIntegerName, remIntegerName,
floatFromIntegerName, doubleFromIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
@@ -851,6 +853,8 @@ geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geI
compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey
quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey
divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey
+quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey
+remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey
floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromIntegerName") floatFromIntegerIdKey
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromIntegerName") doubleFromIntegerIdKey
gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey
@@ -1446,6 +1450,7 @@ mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
+ quotIntegerIdKey, remIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
gcdIntegerIdKey, lcmIntegerIdKey,
andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
@@ -1469,16 +1474,18 @@ geIntegerIdKey = mkPreludeMiscIdUnique 75
compareIntegerIdKey = mkPreludeMiscIdUnique 76
quotRemIntegerIdKey = mkPreludeMiscIdUnique 77
divModIntegerIdKey = mkPreludeMiscIdUnique 78
-floatFromIntegerIdKey = mkPreludeMiscIdUnique 79
-doubleFromIntegerIdKey = mkPreludeMiscIdUnique 80
-gcdIntegerIdKey = mkPreludeMiscIdUnique 81
-lcmIntegerIdKey = mkPreludeMiscIdUnique 82
-andIntegerIdKey = mkPreludeMiscIdUnique 83
-orIntegerIdKey = mkPreludeMiscIdUnique 84
-xorIntegerIdKey = mkPreludeMiscIdUnique 85
-complementIntegerIdKey = mkPreludeMiscIdUnique 86
-shiftLIntegerIdKey = mkPreludeMiscIdUnique 87
-shiftRIntegerIdKey = mkPreludeMiscIdUnique 88
+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
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 100
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 59142da10624..6a3d90a21890 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -642,10 +642,10 @@ builtinIntegerRules =
rule_binop_Bool "ltInteger" ltIntegerName (<),
rule_binop_Bool "geInteger" geIntegerName (>=),
rule_binop_Ordering "compareInteger" compareIntegerName compare,
- rule_divop "divModInteger" divModIntegerName divMod,
- rule_divop "quotRemInteger" quotRemIntegerName quotRem,
- -- TODO: quotInteger rule
- -- TODO: remInteger rule
+ rule_divop_both "divModInteger" divModIntegerName divMod,
+ rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
+ rule_divop_one "quotInteger" quotIntegerName quot,
+ rule_divop_one "remInteger" remIntegerName rem,
-- TODO: encodeFloatInteger rule
rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat,
-- TODO: encodeDoubleInteger rule
@@ -668,9 +668,12 @@ builtinIntegerRules =
rule_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop op }
- rule_divop str name op
+ rule_divop_both str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
- ru_try = match_Integer_divop op }
+ ru_try = match_Integer_divop_both op }
+ rule_divop_one str name op
+ = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+ ru_try = match_Integer_divop_one 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 }
@@ -773,11 +776,11 @@ match_Integer_binop binop id_unf [xl,yl]
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 id_unf [xl,yl]
+match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
+ -> IdUnfoldingFun
+ -> [Expr CoreBndr]
+ -> Maybe (Expr CoreBndr)
+match_Integer_divop_both divop id_unf [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
@@ -789,9 +792,20 @@ match_Integer_divop divop id_unf [xl,yl]
Type integerTy,
Lit (LitInteger r i),
Lit (LitInteger s i)]
- _ -> panic "match_Integer_divop: mkIntegerId has the wrong type"
+ _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type"
+match_Integer_divop_both _ _ _ = Nothing
-match_Integer_divop _ _ _ = Nothing
+-- This helper is used for the quotRem and divMod functions
+match_Integer_divop_one :: (Integer -> Integer -> Integer)
+ -> IdUnfoldingFun
+ -> [Expr CoreBndr]
+ -> Maybe (Expr CoreBndr)
+match_Integer_divop_one divop id_unf [xl,yl]
+ | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
+ , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+ , y /= 0
+ = Just (Lit (LitInteger (x `divop` y) i))
+match_Integer_divop_one _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer)
-> IdUnfoldingFun
--
GitLab