summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CmmOpt.hs21
-rw-r--r--compiler/prelude/PrelNames.hs12
-rw-r--r--compiler/prelude/PrelRules.hs21
-rw-r--r--compiler/prelude/primops.txt.pp8
-rw-r--r--compiler/utils/Util.hs24
-rw-r--r--libraries/ghc-prim/GHC/Classes.hs3
-rw-r--r--testsuite/tests/simplCore/should_compile/Makefile10
-rw-r--r--testsuite/tests/simplCore/should_compile/T5615.hs10
-rw-r--r--testsuite/tests/simplCore/should_compile/T5615.stdout1
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T1
10 files changed, 87 insertions, 24 deletions
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index de3061d7d4..8d1641a7d4 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -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
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 00e9ffed96..558619a9db 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/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,
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index a57609a89d..8868047005 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/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
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index e948610556..a38dd57755 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/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
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 121fdbbf6f..0b16fba72d 100644
--- a/compiler/utils/Util.hs
+++ b/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
diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs
index 9c40449188..5fa118a7f6 100644
--- a/libraries/ghc-prim/GHC/Classes.hs
+++ b/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
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 8b7da66e27..288e3f96e5 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/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
diff --git a/testsuite/tests/simplCore/should_compile/T5615.hs b/testsuite/tests/simplCore/should_compile/T5615.hs
new file mode 100644
index 0000000000..984480431b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T5615.hs
@@ -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
index 0000000000..d00491fd7e
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T5615.stdout
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index e2e0bb6c31..f985b4a859 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/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,
View Lorry Controller Status