diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 8 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 39 |
2 files changed, 37 insertions, 10 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index a6eb834641..be6396cf21 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -308,7 +308,7 @@ basicKnownKeyNames decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, + shiftLIntegerName, shiftRIntegerName, bitIntegerName, -- Float/Double rationalToFloatName, @@ -939,7 +939,7 @@ integerTyConName, mkIntegerName, integerSDataConName, decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName :: Name + shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit n) integerSDataConKey where n = case cIntegerLibraryType of @@ -986,6 +986,7 @@ xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xor complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey +bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey -- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, @@ -1901,6 +1902,9 @@ typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507 toDynIdKey :: Unique toDynIdKey = mkPreludeMiscIdUnique 508 +bitIntegerIdKey :: Unique +bitIntegerIdKey = mkPreludeMiscIdUnique 509 + {- ************************************************************************ * * diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 1ab8543afc..d44c224479 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -1003,6 +1003,7 @@ builtinIntegerRules = rule_unop "complementInteger" complementIntegerName complement, rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR, + rule_bitInteger "bitInteger" bitIntegerName, -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs rule_divop_one "quotInteger" quotIntegerName quot, rule_divop_one "remInteger" remIntegerName rem, @@ -1039,6 +1040,9 @@ builtinIntegerRules = rule_unop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_unop op } + rule_bitInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntToInteger_unop (bit . fromIntegral) } rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } @@ -1155,14 +1159,7 @@ match_magicDict _ = Nothing -- Similarly Int64, Word64 match_IntToInteger :: RuleFun -match_IntToInteger _ id_unf fn [xl] - | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl - = case idType fn of - FunTy _ integerTy -> - Just (Lit (LitInteger x integerTy)) - _ -> - panic "match_IntToInteger: Id has the wrong type" -match_IntToInteger _ _ _ _ = Nothing +match_IntToInteger = match_IntToInteger_unop id match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] @@ -1209,6 +1206,32 @@ match_Integer_unop unop _ id_unf _ [xl] = Just (Lit (LitInteger (unop x) i)) match_Integer_unop _ _ _ _ _ = Nothing +{- Note [Rewriting bitInteger] + +For most types the bitInteger operation can be implemented in terms of shifts. +The integer-gmp package, however, can do substantially better than this if +allowed to provide its own implementation. However, in so doing it previously lost +constant-folding (see Trac #8832). The bitInteger rule above provides constant folding +specifically for this function. + +There is, however, a bit of trickiness here when it comes to ranges. While the +AST encodes all integers (even MachInts) as Integers, `bit` expects the bit +index to be given as an Int. Hence we coerce to an Int in the rule definition. +This will behave a bit funny for constants larger than the word size, but the user +should expect some funniness given that they will have at very least ignored a +warning in this case. +-} + +match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun +match_IntToInteger_unop unop _ id_unf fn [xl] + | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl + = case idType fn of + FunTy _ integerTy -> + Just (Lit (LitInteger (unop x) integerTy)) + _ -> + panic "match_IntToInteger_unop: Id has the wrong type" +match_IntToInteger_unop _ _ _ _ _ = Nothing + match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun match_Integer_binop binop _ id_unf _ [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl |