Turn divInt# and modInt# into bitwise operations when possible
authorTakano Akio <tak@anoak.io>
Sun, 4 Sep 2016 17:22:22 +0000 (13:22 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 5 Sep 2016 18:58:20 +0000 (14:58 -0400)
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
compiler/prelude/PrelNames.hs
compiler/prelude/PrelRules.hs
compiler/prelude/primops.txt.pp
compiler/utils/Util.hs
libraries/ghc-prim/GHC/Classes.hs
testsuite/tests/simplCore/should_compile/Makefile
testsuite/tests/simplCore/should_compile/T5615.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/T5615.stdout [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index de3061d..8d1641a 100644 (file)
@@ -26,6 +26,7 @@ module CmmOpt (
 import CmmUtils
 import Cmm
 import DynFlags
+import Util
 
 import Outputable
 import Platform
@@ -376,26 +377,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
 
 isLit :: CmmExpr -> Bool
index 00e9ffe..558619a 100644 (file)
@@ -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,
index a57609a..8868047 100644 (file)
@@ -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
 
index e948610..a38dd57 100644 (file)
@@ -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
index 121fdbb..0b16fba 100644 (file)
@@ -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
index 9c40449..5fa118a 100644 (file)
@@ -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
index 8b7da66..288e3f9 100644 (file)
@@ -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
diff --git a/testsuite/tests/simplCore/should_compile/T5615.hs b/testsuite/tests/simplCore/should_compile/T5615.hs
new file mode 100644 (file)
index 0000000..9844804
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/testsuite/tests/simplCore/should_compile/T5615.stdout b/testsuite/tests/simplCore/should_compile/T5615.stdout
new file mode 100644 (file)
index 0000000..d00491f
--- /dev/null
@@ -0,0 +1 @@
+1
index e2e0bb6..f985b4a 100644 (file)
@@ -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,