Commit 6ea62427 authored by takano-akio's avatar takano-akio Committed by Ben Gamari

Turn divInt# and modInt# into bitwise operations when possible

This implements #5615 for divInt# and modInt#.

I also included rules to do constant-folding when the both arguments
are known.

Test Plan: validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: hvr, thomie

Differential Revision: https://phabricator.haskell.org/D2486

GHC Trac Issues: #5615
parent 71dd6e44
......@@ -26,6 +26,7 @@ module CmmOpt (
import CmmUtils
import Cmm
import DynFlags
import Util
import Outputable
import Platform
......@@ -375,26 +376,6 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
cmmMachOpFoldM _ _ _ = Nothing
-- -----------------------------------------------------------------------------
-- exactLog2
-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
-- from GCC. It requires bit manipulation primitives, and we use GHC
-- extensions. Tough.
exactLog2 :: Integer -> Maybe Integer
exactLog2 x
= if (x <= 0 || x >= 2147483648) then
Nothing
else
if (x .&. (-x)) /= x then
Nothing
else
Just (pow2 x)
where
pow2 x | x == 1 = 0
| otherwise = 1 + pow2 (x `shiftR` 1)
-- -----------------------------------------------------------------------------
-- Utils
......
......@@ -232,6 +232,9 @@ basicKnownKeyNames
toIntegerName, toRationalName,
fromIntegralName, realToFracName,
-- Int# stuff
divIntName, modIntName,
-- String stuff
fromStringName,
......@@ -912,6 +915,11 @@ metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKe
metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey
metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey
-- Primitive Int
divIntName, modIntName :: Name
divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey
modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName :: Name
......@@ -1909,7 +1917,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
realWorldPrimIdKey, recConErrorIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
unpackCStringFoldrIdKey, unpackCStringIdKey,
typeErrorIdKey :: Unique
typeErrorIdKey, divIntIdKey, modIntIdKey :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
......@@ -1934,6 +1942,8 @@ unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19
unpackCStringIdKey = mkPreludeMiscIdUnique 20
voidPrimIdKey = mkPreludeMiscIdUnique 21
typeErrorIdKey = mkPreludeMiscIdUnique 22
divIntIdKey = mkPreludeMiscIdUnique 23
modIntIdKey = mkPreludeMiscIdUnique 24
unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
returnIOIdKey, newStablePtrIdKey,
......
......@@ -988,7 +988,26 @@ builtinRules
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }
ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
mkBasicRule divIntName 2 $ msum
[ nonZeroLit 1 >> binaryLit (intOp2 div)
, leftZero zeroi
, do
[arg, Lit (MachInt d)] <- getArgs
Just n <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
],
mkBasicRule modIntName 2 $ msum
[ nonZeroLit 1 >> binaryLit (intOp2 mod)
, leftZero zeroi
, do
[arg, Lit (MachInt d)] <- getArgs
Just _ <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId AndIOp)
`App` arg `App` mkIntVal dflags (d - 1)
]
]
++ builtinIntegerRules
......
......@@ -221,12 +221,16 @@ primop IntMulMayOfloOp "mulIntMayOflo#"
primop IntQuotOp "quotInt#" Dyadic
Int# -> Int# -> Int#
{Rounds towards zero.}
{Rounds towards zero. The behavior is undefined if the second argument is
zero.
}
with can_fail = True
primop IntRemOp "remInt#" Dyadic
Int# -> Int# -> Int#
{Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.}
{Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}. The
behavior is undefined if the second argument is zero.
}
with can_fail = True
primop IntQuotRemOp "quotRemInt#" GenPrimOp
......
......@@ -78,6 +78,9 @@ module Util (
-- * Argument processing
getCmd, toCmdArgs, toArgs,
-- * Integers
exactLog2,
-- * Floating point
readRational,
......@@ -985,6 +988,27 @@ toArgs str
Right (arg, rest)
_ ->
Left ("Couldn't read " ++ show s ++ " as String")
-----------------------------------------------------------------------------
-- Integers
-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
-- from GCC. It requires bit manipulation primitives, and we use GHC
-- extensions. Tough.
exactLog2 :: Integer -> Maybe Integer
exactLog2 x
= if (x <= 0 || x >= 2147483648) then
Nothing
else
if (x .&. (-x)) /= x then
Nothing
else
Just (pow2 x)
where
pow2 x | x == 1 = 0
| otherwise = 1 + pow2 (x `shiftR` 1)
{-
-- -----------------------------------------------------------------------------
-- Floats
......
......@@ -440,6 +440,9 @@ not False = True
-- These don't really belong here, but we don't have a better place to
-- put them
-- These functions have built-in rules.
{-# NOINLINE [0] divInt# #-}
{-# NOINLINE [0] modInt# #-}
divInt# :: Int# -> Int# -> Int#
x# `divInt#` y#
-- Be careful NOT to overflow if we do any additional arithmetic
......
......@@ -144,3 +144,13 @@ T10083:
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs-boot
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083a.hs
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs
.PHONY: T5615
T5615:
$(RM) -f T5615.o T5615.hi T5615.dump-simpl
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T5615.hs -ddump-simpl -ddump-to-file
-grep 'divInt#' T5615.dump-simpl
-grep 'modInt#' T5615.dump-simpl
-grep 'quotInt#' T5615.dump-simpl
-grep 'remInt#' T5615.dump-simpl
grep -c '1999#' T5615.dump-simpl
main :: IO ()
main = do
printInt $ 9999 `div` 5
printInt $ 9999 `mod` 5
n <- readLn
printInt $ n `div` 4
printInt $ n `mod` 4
printInt :: Int -> IO ()
printInt = print
......@@ -137,6 +137,7 @@ test('simpl021',
run_command,
['$MAKE -s --no-print-directory simpl021'])
test('T5327', normal, run_command, ['$MAKE -s --no-print-directory T5327'])
test('T5615', normal, run_command, ['$MAKE -s --no-print-directory T5615'])
test('T5623', normal, run_command, ['$MAKE -s --no-print-directory T5623'])
test('T5658b',
normal,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment