7724166 · text · git.iko.soy

git.iko.soy/text

on master help sign in

Implement checked multiplication for non-negative integers

7724166Bryan O'Sullivan12 years ago

Data/Text/Internal.hs+57−3

compare with master

unifiedsplit

@@ -1,4 +1,4 @@

1−{-# LANGUAGE CPP, DeriveDataTypeable #-}

1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}

2{-# OPTIONS_HADDOCK not-home #-}

4-- |

@@ -20,6 +20,10 @@

20-- with the internals, as the functions here do just about nothing to

21-- preserve data invariants. You have been warned!

23+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

24+#include "MachDeps.h"

25+#endif

26+

23module Data.Text.Internal

27module Data.Text.Internal

24 (

28 (

25 -- * Types

29 -- * Types

@@ -34,6 +38,10 @@ module Data.Text.Internal

34 , empty

38 , empty

35 -- * Utilities

39 -- * Utilities

36 , firstf

40 , firstf

41+ -- * Checked multiplication

42+ , mul

43+ , mul32

44+ , mul64

37 -- * Debugging

45 -- * Debugging

38 , showText

46 , showText

39 ) where

47 ) where

@@ -41,10 +49,11 @@ module Data.Text.Internal

41#if defined(ASSERTS)

49#if defined(ASSERTS)

42import Control.Exception (assert)

50import Control.Exception (assert)

43#endif

51#endif

44−import Data.Bits ((.&.))

52+import Data.Bits

45−import qualified Data.Text.Array as A

53+import Data.Int (Int32, Int64)

46import Data.Text.Internal.Unsafe.Char (ord)

54import Data.Text.Internal.Unsafe.Char (ord)

47import Data.Typeable (Typeable)

55import Data.Typeable (Typeable)

56+import qualified Data.Text.Array as A

49-- | A space efficient, packed, unboxed Unicode text type.

58-- | A space efficient, packed, unboxed Unicode text type.

50data Text = Text

59data Text = Text

@@ -108,6 +117,51 @@ firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)

108firstf f (Just (a, b)) = Just (f a, b)

117firstf f (Just (a, b)) = Just (f a, b)

109firstf _ Nothing = Nothing

118firstf _ Nothing = Nothing

110

119

120+-- | Checked multiplication. Calls 'error' if the result would

121+-- overflow.

122+mul :: Int -> Int -> Int

123+#if WORD_SIZE_IN_BITS == 64

124+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b

125+#else

126+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b

127+#endif

128+{-# INLINE mul #-}

129+infixl 7 `mul`

130+

131+-- | Checked multiplication. Calls 'error' if the result would

132+-- overflow.

133+mul64 :: Int64 -> Int64 -> Int64

134+mul64 a b

135+ | a >= 0 && b >= 0 = mul64_ a b

136+ | a >= 0 = -mul64_ a (-b)

137+ | b >= 0 = -mul64_ (-a) b

138+ | otherwise = mul64_ (-a) (-b)

139+{-# INLINE mul64 #-}

140+infixl 7 `mul64`

141+

142+mul64_ :: Int64 -> Int64 -> Int64

143+mul64_ a b

144+ | ahi > 0 && bhi > 0 = error "overflow"

145+ | top > 0x7fffffff = error "overflow"

146+ | total < 0 = error "overflow"

147+ | otherwise = total

148+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)

149+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)

150+ top = ahi * blo + alo * bhi

151+ total = (top `shiftL` 32) + alo * blo

