Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • testsuite/driver/testlib.py
    ... ... @@ -13,6 +13,7 @@ import time
    13 13 
     import datetime
    14 14 
     import copy
    15 15 
     import glob
    16 
    +import random
    16 17 
     import sys
    17 18 
     from math import ceil, trunc, floor, log
    18 19 
     from pathlib import Path, PurePath
    ... ... @@ -648,6 +649,11 @@ def extra_files(files):
    648 649 
     def _extra_files(name, opts, files):
    649 650 
         opts.extra_files.extend(files)
    650 651
    652 
    +def mini_quickcheck(name, opts):
    653 
    +    miniqc = os.path.relpath(config.top / 'tests' / 'MiniQuickCheck.hs', opts.srcdir)
    654 
    +    opts.extra_files.extend([miniqc])
    655 
    +    opts.extra_run_opts += ' ' + str(random.getrandbits(64))
    656 
    +
    651 657 
     # Record the size of a specific file
    652 658 
     def collect_size ( deviation, path ):
    653 659 
         return collect_size_func(deviation, lambda: path)

  • testsuite/tests/MiniQuickCheck.hs
    1 
    +{-# LANGUAGE DataKinds                  #-}
    2 
    +{-# LANGUAGE DerivingStrategies         #-}
    3 
    +{-# LANGUAGE GeneralisedNewtypeDeriving #-}
    4 
    +{-# LANGUAGE RecordWildCards            #-}
    5 
    +{-# LANGUAGE TypeFamilies               #-}
    6 
    +
    7 
    +-- | A minimal QuickCheck-like property testing framework for use in the GHC
    8 
    +-- test suite.
    9 
    +--
    10 
    +-- We vendor this package to avoid depending on the real QuickCheck package,
    11 
    +-- as the latter (or one of its dependencies) may not build with the GHC version
    12 
    +-- being tested.
    13 
    +module MiniQuickCheck
    14 
    +  ( -- * QuickCheck generator
    15 
    +    Gen(..)
    16 
    +
    17 
    +    -- * QuickCheck typeclasses
    18 
    +  , Arbitrary(..)
    19 
    +  , IsProperty(..)
    20 
    +
    21 
    +    -- * QuickCheck properties
    22 
    +  , PropertyCheck(..)
    23 
    +  , PropertyTestArg(..)
    24 
    +  , Property(..)
    25 
    +  , forAll
    26 
    +  , (===)
    27 
    +  , propertyCompare
    28 
    +  , propertyAnd
    29 
    +  , getCheck
    30 
    +
    31 
    +    -- * QuickCheck test tree
    32 
    +  , Test(..)
    33 
    +
    34 
    +    -- * Running QuickCheck tests
    35 
    +  , Result(..)
    36 
    +  , Iterations(..)
    37 
    +  , runTestsMain
    38 
    +  , runTests
    39 
    +  , runTestInternal
    40 
    +
    41 
    +    -- * QuickCheck primitive generators
    42 
    +  , arbitraryInt64
    43 
    +  , arbitraryWord64
    44 
    +  , integralDownsize
    45 
    +  , wordDownsize
    46 
    +
    47 
    +    -- * QuickCheck newtypes
    48 
    +  , NonZero(..)
    49 
    +  , nonZero
    50 
    +  , BoundedShiftAmount(..)
    51 
    +  , BoundedBy(..)
    52 
    +  ) where
    53 
    +
    54 
    +-- base
    55 
    +import Control.Monad.IO.Class
    56 
    +  ( liftIO )
    57 
    +import Data.Bits
    58 
    +  ( (.|.), shiftL, shiftR
    59 
    +  , FiniteBits, finiteBitSize
    60 
    +  )
    61 
    +import Data.Int
    62 
    +  ( Int8, Int16, Int32, Int64 )
    63 
    +import Data.IORef
    64 
    +  ( newIORef, atomicModifyIORef' )
    65 
    +import Data.Kind
    66 
    +  ( Type )
    67 
    +import Data.List
    68 
    +  ( intercalate )
    69 
    +import Data.Proxy
    70 
    +  ( Proxy(..) )
    71 
    +import Data.Word
    72 
    +  ( Word8, Word16, Word32, Word64 )
    73 
    +import GHC.TypeNats
    74 
    +  ( Nat, KnownNat, natVal )
    75 
    +import Numeric.Natural
    76 
    +  ( Natural )
    77 
    +import System.Environment
    78 
    +  ( getArgs )
    79 
    +import System.Exit
    80 
    +  ( die, exitFailure )
    81 
    +import Text.Read
    82 
    +  ( readMaybe )
    83 
    +
    84 
    +-- transformers
    85 
    +import Control.Monad.Trans.Reader
    86 
    +  ( ReaderT, runReaderT, ask, local )
    87 
    +import Control.Monad.Trans.State.Strict
    88 
    +  ( State, state, runState )
    89 
    +
    90 
    +--------------------------------------------------------------------------------
    91 
    +-- Core framework
    92 
    +
    93 
    +newtype Gen a = Gen { runGen :: State Word64 a }
    94 
    +  deriving newtype ( Functor, Applicative, Monad )
    95 
    +
    96 
    +class Arbitrary a where
    97 
    +  arbitrary :: Gen a
    98 
    +
    99 
    +class IsProperty p where
    100 
    +  property :: p -> Property
    101 
    +
    102 
    +data PropertyCheck
    103 
    +  = PropertyBinaryOp Bool String String String
    104 
    +  | PropertyAnd PropertyCheck PropertyCheck
    105 
    +
    106 
    +instance IsProperty PropertyCheck where
    107 
    +  property check = Prop (pure (PropertyEOA check))
    108 
    +
    109 
    +data PropertyTestArg
    110 
    +  = PropertyEOA PropertyCheck
    111 
    +  | PropertyArg String PropertyTestArg
    112 
    +
    113 
    +getCheck :: PropertyTestArg -> ([String], PropertyCheck)
    114 
    +getCheck (PropertyEOA pc)    = ([], pc)
    115 
    +getCheck (PropertyArg s pta) = let (ss, pc) = getCheck pta in (s:ss, pc)
    116 
    +
    117 
    +data Property = Prop { unProp :: Gen PropertyTestArg }
    118 
    +
    119 
    +instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
    120 
    +  property p = forAll arbitrary p
    121 
    +
    122 
    +-- | Run a generator for a value of the given type and add it as an argument
    123 
    +-- to the property test.
    124 
    +forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
    125 
    +forAll generator tst = Prop $ do
    126 
    +  a <- generator
    127 
    +  augment a <$> unProp (property (tst a))
    128 
    +  where
    129 
    +    augment a arg = PropertyArg (show a) arg
    130 
    +
    131 
    +-- | Build a @PropertyCheck@ by comparing two values with a named predicate.
    132 
    +propertyCompare :: Show a => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
    133 
    +propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b)
    134 
    +
    135 
    +-- | Check that two values are equal (by '==').
    136 
    +(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
    137 
    +(===) = propertyCompare "==" (==)
    138 
    +infix 4 ===
    139 
    +
    140 
    +-- | Conjunction of two property checks.
    141 
    +propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck
    142 
    +propertyAnd = PropertyAnd
    143 
    +
    144 
    +--------------------------------------------------------------------------------
    145 
    +-- Test tree
    146 
    +
    147 
    +-- | A named test or group of tests.
    148 
    +data Test where
    149 
    +  Group    :: String -> [Test] -> Test
    150 
    +  Property :: IsProperty prop => String -> prop -> Test
    151 
    +
    152 
    +--------------------------------------------------------------------------------
    153 
    +-- Test runner
    154 
    +
    155 
    +newtype Iterations = Iterations { nbIterations :: Word }
    156 
    +  deriving newtype ( Show, Eq, Ord )
    157 
    +
    158 
    +-- | Outcome of running a test suite.
    159 
    +data Result = Success | Failure [[String]]
    160 
    +
    161 
    +instance Semigroup Result where
    162 
    +  Success    <> y          = y
    163 
    +  x          <> Success    = x
    164 
    +  Failure xs <> Failure ys = Failure (xs ++ ys)
    165 
    +
    166 
    +instance Monoid Result where
    167 
    +  mempty = Success
    168 
    +
    169 
    +data RunS = RunS
    170 
    +  { depth       :: Int
    171 
    +  , currentSeed :: Word64
    172 
    +  , context     :: [String]
    173 
    +  }
    174 
    +
    175 
    +putMsg :: String -> ReaderT RunS IO ()
    176 
    +putMsg s = do
    177 
    +  n <- depth <$> ask
    178 
    +  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
    179 
    +
    180 
    +nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
    181 
    +nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
    182 
    +
    183 
    +runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
    184 
    +runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
    185 
    +  if ok
    186 
    +    then return Success
    187 
    +    else do
    188 
    +      ctx <- context <$> ask
    189 
    +      let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
    190 
    +      putMsg msg
    191 
    +      return (Failure [msg : ctx])
    192 
    +runPropertyCheck (PropertyAnd a b) =
    193 
    +  (<>) <$> runPropertyCheck a <*> runPropertyCheck b
    194 
    +
    195 
    +runProperty :: Iterations -> Property -> ReaderT RunS IO Result
    196 
    +runProperty (Iterations iters) (Prop p) = do
    197 
    +  startingSeed <- currentSeed <$> ask
    198 
    +  loop iters startingSeed
    199 
    +  where
    200 
    +    loop 0 _ = do
    201 
    +      putMsg ("Passed " ++ show iters ++ " iterations")
    202 
    +      return Success
    203 
    +    loop n s = do
    204 
    +      let (pt, s') = runState (runGen p) s
    205 
    +          (ss, pc) = getCheck pt
    206 
    +      res <- runPropertyCheck pc
    207 
    +      case res of
    208 
    +        Success      -> loop (n - 1) s'
    209 
    +        Failure msgs -> do
    210 
    +          let msg = "With arguments " ++ intercalate ", " ss ++ " (Seed: " ++ show s ++ ")"
    211 
    +          putMsg msg
    212 
    +          return (Failure (map (msg :) msgs))
    213 
    +
    214 
    +-- | Run a single 'Test', accumulating all failures.
    215 
    +runTestInternal :: Iterations -> Test -> ReaderT RunS IO Result
    216 
    +runTestInternal iters (Group name tests) = do
    217 
    +  let label = "Group " ++ name
    218 
    +  putMsg label
    219 
    +  env <- ask
    220 
    +  nest label $ do
    221 
    +    -- Compute initial seed for each test in the group, based on the
    222 
    +    -- index of the test in the group.
    223 
    +    let runOne idx t = do
    224 
    +          let !s = snd $ stepLCG (currentSeed env + fromIntegral idx)
    225 
    +          local (\e -> e { currentSeed = s }) (runTestInternal iters t)
    226 
    +    mconcat <$> traverse (uncurry runOne) (zip [1..] tests)
    227 
    +
    228 
    +runTestInternal iters (Property name p) = do
    229 
    +  let label = "Running " ++ name
    230 
    +  putMsg label
    231 
    +  nest label (runProperty iters (property p))
    232 
    +
    233 
    +showStack :: Int -> [String] -> String
    234 
    +showStack _  []     = ""
    235 
    +showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
    236 
    +
    237 
    +-- | Standard @main@ entry point for tests using 'MiniQuickCheck'.
    238 
    +--
    239 
    +-- Reads a 'Word64' seed from the first command-line argument, then
    240 
    +-- delegates to 'runTests'.
    241 
    +runTestsMain :: Iterations -> Test -> IO ()
    242 
    +runTestsMain iters t = do
    243 
    +  args <- getArgs
    244 
    +  seed <- case args of
    245 
    +    [arg] -> case readMaybe arg of
    246 
    +      Just s  -> pure s
    247 
    +      Nothing -> die $ "Invalid seed: " ++ show arg
    248 
    +    _ -> die "Usage: <test-name> <seed>"
    249 
    +  runTests iters seed t
    250 
    +
    251 
    +runTests :: Iterations -> Word64 -> Test -> IO ()
    252 
    +runTests iters seed t = do
    253 
    +  res <- runReaderT (runTestInternal iters t) (RunS 0 seed [])
    254 
    +  case res of
    255 
    +    Success      -> return ()
    256 
    +    Failure tests -> do
    257 
    +      putStrLn $ "Seed: " ++ show seed
    258 
    +      putStrLn $ "These tests failed:\n"
    259 
    +              ++ intercalate "\n" (map (showStack 0 . reverse) tests)
    260 
    +      exitFailure
    261 
    +
    262 
    +--------------------------------------------------------------------------------
    263 
    +-- Random number generation (linear congruences)
    264 
    +
    265 
    +-- Constants from Knuth's MMIX
    266 
    +
    267 
    +lcgMultiplier :: Word64
    268 
    +lcgMultiplier = 6364136223846793005
    269 
    +lcgIncrement :: Word64
    270 
    +lcgIncrement = 1442695040888963407
    271 
    +
    272 
    +-- | Pure step function for the linear congruential generator
    273 
    +stepLCG :: Word64 -> (Word64, Word64)
    274 
    +stepLCG s =
    275 
    +  let s' = s * lcgMultiplier + lcgIncrement
    276 
    +  in (s', s')
    277 
    +
    278 
    +--------------------------------------------------------------------------------
    279 
    +-- Primitive generators
    280 
    +
    281 
    +-- | Generate a uniformly random 'Word64'.
    282 
    +arbitraryWord64 :: Gen Word64
    283 
    +arbitraryWord64 = Gen $ state stepLCG
    284 
    +
    285 
    +-- | Generate a uniformly random 'Int64' (bit-reinterpretation of a Word64).
    286 
    +arbitraryInt64 :: Gen Int64
    287 
    +arbitraryInt64 = fromIntegral <$> arbitraryWord64
    288 
    +
    289 
    +-- | Shrink a random 'Int64' down to a smaller integral type.
    290 
    +integralDownsize :: (Integral a, FiniteBits a) => Int64 -> a
    291 
    +integralDownsize = wordDownsize . fromIntegral
    292 
    +
    293 
    +-- | Shrink a random 'Word64' down to a smaller integral type.
    294 
    +wordDownsize :: forall a. (Integral a, FiniteBits a) => Word64 -> a
    295 
    +wordDownsize w =
    296 
    +  fromIntegral (w `shiftR` (64 - finiteBitSize (undefined :: a)))
    297 
    +    -- take the higher bits (more random with our LCG)
    298 
    +
    299 
    +--------------------------------------------------------------------------------
    300 
    +-- Basic Arbitrary instances
    301 
    +
    302 
    +instance Arbitrary Bool where
    303 
    +  arbitrary = ( == 1 ) . ( `shiftR` 63 ) <$> arbitraryWord64
    304 
    +
    305 
    +instance Arbitrary Word64 where
    306 
    +  arbitrary = arbitraryWord64
    307 
    +instance Arbitrary Word32 where
    308 
    +  arbitrary = wordDownsize <$> arbitraryWord64
    309 
    +instance Arbitrary Word16 where
    310 
    +  arbitrary = wordDownsize <$> arbitraryWord64
    311 
    +instance Arbitrary Word8 where
    312 
    +  arbitrary = wordDownsize <$> arbitraryWord64
    313 
    +instance Arbitrary Word where
    314 
    +  arbitrary = fromIntegral <$> arbitraryWord64
    315 
    +
    316 
    +instance Arbitrary Int64 where
    317 
    +  arbitrary = arbitraryInt64
    318 
    +instance Arbitrary Int32 where
    319 
    +  arbitrary = integralDownsize <$> arbitraryInt64
    320 
    +instance Arbitrary Int16 where
    321 
    +  arbitrary = integralDownsize <$> arbitraryInt64
    322 
    +instance Arbitrary Int8 where
    323 
    +  arbitrary = integralDownsize <$> arbitraryInt64
    324 
    +instance Arbitrary Int where
    325 
    +  arbitrary = fromIntegral <$> arbitraryInt64
    326 
    +
    327 
    +-- | Generates a natural number with at most 192 bits set.
    328 
    +instance Arbitrary Natural where
    329 
    +  arbitrary = do
    330 
    +    cx <- ( `shiftR` 62 ) <$> arbitraryWord64
    331 
    +    n1 <- fromIntegral <$> arbitraryWord64
    332 
    +    n2 <- fromIntegral <$> arbitraryWord64
    333 
    +    n3 <- fromIntegral <$> arbitraryWord64
    334 
    +
    335 
    +    pure $ case cx of
    336 
    +      0 -> n1
    337 
    +      1 -> (n1 `shiftL` 64) .|. n2
    338 
    +      _ -> (n1 `shiftL` 128) .|. (n2 `shiftL` 64) .|. n3
    339 
    +
    340 
    +-- | Generates an integer with at most 192 bits set.
    341 
    +instance Arbitrary Integer where
    342 
    +  arbitrary = do
    343 
    +    nat <- arbitrary @Natural
    344 
    +    neg <- arbitrary @Bool
    345 
    +
    346 
    +    pure $
    347 
    +      if neg
    348 
    +      then negate (fromIntegral nat)
    349 
    +      else fromIntegral nat
    350 
    +
    351 
    +instance Arbitrary Char where
    352 
    +  arbitrary = do
    353 
    +    let high = fromIntegral (fromEnum (maxBound :: Char)) :: Word
    354 
    +    x <- arbitrary
    355 
    +    return (toEnum . fromIntegral $ x `mod` (high + 1))
    356 
    +
    357 
    +--------------------------------------------------------------------------------
    358 
    +-- Useful newtypes for different Arbitrary instances
    359 
    +
    360 
    +-- | Wrapper for non-zero values.
    361 
    +newtype NonZero a = NonZero { getNonZero :: a }
    362 
    +  deriving (Eq, Ord, Bounded, Show)
    363 
    +
    364 
    +-- | Generator that rejects zero values.
    365 
    +nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
    366 
    +nonZero = do
    367 
    +  x <- arbitrary
    368 
    +  if x == 0 then nonZero else pure (NonZero x)
    369 
    +
    370 
    +instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
    371 
    +  arbitrary = nonZero
    372 
    +
    373 
    +-- | Shift amount bounded to @[0, finiteBitSize - 1]@.
    374 
    +newtype BoundedShiftAmount a = BoundedShiftAmount { getBoundedShiftAmount :: Int }
    375 
    +  deriving (Eq, Ord, Show)
    376 
    +
    377 
    +instance FiniteBits a => Arbitrary (BoundedShiftAmount a) where
    378 
    +  arbitrary = do
    379 
    +    x <- arbitrary
    380 
    +    let w = finiteBitSize (undefined :: a)
    381 
    +    pure $ BoundedShiftAmount (abs x `mod` w)
    382 
    +
    383 
    +-- | @a `BoundedBy` n@ represents numbers with maximum absolute value @n@ (inclusive).
    384 
    +type BoundedBy :: Type -> Nat -> Type
    385 
    +newtype BoundedBy a n = BoundedBy { getBoundedBy :: a }
    386 
    +  deriving (Eq, Ord, Show)
    387 
    +
    388 
    +instance
    389 
    +  forall n a
    390 
    +  .  ( KnownNat n, Integral a, Arbitrary a )
    391 
    +  => Arbitrary ( a `BoundedBy` n ) where
    392 
    +  arbitrary = BoundedBy . (`rem` (n + 1)) <$> arbitrary
    393 
    +    where
    394 
    +      n :: a
    395 
    +      n = fromIntegral $ natVal @n Proxy

  • testsuite/tests/numeric/should_run/all.T
    ... ... @@ -3,8 +3,6 @@
    3 3 
     #	extra run flags
    4 4 
     #	expected process return value, if not zero
    5 5
    6 
    -import random
    7 
    -
    8 6 
     # some bugs only surface with -O, omitting optasm may cause them to
    9 7 
     # slip into releases! (e.g. #26711)
    10 8 
     setTestOpts(when(have_ncg(), extra_ways(['optasm'])))
    ... ... @@ -89,7 +87,14 @@ test('T20291', normal, compile_and_run, [''])
    89 87 
     test('T22282', normal, compile_and_run, [''])
    90 88 
     test('T22671', js_fragile(24259), compile_and_run, [''])
    91 89 
     # the high run timeout multiplier exists because of timeouts with the wasm backend
    92 
    -test('foundation', [run_timeout_multiplier(4), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt']), extra_run_opts(str(random.getrandbits(64)))], compile_and_run, ['-fno-break-points'])
    90 
    +test('foundation',
    91 
    +     [ mini_quickcheck
    92 
    +     , run_timeout_multiplier(4)
    93 
    +     , js_fragile(24259)
    94 
    +     , extra_ways(['optasm','ghci','ghci-opt'])
    95 
    +     ]
    96 
    +     , multimod_compile_and_run
    97 
    +     , ['foundation', '-fno-break-points'])
    93 98 
     test('T24066', normal, compile_and_run, [''])
    94 99 
     test('div01', normal, compile_and_run, [''])
    95 100 
     test('T24245', normal, compile_and_run, [''])

  • testsuite/tests/numeric/should_run/foundation.hs
    ... ... @@ -23,252 +23,20 @@ module Main
    23 23 
         ( main
    24 24 
         ) where
    25 25
    26 
    -import Data.Array.Byte
    27 
    -import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize)
    28 
    -import Data.Word
    26 
    +import Data.Bits       (Bits((.&.), bit))
    27 
    +import Data.Function   (on)
    29 28 
     import Data.Int
    30 
    -import GHC.Natural
    31 29 
     import Data.Typeable
    30 
    +import Data.Word
    32 31 
     import GHC.Int
    33 
    -import GHC.Word
    34 
    -import Data.Function
    32 
    +import GHC.Natural
    35 33 
     import GHC.Prim
    36 
    -import Control.Monad.Reader
    37 
    -import Data.List (intercalate)
    38 
    -import System.Environment (getArgs)
    39 
    -import Text.Read (readMaybe)
    40 
    -import Unsafe.Coerce
    41 34 
     import GHC.Types
    42 
    -import Data.Char
    43 
    -import System.Exit
    44 
    -
    35 
    +import GHC.Word
    45 36 
     import qualified GHC.Internal.PrimopWrappers as Wrapper
    46 
    -import qualified GHC.Internal.Prim as Primop
    47 
    -
    48 
    -newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
    49 
    -  deriving newtype (Functor, Applicative, Monad)
    50 
    -
    51 
    -class Arbitrary a where
    52 
    -  arbitrary :: Gen a
    53 
    -
    54 
    -class IsProperty p where
    55 
    -    property :: p -> Property
    37 
    +import qualified GHC.Internal.Prim           as Primop
    56 38
    57 
    -data PropertyCheck = PropertyBinaryOp Bool String String String
    58 
    -                   | PropertyAnd PropertyCheck PropertyCheck
    59 
    -
    60 
    -instance IsProperty PropertyCheck where
    61 
    -    property check = Prop $ pure (PropertyEOA check)
    62 
    -
    63 
    -data PropertyTestArg = PropertyEOA PropertyCheck
    64 
    -                     | PropertyArg String PropertyTestArg
    65 
    -
    66 
    -getCheck :: PropertyTestArg -> ([String], PropertyCheck)
    67 
    -getCheck (PropertyEOA pc) = ([], pc)
    68 
    -getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
    69 
    -
    70 
    -data Property = Prop { unProp :: Gen PropertyTestArg }
    71 
    -
    72 
    -instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
    73 
    -    property p = forAll arbitrary p
    74 
    -
    75 
    --- | Running a generator for a specific type under a property
    76 
    -forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
    77 
    -forAll generator tst = Prop $ do
    78 
    -    a <- generator
    79 
    -    augment a <$> unProp (property (tst a))
    80 
    -  where
    81 
    -    augment a arg = PropertyArg (show a) arg
    82 
    -
    83 
    --- | A property that check for equality of its 2 members.
    84 
    -propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
    85 
    -propertyCompare s f a b =
    86 
    -    let sa = show a
    87 
    -        sb = show b
    88 
    -     in PropertyBinaryOp (a `f` b) s sa sb
    89 
    -
    90 
    -(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
    91 
    -(===) = propertyCompare "==" (==)
    92 
    -infix 4 ===
    93 
    -
    94 
    -propertyAnd = PropertyAnd
    95 
    -
    96 
    -
    97 
    -data Test where
    98 
    -  Group :: String -> [Test] -> Test
    99 
    -  Property :: IsProperty prop => String -> prop -> Test
    100 
    -
    101 
    -
    102 
    -arbitraryInt64 :: Gen Int64
    103 
    -arbitraryInt64 = Gen $ do
    104 
    -    h <- ask
    105 
    -    W64# w <- liftIO (randomWord64 h)
    106 
    -    return (I64# (unsafeCoerce# w))
    107 
    -
    108 
    -integralDownsize :: (Integral a) => Int64 -> a
    109 
    -integralDownsize = fromIntegral
    110 
    -
    111 
    -wordDownsize :: (Integral a) => Word64 -> a
    112 
    -wordDownsize = fromIntegral
    113 
    -
    114 
    -arbitraryWord64 :: Gen Word64
    115 
    -arbitraryWord64 = Gen $ do
    116 
    -    h <- ask
    117 
    -    liftIO (randomWord64 h)
    118 
    -
    119 
    -nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
    120 
    -nonZero = do
    121 
    -  x <- arbitrary
    122 
    -  if x == 0 then nonZero else pure $ NonZero x
    123 
    -
    124 
    -newtype NonZero a = NonZero { getNonZero :: a }
    125 
    -  deriving (Eq,Ord,Bounded,Show)
    126 
    -
    127 
    -instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
    128 
    -  arbitrary = nonZero
    129 
    -
    130 
    --- | A newtype for shift amounts that are bounded by @wordSize - 1@
    131 
    -newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int}
    132 
    -  deriving (Eq, Ord, Show)
    133 
    -
    134 
    -instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where
    135 
    -  arbitrary = do
    136 
    -    x <- arbitrary
    137 
    -    let widthBits = finiteBitSize (undefined :: a)
    138 
    -    pure $ BoundedShiftAmount (abs x `mod` widthBits)
    139 
    -
    140 
    -instance Arbitrary Natural where
    141 
    -    arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
    142 
    -
    143 
    --- Bounded by Int64
    144 
    -instance Arbitrary Integer where
    145 
    -    arbitrary = fromIntegral <$> arbitraryInt64
    146 
    -
    147 
    -instance Arbitrary Int where
    148 
    -    arbitrary = int64ToInt <$> arbitraryInt64
    149 
    -instance Arbitrary Word where
    150 
    -    arbitrary = word64ToWord <$> arbitraryWord64
    151 
    -instance Arbitrary Word64 where
    152 
    -    arbitrary = arbitraryWord64
    153 
    -instance Arbitrary Word32 where
    154 
    -    arbitrary = wordDownsize <$> arbitraryWord64
    155 
    -instance Arbitrary Word16 where
    156 
    -    arbitrary = wordDownsize <$> arbitraryWord64
    157 
    -instance Arbitrary Word8 where
    158 
    -    arbitrary = wordDownsize <$> arbitraryWord64
    159 
    -instance Arbitrary Int64 where
    160 
    -    arbitrary = arbitraryInt64
    161 
    -instance Arbitrary Int32 where
    162 
    -    arbitrary = integralDownsize <$> arbitraryInt64
    163 
    -instance Arbitrary Int16 where
    164 
    -    arbitrary = integralDownsize <$> arbitraryInt64
    165 
    -instance Arbitrary Int8 where
    166 
    -    arbitrary = integralDownsize <$> arbitraryInt64
    167 
    -
    168 
    -instance Arbitrary Char where
    169 
    -    arbitrary = do
    170 
    -      let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
    171 
    -      (x::Word) <- arbitrary
    172 
    -      let x' = mod x high
    173 
    -      return (chr $ fromIntegral x')
    174 
    -
    175 
    -int64ToInt :: Int64 -> Int
    176 
    -int64ToInt (I64# i) = I# (int64ToInt# i)
    177 
    -
    178 
    -
    179 
    -word64ToWord :: Word64 -> Word
    180 
    -word64ToWord (W64# i) = W# (word64ToWord# i)
    181 
    -
    182 
    -
    183 
    -data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
    184 
    -
    185 
    -newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
    186 
    -
    187 
    -data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
    188 
    -
    189 
    -newLCGGen :: LCGParams -> IO LCGGen
    190 
    -newLCGGen LCGParams {seed = W64# seed#, ..} = do
    191 
    -  MutableByteArray mba# <- IO $ \s0 -> case newByteArray# 8# s0 of
    192 
    -    (# s1, mba# #) -> case writeWord64Array# mba# 0# seed# s1 of
    193 
    -      s2 -> (# s2, MutableByteArray mba# #)
    194 
    -  pure $ LCGGen $ IO $ \s0 -> case readWord64Array# mba# 0# s0 of
    195 
    -    (# s1, old_val# #) ->
    196 
    -      let old_val = W64# old_val#
    197 
    -          !new_val@(W64# new_val#) = (old_val * a + c) `mod` m
    198 
    -       in case writeWord64Array# mba# 0# new_val# s1 of
    199 
    -            s2 -> (# s2, new_val #)
    200 
    -
    201 
    -runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
    202 
    -  if res then return Success
    203 
    -         else do
    204 
    -          ctx <- context <$> ask
    205 
    -          let msg = "Failure: " ++ s1 ++ desc ++ s2
    206 
    -          putMsg msg
    207 
    -          return (Failure [msg : ctx])
    208 
    -runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPropertyCheck a2
    209 
    -
    210 
    -runProperty :: Property -> ReaderT RunS IO Result
    211 
    -runProperty (Prop p) = do
    212 
    -  let iterations = 1000 :: Int
    213 
    -  loop iterations iterations
    214 
    -  where
    215 
    -    loop iterations 0 = do
    216 
    -      putMsg ("Passed " ++ show iterations ++ " iterations")
    217 
    -      return Success
    218 
    -    loop iterations n = do
    219 
    -      h <- rg <$> ask
    220 
    -      p <- liftIO (runReaderT (runGen p) h)
    221 
    -      let (ss, pc) = getCheck p
    222 
    -      res <- runPropertyCheck pc
    223 
    -      case res of
    224 
    -        Success -> loop iterations (n-1)
    225 
    -        Failure msgs -> do
    226 
    -          let msg = ("With arguments " ++ intercalate ", " ss)
    227 
    -          putMsg msg
    228 
    -          return (Failure (map (msg :) msgs))
    229 
    -
    230 
    -data Result = Success | Failure [[String]]
    231 
    -
    232 
    -instance Semigroup Result where
    233 
    -  Success <> x = x
    234 
    -  x <> Success = x
    235 
    -  (Failure xs) <> (Failure ys) = Failure (xs ++ ys)
    236 
    -
    237 
    -instance Monoid Result where
    238 
    -  mempty = Success
    239 
    -
    240 
    -putMsg s = do
    241 
    -  n <- depth <$> ask
    242 
    -  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
    243 
    -
    244 
    -
    245 
    -nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
    246 
    -
    247 
    -runTestInternal :: Test -> ReaderT RunS IO Result
    248 
    -runTestInternal (Group name tests) = do
    249 
    -  let label = ("Group " ++ name)
    250 
    -  putMsg label
    251 
    -  nest label (mconcat <$> mapM runTestInternal tests)
    252 
    -runTestInternal (Property name p) = do
    253 
    -  let label = ("Running " ++ name)
    254 
    -  putMsg label
    255 
    -  nest label $ runProperty (property p)
    256 
    -
    257 
    -
    258 
    -runTests :: Word64 -> Test -> IO ()
    259 
    -runTests seed t = do
    260 
    -  -- These params are the same ones as glibc uses.
    261 
    -  h <- newLCGGen (LCGParams { seed, m = 2 ^ (31 :: Int), a = 1103515245, c = 12345 })
    262 
    -  res <- runReaderT  (runTestInternal t) (RunS 0 h [])
    263 
    -  case res of
    264 
    -    Success -> return ()
    265 
    -    Failure tests -> do
    266 
    -      putStrLn $ "Seed: " ++ show seed
    267 
    -      putStrLn $ "These tests failed:  \n" ++ intercalate "  \n" (map (showStack 0 . reverse) tests)
    268 
    -      exitFailure
    269 
    -
    270 
    -showStack _ [] = ""
    271 
    -showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
    39 
    +import MiniQuickCheck
    272 40
    273 41 
     -------------------------------------------------------------------------------
    274 42
    ... ... @@ -325,8 +93,11 @@ testOperatorPrecedence _ = Group "Precedence"
    325 93 
         , Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c)
    326 94 
         , Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c))
    327 95 
         , Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c)
    328 
    -    , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
    329 
    -    , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
    96 
    +
    97 
    +      -- Bound the exponent to avoid OOM errors e.g.
    98 
    +      --   GNU MP: Cannot allocate memory (size=4294938656)
    99 
    +    , Property "* and ^ (1)" $ \(a :: a) (BoundedBy b :: Natural `BoundedBy` 100) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
    100 
    +    , Property "* and ^ (2)" $ \(a :: a) (BoundedBy c :: Natural `BoundedBy` 100) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
    330 101 
         ]
    331 102
    332 103
    ... ... @@ -454,19 +225,8 @@ instance TestPrimop LowerBitsAreDefined where
    454 225 
     twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
    455 226 
     twoNonZero f x (NonZero y) = f x y
    456 227
    457 
    -getSeedFromArgs :: IO Word64
    458 
    -getSeedFromArgs = do
    459 
    -  args <- getArgs
    460 
    -  case args of
    461 
    -    [arg] -> case readMaybe arg of
    462 
    -      Just seed -> pure seed
    463 
    -      Nothing -> die $ "Invalid seed (expected Word64): " ++ show arg
    464 
    -    _ -> die "Usage: foundation <seed>"
    465 
    -
    466 228 
     main :: IO ()
    467 
    -main = do
    468 
    -  seed <- getSeedFromArgs
    469 
    -  runTests seed (Group "ALL" [testNumberRefs, testPrimops])
    229 
    +main = runTestsMain (Iterations 1000) (Group "ALL" [testNumberRefs, testPrimops])
    470 230
    471 231 
     -- Test an interpreted primop vs a compiled primop
    472 232 
     testPrimops = Group "primop"

  • testsuite/tests/simd/should_run/all.T
    ... ... @@ -80,7 +80,7 @@ test('simd002', [], compile_and_run, [''])
    80 80 
     test('simd003', [], compile_and_run, [''])
    81 81 
     test('simd004', [], compile_and_run, ['-O2'])
    82 82 
     test('simd005', [], compile_and_run, [''])
    83 
    -test('simd006', [], compile_and_run, [''])
    83 
    +test('simd006', [mini_quickcheck], multimod_compile_and_run, ['simd006', ''])
    84 84 
     test('simd007', [], compile_and_run, [''])
    85 85 
     test('simd008', [], compile_and_run, [''])
    86 86 
     test('simd009', [ req_th

  • testsuite/tests/simd/should_run/simd006.hs
    1 
    -{-# LANGUAGE MagicHash #-}
    2 
    -{-# LANGUAGE UnboxedTuples #-}
    3 
    -{-# LANGUAGE FlexibleContexts    #-}
    4 
    -{-# LANGUAGE OverloadedStrings   #-}
    5 
    -{-# LANGUAGE ScopedTypeVariables #-}
    6 
    -{-# LANGUAGE TypeFamilies        #-}
    7 
    -{-# LANGUAGE DerivingStrategies #-}
    1 
    +{-# LANGUAGE MagicHash           #-}
    2 
    +{-# LANGUAGE UnboxedTuples       #-}
    3 
    +{-# LANGUAGE DerivingStrategies  #-}
    8 4 
     {-# LANGUAGE GeneralisedNewtypeDeriving #-}
    9 
    -{-# LANGUAGE MagicHash #-}
    10 
    -{-# LANGUAGE RecordWildCards #-}
    5 
    +{-# LANGUAGE ScopedTypeVariables #-}
    11 6
    12 
    --- QuickCheck testing for SIMD operations
    7 
    +-- QuickCheck-like property tests for SIMD vector operations.
    13 8
    14 
    -module Main
    15 
    -    ( main
    16 
    -    ) where
    9 
    +module Main (main) where
    17 10
    18 
    -import Data.Word
    19 
    -import Data.Int
    20 
    -import GHC.Natural
    21 11 
     import Data.Coerce
    22 
    -import Data.Typeable
    23 
    -import Data.Proxy
    24 
    -import GHC.Int
    25 
    -import GHC.Word
    26 
    -import Data.Function
    12 
    +import Data.Word
    27 13 
     import GHC.Prim
    28 
    -import Control.Monad.Reader
    29 
    -import System.IO
    30 
    -import Foreign.Marshal.Alloc
    31 
    -import Foreign.Storable
    32 
    -import Foreign.Ptr
    33 
    -import Data.List (intercalate)
    34 
    -import Data.IORef
    35 
    -import Unsafe.Coerce
    36 14 
     import GHC.Exts
    37 15 
     import GHC.Float
    38 16 
       ( castFloatToWord32 , castWord32ToFloat
    39 17 
       , castDoubleToWord64, castWord64ToDouble
    40 18 
       )
    41 19
    20 
    +import MiniQuickCheck
    42 21
    22 
    +--------------------------------------------------------------------------------
    23 
    +-- Scalar wrappers that use bit-equality to test for equality.
    43 24
    44 
    -newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
    45 
    -  deriving newtype (Functor, Applicative, Monad)
    46 
    -
    47 
    -class Arbitrary a where
    48 
    -  arbitrary :: Gen a
    49 
    -
    50 
    -class IsProperty p where
    51 
    -    property :: p -> Property
    52 
    -
    53 
    -data PropertyCheck = PropertyBinaryOp Bool String String String
    54 
    -                   | PropertyAnd PropertyCheck PropertyCheck
    55 
    -
    56 
    -instance IsProperty PropertyCheck where
    57 
    -    property check = Prop $ pure (PropertyEOA check)
    58 
    -
    59 
    -data PropertyTestArg = PropertyEOA PropertyCheck
    60 
    -                     | PropertyArg String PropertyTestArg
    61 
    -
    62 
    -getCheck :: PropertyTestArg -> ([String], PropertyCheck)
    63 
    -getCheck (PropertyEOA pc) = ([], pc)
    64 
    -getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
    65 
    -
    66 
    -data Property = Prop { unProp :: Gen PropertyTestArg }
    67 
    -
    68 
    -instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
    69 
    -    property p = forAll arbitrary p
    70 
    -
    71 
    --- | Running a generator for a specific type under a property
    72 
    -forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
    73 
    -forAll generator tst = Prop $ do
    74 
    -    a <- generator
    75 
    -    augment a <$> unProp (property (tst a))
    76 
    -  where
    77 
    -    augment a arg = PropertyArg (show a) arg
    78 
    -
    79 
    --- | A property that check for equality of its 2 members.
    80 
    -propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
    81 
    -propertyCompare s f a b =
    82 
    -    let sa = show a
    83 
    -        sb = show b
    84 
    -     in PropertyBinaryOp (a `f` b) s sa sb
    85 
    -
    86 
    -(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
    87 
    -(===) = propertyCompare "==" (==)
    88 
    -infix 4 ===
    89 
    -
    90 
    -propertyAnd = PropertyAnd
    91 
    -
    92 
    -
    93 
    -data Test where
    94 
    -  Group :: String -> [Test] -> Test
    95 
    -  Property :: IsProperty prop => String -> prop -> Test
    96 
    -
    25 
    +newtype FloatNT = FloatNT Float
    26 
    +  deriving newtype (Show, Num)
    97 27
    98 
    -arbitraryInt64 :: Gen Int64
    99 
    -arbitraryInt64 = Gen $ do
    100 
    -    h <- ask
    101 
    -    W64# w <- liftIO (randomWord64 h)
    102 
    -    return (I64# (unsafeCoerce# w))
    28 
    +instance Eq FloatNT where
    29 
    +  FloatNT f1 == FloatNT f2 = castFloatToWord32 f1 == castFloatToWord32 f2
    103 30
    104 
    -integralDownsize :: (Integral a) => Int64 -> a
    105 
    -integralDownsize = fromIntegral
    31 
    +instance Arbitrary FloatNT where
    32 
    +  arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
    106 33
    107 
    -wordDownsize :: (Integral a) => Word64 -> a
    108 
    -wordDownsize = fromIntegral
    34 
    +newtype DoubleNT = DoubleNT Double
    35 
    +  deriving newtype (Show, Num)
    109 36
    110 
    -arbitraryWord64 :: Gen Word64
    111 
    -arbitraryWord64 = Gen $ do
    112 
    -    h <- ask
    113 
    -    liftIO (randomWord64 h)
    37 
    +instance Eq DoubleNT where
    38 
    +  DoubleNT d1 == DoubleNT d2 = castDoubleToWord64 d1 == castDoubleToWord64 d2
    114 39
    40 
    +instance Arbitrary DoubleNT where
    41 
    +  arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
    115 42
    116 
    -instance Arbitrary Word64 where
    117 
    -    arbitrary = arbitraryWord64
    118 
    -instance Arbitrary Word32 where
    119 
    -    arbitrary = wordDownsize <$> arbitraryWord64
    43 
    +--------------------------------------------------------------------------------
    44 
    +-- Min/max for the types under test
    120 45
    121 46 
     class HasMinMax a where
    122 47 
       mini, maxi :: a -> a -> a
    48 
    +
    123 49 
     instance HasMinMax FloatNT where
    124 50 
       mini (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (minFloat# f1 f2))
    125 51 
       maxi (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (maxFloat# f1 f2))
    52 
    +
    126 53 
     instance HasMinMax DoubleNT where
    127 54 
       mini (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (minDouble# d1 d2))
    128 55 
       maxi (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (maxDouble# d1 d2))
    129 56
    130 
    -newtype FloatNT = FloatNT Float
    131 
    -  deriving newtype (Show, Num)
    132 
    -instance Eq FloatNT where
    133 
    -  FloatNT f1 == FloatNT f2 =
    134 
    -    castFloatToWord32 f1 == castFloatToWord32 f2
    135 
    -instance Arbitrary FloatNT where
    136 
    -  arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
    137 
    -newtype DoubleNT = DoubleNT Double
    138 
    -  deriving newtype (Show, Num)
    139 
    -instance Eq DoubleNT where
    140 
    -  DoubleNT d1 == DoubleNT d2 =
    141 
    -    castDoubleToWord64 d1 == castDoubleToWord64 d2
    142 
    -instance Arbitrary DoubleNT where
    143 
    -  arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
    144 
    -
    57 
    +--------------------------------------------------------------------------------
    58 
    +-- SIMD vector types
    145 59
    146 60 
     data FloatX4 = FX4# FloatX4#
    61 
    +
    147 62 
     instance Show FloatX4 where
    148 
    -  show (FX4# f) = case (unpackFloatX4# f) of
    149 
    -    (# a, b, c, d #) -> show ((F# a), (F# b), (F# c), (F# d))
    63 
    +  show (FX4# f) = case unpackFloatX4# f of
    64 
    +    (# a, b, c, d #) -> show (F# a, F# b, F# c, F# d)
    65 
    +
    150 66 
     instance Eq FloatX4 where
    151 
    -  (FX4# a) == (FX4# b)
    152 
    -    = case (unpackFloatX4# a) of
    67 
    +  FX4# a == FX4# b
    68 
    +    = case unpackFloatX4# a of
    153 69 
             (# a1, a2, a3, a4 #) ->
    154 
    -          case (unpackFloatX4# b) of
    155 
    -            (# b1, b2, b3, b4 #) -> FloatNT (F# a1) == FloatNT (F# b1) &&
    156 
    -                                    FloatNT (F# a2) == FloatNT (F# b2) &&
    157 
    -                                    FloatNT (F# a3) == FloatNT (F# b3) &&
    158 
    -                                    FloatNT (F# a4) == FloatNT (F# b4)
    70 
    +          case unpackFloatX4# b of
    71 
    +            (# b1, b2, b3, b4 #) ->
    72 
    +              FloatNT (F# a1) == FloatNT (F# b1) &&
    73 
    +              FloatNT (F# a2) == FloatNT (F# b2) &&
    74 
    +              FloatNT (F# a3) == FloatNT (F# b3) &&
    75 
    +              FloatNT (F# a4) == FloatNT (F# b4)
    76 
    +
    159 77 
     instance Arbitrary FloatX4 where
    160 78 
       arbitrary = do
    161 79 
         FloatNT (F# f1) <- arbitrary
    ... ... @@ -163,52 +81,59 @@ instance Arbitrary FloatX4 where
    163 81 
         FloatNT (F# f3) <- arbitrary
    164 82 
         FloatNT (F# f4) <- arbitrary
    165 83 
         return $ FX4# (packFloatX4# (# f1, f2, f3, f4 #))
    84 
    +
    166 85 
     instance Num FloatX4 where
    167 
    -  FX4# x + FX4# y =
    168 
    -    FX4# ( x `plusFloatX4#` y )
    169 
    -  FX4# x - FX4# y =
    170 
    -    FX4# ( x `minusFloatX4#` y )
    171 
    -  negate ( FX4# x ) = FX4# ( negateFloatX4# x )
    172 
    -  FX4# x * FX4# y =
    173 
    -    FX4# ( x `timesFloatX4#` y )
    174 
    -  abs = error "no"
    175 
    -  signum = error "no"
    176 
    -  fromInteger = error "no"
    86 
    +  FX4# x + FX4# y = FX4# (x `plusFloatX4#`  y)
    87 
    +  FX4# x - FX4# y = FX4# (x `minusFloatX4#` y)
    88 
    +  negate (FX4# x) = FX4# (negateFloatX4# x)
    89 
    +  FX4# x * FX4# y = FX4# (x `timesFloatX4#` y)
    90 
    +  abs    = error "FloatX4: no abs"
    91 
    +  signum = error "FloatX4: no signum"
    92 
    +  fromInteger = error "FloatX4: no fromInteger"
    93 
    +
    177 94 
     instance HasMinMax FloatX4 where
    178 95 
       mini (FX4# a) (FX4# b) = FX4# (minFloatX4# a b)
    179 96 
       maxi (FX4# a) (FX4# b) = FX4# (maxFloatX4# a b)
    180 97
    98 
    +--------------------------------------------------------------------------------
    99 
    +
    181 100 
     data DoubleX2 = DX2# DoubleX2#
    101 
    +
    182 102 
     instance Show DoubleX2 where
    183 
    -  show (DX2# d) = case (unpackDoubleX2# d) of
    184 
    -    (# a, b #) -> show ((D# a), (D# b))
    103 
    +  show (DX2# d) = case unpackDoubleX2# d of
    104 
    +    (# a, b #) -> show (D# a, D# b)
    105 
    +
    185 106 
     instance Eq DoubleX2 where
    186 
    -  (DX2# a) == (DX2# b)
    187 
    -    = case (unpackDoubleX2# a) of
    107 
    +  DX2# a == DX2# b
    108 
    +    = case unpackDoubleX2# a of
    188 109 
             (# a1, a2 #) ->
    189 
    -          case (unpackDoubleX2# b) of
    190 
    -            (# b1, b2 #) -> DoubleNT (D# a1) == DoubleNT (D# b1) &&
    191 
    -                            DoubleNT (D# a2) == DoubleNT (D# b2)
    110 
    +          case unpackDoubleX2# b of
    111 
    +            (# b1, b2 #) ->
    112 
    +              DoubleNT (D# a1) == DoubleNT (D# b1) &&
    113 
    +              DoubleNT (D# a2) == DoubleNT (D# b2)
    114 
    +
    192 115 
     instance Arbitrary DoubleX2 where
    193 116 
       arbitrary = do
    194 117 
         DoubleNT (D# d1) <- arbitrary
    195 118 
         DoubleNT (D# d2) <- arbitrary
    196 119 
         return $ DX2# (packDoubleX2# (# d1, d2 #))
    120 
    +
    197 121 
     instance Num DoubleX2 where
    198 
    -  DX2# x + DX2# y =
    199 
    -    DX2# ( x `plusDoubleX2#` y )
    200 
    -  DX2# x - DX2# y =
    201 
    -    DX2# ( x `minusDoubleX2#` y )
    202 
    -  negate ( DX2# x ) = DX2# ( negateDoubleX2# x )
    203 
    -  DX2# x * DX2# y =
    204 
    -    DX2# ( x `timesDoubleX2#` y )
    205 
    -  abs = error "no"
    206 
    -  signum = error "no"
    207 
    -  fromInteger = error "no"
    122 
    +  DX2# x + DX2# y = DX2# (x `plusDoubleX2#`  y)
    123 
    +  DX2# x - DX2# y = DX2# (x `minusDoubleX2#` y)
    124 
    +  negate (DX2# x) = DX2# (negateDoubleX2# x)
    125 
    +  DX2# x * DX2# y = DX2# (x `timesDoubleX2#` y)
    126 
    +  abs    = error "DoubleX2: no abs"
    127 
    +  signum = error "DoubleX2: no signum"
    128 
    +  fromInteger = error "DoubleX2: no fromInteger"
    129 
    +
    208 130 
     instance HasMinMax DoubleX2 where
    209 131 
       mini (DX2# a) (DX2# b) = DX2# (minDoubleX2# a b)
    210 132 
       maxi (DX2# a) (DX2# b) = DX2# (maxDoubleX2# a b)
    211 133
    134 
    +--------------------------------------------------------------------------------
    135 
    +-- Expression language for generating random expressions over vector types.
    136 
    +
    212 137 
     data Expr a where
    213 138 
       Lit :: a -> Expr a
    214 139 
       Add :: Expr a -> Expr a -> Expr a
    ... ... @@ -218,11 +143,12 @@ data Expr a where
    218 143 
       Min :: Expr a -> Expr a -> Expr a
    219 144 
       Max :: Expr a -> Expr a -> Expr a
    220 145 
       deriving (Show, Eq)
    146 
    +
    221 147 
     fmapExpr :: (a -> b) -> Expr a -> Expr b
    222 
    -fmapExpr f (Lit a) = Lit (f a)
    148 
    +fmapExpr f (Lit a)   = Lit (f a)
    223 149 
     fmapExpr f (Add a b) = Add (fmapExpr f a) (fmapExpr f b)
    224 150 
     fmapExpr f (Sub a b) = Sub (fmapExpr f a) (fmapExpr f b)
    225 
    -fmapExpr f (Neg a) = Neg (fmapExpr f a)
    151 
    +fmapExpr f (Neg a)   = Neg (fmapExpr f a)
    226 152 
     fmapExpr f (Mul a b) = Mul (fmapExpr f a) (fmapExpr f b)
    227 153 
     fmapExpr f (Min a b) = Min (fmapExpr f a) (fmapExpr f b)
    228 154 
     fmapExpr f (Max a b) = Max (fmapExpr f a) (fmapExpr f b)
    ... ... @@ -240,75 +166,16 @@ instance Arbitrary a => Arbitrary (Expr a) where
    240 166 
           _ -> Lit <$> arbitrary
    241 167
    242 168 
     eval :: (Num a, HasMinMax a) => Expr a -> a
    243 
    -eval (Lit a) = a
    169 
    +eval (Lit a)   = a
    244 170 
     eval (Add a b) = eval a + eval b
    245 171 
     eval (Sub a b) = eval a - eval b
    246 
    -eval (Neg a) = negate (eval a)
    172 
    +eval (Neg a)   = negate (eval a)
    247 173 
     eval (Mul a b) = eval a * eval b
    248 174 
     eval (Min a b) = mini (eval a) (eval b)
    249 175 
     eval (Max a b) = maxi (eval a) (eval b)
    250 176
    251 
    -int64ToInt :: Int64 -> Int
    252 
    -int64ToInt (I64# i) = I# (int64ToInt# i)
    253 
    -
    254 
    -
    255 
    -word64ToWord :: Word64 -> Word
    256 
    -word64ToWord (W64# i) = W# (word64ToWord# i)
    257 
    -
    258 
    -
    259 
    -data RunS = RunS { depth :: Int, rg :: LCGGen  }
    260 
    -
    261 
    -newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
    262 
    -
    263 
    -data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
    264 
    -
    265 
    -newLCGGen :: LCGParams -> IO LCGGen
    266 
    -newLCGGen LCGParams{..}  = do
    267 
    -  var <- newIORef (fromIntegral seed)
    268 
    -  return $ LCGGen $ do
    269 
    -    atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val))
    270 
    -
    271 
    -
    272 
    -runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
    273 
    -  if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
    274 
    -runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
    275 
    -
    276 
    -runProperty :: Property -> ReaderT RunS IO ()
    277 
    -runProperty (Prop p) = do
    278 
    -  let iterations = 100
    279 
    -  loop iterations iterations
    280 
    -  where
    281 
    -    loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
    282 
    -    loop iterations n = do
    283 
    -      h <- rg <$> ask
    284 
    -      p <- liftIO (runReaderT (runGen p) h)
    285 
    -      let (ss, pc) = getCheck p
    286 
    -      res <- runPropertyCheck pc
    287 
    -      if res then loop iterations (n-1)
    288 
    -             else putMsg ("With arguments " ++ intercalate ", " ss)
    289 
    -
    290 
    -putMsg s = do
    291 
    -  n <- depth <$> ask
    292 
    -  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
    293 
    -
    294 
    -nest = local (\s -> s { depth = depth s + 1 })
    295 
    -
    296 
    -runTestInternal :: Test -> ReaderT RunS IO ()
    297 
    -runTestInternal (Group name tests) = do
    298 
    -  putMsg ("Group " ++ name)
    299 
    -  nest (mapM_ runTestInternal tests)
    300 
    -runTestInternal (Property name p) = do
    301 
    -  putMsg ("Running " ++ name)
    302 
    -  nest $ runProperty (property p)
    303 
    -
    304 
    -
    305 
    -runTests :: Test -> IO ()
    306 
    -runTests t = do
    307 
    -  -- These params are the same ones as glibc uses.
    308 
    -  h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
    309 
    -  runReaderT  (runTestInternal t) (RunS 0 h)
    310 
    -
    311 
    --------------------------------------------------------------------------------
    177 
    +--------------------------------------------------------------------------------
    178 
    +-- Test groups
    312 179
    313 180 
     testFloatX4 :: Test
    314 181 
     testFloatX4 = Group "FloatX4"
    ... ... @@ -324,15 +191,12 @@ testFloatX4 = Group "FloatX4"
    324 191 
         unpack :: FloatX4 -> ( FloatNT, FloatNT, FloatNT, FloatNT )
    325 192 
         unpack (FX4# f) = case unpackFloatX4# f of
    326 193 
           (# f1, f2, f3, f4 #) -> coerce ( F# f1, F# f2, F# f3, F# f4 )
    194 
    +
    327 195 
         get1, get2, get3, get4 :: FloatX4 -> FloatNT
    328 
    -    get1 (FX4# f) = case unpackFloatX4# f of
    329 
    -      (# f1, _, _, _ #) -> FloatNT (F# f1)
    330 
    -    get2 (FX4# f) = case unpackFloatX4# f of
    331 
    -      (# _, f2, _, _ #) -> FloatNT (F# f2)
    332 
    -    get3 (FX4# f) = case unpackFloatX4# f of
    333 
    -      (# _, _, f3, _ #) -> FloatNT (F# f3)
    334 
    -    get4 (FX4# f) = case unpackFloatX4# f of
    335 
    -      (# _, _, _, f4 #) -> FloatNT (F# f4)
    196 
    +    get1 (FX4# f) = case unpackFloatX4# f of (# f1,  _,  _,  _ #) -> FloatNT (F# f1)
    197 
    +    get2 (FX4# f) = case unpackFloatX4# f of (#  _, f2,  _,  _ #) -> FloatNT (F# f2)
    198 
    +    get3 (FX4# f) = case unpackFloatX4# f of (#  _,  _, f3,  _ #) -> FloatNT (F# f3)
    199 
    +    get4 (FX4# f) = case unpackFloatX4# f of (#  _,  _,  _, f4 #) -> FloatNT (F# f4)
    336 200
    337 201 
     testDoubleX2 :: Test
    338 202 
     testDoubleX2 = Group "DoubleX2"
    ... ... @@ -346,16 +210,15 @@ testDoubleX2 = Group "DoubleX2"
    346 210 
         unpack :: DoubleX2 -> ( DoubleNT, DoubleNT )
    347 211 
         unpack (DX2# d) = case unpackDoubleX2# d of
    348 212 
           (# d1, d2 #) -> coerce ( D# d1, D# d2 )
    213 
    +
    349 214 
         get1, get2 :: DoubleX2 -> DoubleNT
    350 215 
         get1 (DX2# d) = case unpackDoubleX2# d of
    351 
    -      (# d1, _ #) -> DoubleNT (D# d1)
    216 
    +      (# d1,  _ #) -> DoubleNT (D# d1)
    352 217 
         get2 (DX2# d) = case unpackDoubleX2# d of
    353 
    -      (# _, d2 #) -> DoubleNT (D# d2)
    218 
    +      (#  _, d2 #) -> DoubleNT (D# d2)
    354 219
    355 220 
     testSIMD :: Test
    356 
    -testSIMD = Group "ALL"
    357 
    -    [ testFloatX4
    358 
    -    , testDoubleX2
    359 
    -    ]
    221 
    +testSIMD = Group "ALL" [testFloatX4, testDoubleX2]
    360 222
    361 
    -main = runTests testSIMD
    223 
    +main :: IO ()
    224 
    +main = runTestsMain (Iterations 100) testSIMD

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help