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

compiler/cmm/CmmOpt.hs

@@ -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
 

compiler/prelude/PrelNames.hs

@@ -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,

compiler/prelude/PrelRules.hs

@@ -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
 

compiler/prelude/primops.txt.pp

@@ -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

compiler/utils/Util.hs

@@ -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

libraries/ghc-prim/GHC/Classes.hs

@@ -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

testsuite/tests/simplCore/should_compile/Makefile

@@ -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

testsuite/tests/simplCore/should_compile/T5615.hs

+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

testsuite/tests/simplCore/should_compile/T5615.stdout

+1

testsuite/tests/simplCore/should_compile/all.T

@@ -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,