diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index a88e536eb214f559c57c95949563019047a5ab99..98460561c8b08665ff99d4839ea4025f0f7b287b 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 59142da106245f4850bd4ebd17e8b4b5ba29f593..6a3d90a2189033a6719efa66d10eaab38af175e8 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