152+{-# INLINE mul64_ #-}

153+

154+-- | Checked multiplication. Calls 'error' if the result would

155+-- overflow.

156+mul32 :: Int32 -> Int32 -> Int32

157+mul32 a b = case fromIntegral a * fromIntegral b of

158+ ab | ab < min32 || ab > max32 -> error "overflow"

159+ | otherwise -> fromIntegral ab

160+ where min32 = -0x80000000 :: Int64

161+ max32 = 0x7fffffff

162+{-# INLINE mul32 #-}

163+infixl 7 `mul32`

164+

111-- $internals

165-- $internals

112--

166--

113-- Internally, the 'Text' type is represented as an array of 'Word16'

167-- Internally, the 'Text' type is represented as an array of 'Word16'

tests/Tests/Properties.hs+4−1

@@ -54,6 +54,7 @@ import qualified Data.Text.Lazy.Builder.RealFloat as TB

54import qualified Data.Text.Lazy.Encoding as EL

55import qualified Data.Text.Lazy.IO as TL

56import qualified System.IO as IO

57+import qualified Tests.Properties.Mul as Mul

57import qualified Tests.SlowFunctions as Slow

58import qualified Tests.SlowFunctions as Slow

59t_pack_unpack = (T.unpack . T.pack) `eq` id

60t_pack_unpack = (T.unpack . T.pack) `eq` id

@@ -1308,5 +1309,7 @@ tests =

1308 testProperty "t_take_drop_16" t_take_drop_16,

1309 testProperty "t_take_drop_16" t_take_drop_16,

1309 testProperty "t_use_from" t_use_from,

1310 testProperty "t_use_from" t_use_from,

1310 testProperty "t_copy" t_copy

1311 testProperty "t_copy" t_copy

1311− ]

1312+ ],

1313+

1314+ testGroup "mul" Mul.tests

1312 ]

1315 ]

tests/Tests/Properties/Mul.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

3+module Tests.Properties.Mul (tests) where

5+import Control.Applicative ((<$>), pure)

6+import Control.Exception as E (SomeException, catch, evaluate)

7+import Data.Int (Int64)

8+import Data.Text.Internal (mul, mul64)

9+import System.IO.Unsafe (unsafePerformIO)

10+import Test.Framework (Test)

11+import Test.Framework.Providers.QuickCheck2 (testProperty)

12+import Test.QuickCheck hiding ((.&.))

13+

14+mulRef :: (Integral a, Bounded a) => a -> a -> Maybe a

15+mulRef a b

16+ | ab < bot || ab > top = Nothing

17+ | otherwise = Just (fromIntegral ab)

18+ where ab = fromIntegral a * fromIntegral b

19+ top = fromIntegral (maxBound `asTypeOf` a) :: Integer

20+ bot = fromIntegral (minBound `asTypeOf` a) :: Integer

21+

22+eval :: (a -> b -> c) -> a -> b -> Maybe c

23+eval f a b = unsafePerformIO $

24+ (Just <$> evaluate (f a b)) `E.catch` (\(_::SomeException) -> pure Nothing)

25+

26+t_mul64 :: Int64 -> Int64 -> Property

27+t_mul64 a b = mulRef a b === eval mul64 a b

28+

29+t_mul :: Int -> Int -> Property

30+t_mul a b = mulRef a b === eval mul a b

31+

32+tests :: [Test]

33+tests = [

34+ testProperty "t_mul" t_mul

35+ , testProperty "t_mul64" t_mul64

36+ ]

tests/text-tests.cabal+9

@@ -23,6 +23,15 @@ flag hpc

23executable text-tests

24 main-is: Tests.hs

26+ other-modules:

27+ Tests.IO

28+ Tests.Properties

29+ Tests.Properties.Mul

30+ Tests.QuickCheckUtils

31+ Tests.Regressions

32+ Tests.SlowFunctions

33+ Tests.Utils

34+

26 ghc-options:

35 ghc-options:

27 -Wall -threaded -O0 -rtsopts

36 -Wall -threaded -O0 -rtsopts

text.cabal+1

@@ -59,6 +59,7 @@ extra-source-files:

59 tests/.ghci

60 tests/Makefile

61 tests/Tests/*.hs

62+ tests/Tests/*/*.hs

62 tests/cabal.config

63 tests/cabal.config

63 tests/scripts/*.sh

64 tests/scripts/*.sh

64 tests/text-tests.cabal

65 tests/text-tests.cabal