GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

87db83e2

by Cheng Shao at 2026-04-24T14:37:21-04:00

ci: bump freebsd boot ghc to 9.10.3

This commit bumps freebsd boot ghc to 9.10.3 to align with other
platforms and prevent outdated boot libs in boot ghc to block the
freebsd job.

17e3a0b7

by Cheng Shao at 2026-04-24T14:37:21-04:00

compiler: improve Binary instance of Array

This patch improves the `Binary` instance of `Array`:

- We no longer allocate intermediate lists. When serializing an
  `Array`, we iterate over the elements directly; when deserializing
  it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
  not needed.

Closes #27109.

2d30f7d3

by sheaf at 2026-04-24T14:38:23-04:00

Vendor mini-QuickCheck for testsuite

This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).

On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.

Fixes #25990 and #25969.

a83c69ee

by sheaf at 2026-04-24T15:11:17-04:00

Hadrian: add --keep-response-files

This commit adds a Hadrian flag that allows response files to be
retained. This is useful for debugging a failing Hadrian command line.

3faedf50

by sheaf at 2026-04-24T15:11:22-04:00

hadrian/build-cabal.bat: fix build on Windows

Commit 8cb99552f6 introduced a warning for a missing package index.
However, the logic was faulty on Windows: the piping was broken, and
"remote-repo-cache:" was being interpreted as a (malformed) drive letter,
leading to the error:

  The filename, directory name, or volume label syntax is incorrect.

This commit fixes that by using a temporary file instead of piping.

16 changed files:

.gitlab/generate-ci/gen_ci.hs
.gitlab/jobs.yaml
+ changelog.d/binary-array-no-list
+ changelog.d/hadrian-response-files.md
compiler/GHC/Utils/Binary.hs
hadrian/build-cabal.bat
hadrian/src/Builder.hs
hadrian/src/CommandLine.hs
hadrian/src/Hadrian/Builder/Ar.hs
hadrian/src/Hadrian/Utilities.hs
testsuite/driver/testlib.py
+ testsuite/tests/MiniQuickCheck.hs
testsuite/tests/numeric/should_run/all.T
testsuite/tests/numeric/should_run/foundation.hs
testsuite/tests/simd/should_run/all.T
testsuite/tests/simd/should_run/simd006.hs

Changes:

.gitlab/generate-ci/gen_ci.hs

@@ -445,7 +445,7 @@ opsysVariables _ FreeBSD14 = mconcat
      -- Prefer to use the system's clang-based toolchain and not gcc
    , "CC" =: "cc"
    , "CXX" =: "c++"
 -  , "FETCH_GHC_VERSION" =: "9.10.1"
 +  , "FETCH_GHC_VERSION" =: "9.10.3"
    , "CABAL_INSTALL_VERSION" =: "3.14.2.0"
+   ]
  opsysVariables arch (Linux distro) = distroVariables arch distro

.gitlab/jobs.yaml

@@ -1721,7 +1721,7 @@
        "CC": "cc",
        "CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
        "CXX": "c++",
 -      "FETCH_GHC_VERSION": "9.10.1",
 +      "FETCH_GHC_VERSION": "9.10.3",
        "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
        "RUNTEST_ARGS": "",
        "TEST_ENV": "x86_64-freebsd14-validate",
@@ -4543,7 +4543,7 @@
        "CC": "cc",
        "CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
        "CXX": "c++",
 -      "FETCH_GHC_VERSION": "9.10.1",
 +      "FETCH_GHC_VERSION": "9.10.3",
        "IGNORE_PERF_FAILURES": "all",
        "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
        "RUNTEST_ARGS": "",
@@ -5643,7 +5643,7 @@
        "CC": "cc",
        "CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
        "CXX": "c++",
 -      "FETCH_GHC_VERSION": "9.10.1",
 +      "FETCH_GHC_VERSION": "9.10.3",
        "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
        "RUNTEST_ARGS": "",
        "TEST_ENV": "x86_64-freebsd14-validate"

changelog.d/binary-array-no-list

 +section: compiler
 +synopsis: Reduce allocations when (de)serialising `Array` in the `ghc` library.
 +issues: #27109
 +mrs: !15805
++
 +description: {
 +  The `ghc` library's `Binary` instance for `Array` was changed to
 +  avoid allocating an intermediate list and to omit a redundant length
 +  field during (de)serialisation.
++
 +  This should only affect the `ghc` library's (de)serialisation code paths,
 +  primarily when parsing HIE files and bytecode objects.
 +}

changelog.d/hadrian-response-files.md

 +section: packaging
 +synopsis: Add a flag to tell Hadrian to keep response files
 +issues: #27184
 +mrs: !15906
 +description:
 +  Hadrian can now be instructed to keep response files with the new
 +  --keep-response-files command line flag. This is helpful when debugging a
 +  build failure, as it allows re-running the failing command line invocation
 +  without an error due to a missing response file.

compiler/GHC/Utils/Binary.hs

@@ -142,6 +142,8 @@ import Control.DeepSeq
  import Control.Monad            ( when, (<$!>), unless, forM_, void )
  import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
  import Data.Array
 +import Data.Array.Base (unsafeFreezeIOArray)
 +import Data.Array.IArray (traverseArray_)
  import Data.Array.IO
  import Data.Array.Unsafe
  import qualified Data.Binary as Binary
@@ -970,11 +972,12 @@ instance Binary a => Binary (NonEmpty a) where
  instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
      put_ bh arr = do
          put_ bh $ bounds arr
 -        put_ bh $ elems arr
 +        traverseArray_ (put_ bh) arr
++
      get bh = do
 -        bounds <- get bh
 -        xs <- get bh
 -        return $ listArray bounds xs
 +        (l, u) <- get bh
 +        marr <- newGenArray (l, u) $ \_ -> get bh
 +        unsafeFreezeIOArray marr
  instance Binary a => Binary (SmallArray a) where
      put_ bh sa = do

hadrian/build-cabal.bat

@@ -39,7 +39,9 @@ if %CABMAJOR% lss 3 (
      exit /B 2
+ )
 -for /F "tokens=*" %%a in ('"%CABAL%" --with-compiler=%GHC% path --output-format=key-value 2^>NUL ^| findstr /B "remote-repo-cache:"') do set REMOTE_REPO_CACHE=%%a
 +"%CABAL%" --with-compiler=%GHC% path --output-format=key-value > "%TEMP%\ghc_cabal_path.txt" 2>NUL
 +for /F "tokens=*" %%a in ('findstr /B "remote-repo-cache:" "%TEMP%\ghc_cabal_path.txt"') do set REMOTE_REPO_CACHE=%%a
 +del "%TEMP%\ghc_cabal_path.txt" 2>NUL
  set REMOTE_REPO_CACHE=%REMOTE_REPO_CACHE:remote-repo-cache: =%
  if not exist "%REMOTE_REPO_CACHE%\hackage.haskell.org" (
      echo Please run 'cabal update' first

hadrian/src/Builder.hs

@@ -389,15 +389,13 @@ runHaddock :: FilePath    -- ^ path to @haddock@
        -> [String]
        -> [FilePath]  -- ^ input file paths
        -> Action ()
 -runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
 +runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do
      writeFile' tmp $ escapeArgs fileInputs
      cmd [haddockPath] flagArgs ('@' : tmp)
  runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
 -runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
+-
 +runGhcWithResponse ghcPath flagArgs fileInputs = withResponseFile $ \tmp -> do
      writeFile' tmp $ escapeArgs fileInputs
+-
      -- We can't put the flags in a response file, because some flags
      -- require empty arguments (such as the -dep-suffix flag), but
      -- that isn't supported yet due to #26560.

hadrian/src/CommandLine.hs

@@ -3,7 +3,8 @@ module CommandLine (
      lookupBignum,
      cmdBignum, cmdBignumCheck, cmdProgressInfo, cmdCompleteSetting,
      cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
 -    cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
 +    cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
 +    cmdKeepResponseFiles
      ) where
  import Data.Either
@@ -11,7 +12,7 @@ import qualified Data.HashMap.Strict as Map
  import Data.List.Extra
  import Development.Shake hiding (Normal)
  import Flavour (DocTargets, DocTarget(..))
 -import Hadrian.Utilities hiding (buildRoot)
 +import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
  import Settings.Parser
  import System.Console.GetOpt
  import System.Environment
@@ -37,6 +38,7 @@ data CommandLineArgs = CommandLineArgs
      , testArgs       :: TestArgs
      , docsArgs       :: DocArgs
      , docTargets     :: DocTargets
 +    , keepResponseFiles :: Bool
      , prefix           :: Maybe FilePath
      , changelogVersion :: Maybe String
      , completeStg      :: Maybe String }
@@ -58,6 +60,7 @@ defaultCommandLineArgs = CommandLineArgs
      , testArgs       = defaultTestArgs
      , docsArgs       = defaultDocArgs
      , docTargets     = Set.fromList [minBound..maxBound]
 +    , keepResponseFiles    = False
      , prefix           = Nothing
      , changelogVersion = Nothing
      , completeStg      = Nothing }
@@ -143,6 +146,9 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
  readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
  readSkipDepends = Right $ \flags -> flags { skipDepends = True }
 +readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
 +readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
++
  readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
  readUnitIdHash = Right $ \flags ->
    trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -301,6 +307,8 @@ optDescrs =
        "Progress info style (None, Brief, Normal or Unicorn)."
      , Option [] ["docs"] (ReqArg readDocsArg "TARGET")
        "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
 +    , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
 +      "Keep response files created during the build (for debugging)."
      , Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
        "Keep all the files generated when running the testsuite."
      , Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -377,11 +385,12 @@ cmdLineArgsMap = do
          else return []
      let allSettings = cliSettings ++ fileSettings
 -    return $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
 -           $ insertExtra (buildRoot      args) -- Accessed by Hadrian.Utilities
 -           $ insertExtra (testArgs       args) -- Accessed by Settings.Builders.RunTest
 -           $ insertExtra (docsArgs       args) -- Accessed by Rules.Documentation
 -           $ insertExtra allSettings           -- Accessed by Settings
 +    return $ insertExtra (progressInfo               args) -- Accessed by Hadrian.Utilities
 +           $ insertExtra (buildRoot                  args) -- Accessed by Hadrian.Utilities
 +           $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
 +           $ insertExtra (testArgs                   args) -- Accessed by Settings.Builders.RunTest
 +           $ insertExtra (docsArgs                   args) -- Accessed by Rules.Documentation
 +           $ insertExtra allSettings                       -- Accessed by Settings
             $ insertExtra args Map.empty
  cmdLineArgs :: Action CommandLineArgs
@@ -423,6 +432,9 @@ cmdBignum = bignum <$> cmdLineArgs
  cmdBignumCheck :: Action Bool
  cmdBignumCheck = bignumCheck <$> cmdLineArgs
 +cmdKeepResponseFiles :: Action Bool
 +cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
++
  cmdProgressInfo :: Action ProgressInfo
  cmdProgressInfo = progressInfo <$> cmdLineArgs

hadrian/src/Hadrian/Builder/Ar.hs

@@ -40,7 +40,7 @@ runAr :: FilePath    -- ^ path to @ar@
        -> [FilePath]  -- ^ input file paths
        -> [CmdOption] -- ^ Additional options
        -> Action ()
 -runAr arPath flagArgs fileArgs buildOptions = withTempFile $ \tmp -> do
 +runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
      writeFile' tmp $ unwords fileArgs
      cmd [arPath] flagArgs ('@' : tmp) buildOptions

hadrian/src/Hadrian/Utilities.hs

@@ -14,6 +14,7 @@ module Hadrian.Utilities (
      -- * Paths
      BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
 +    KeepResponseFiles (..), keepResponseFiles, withResponseFile,
      -- * File system operations
      copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -48,6 +49,7 @@ import Development.Shake hiding (Normal)
  import Development.Shake.Classes
  import Development.Shake.FilePath
  import System.Environment (lookupEnv)
 +import System.IO (hClose, openTempFile)
  import qualified Data.ByteString        as BS
  import qualified Control.Exception.Base as IO
@@ -317,6 +319,29 @@ buildRootRules = do
  isGeneratedSource :: FilePath -> Action Bool
  isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
 +newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
++
 +-- | Whether to retain response files after the build action that created them
 +-- completes. Mainly useful for debugging.
 +keepResponseFiles :: Action Bool
 +keepResponseFiles = do
 +    KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
 +    return keep
++
 +-- | Run an action with a response file path.
 +--
 +-- With @--keep-response-files@, the file is left on disk.
 +withResponseFile :: (FilePath -> Action a) -> Action a
 +withResponseFile action = do
 +    keep <- keepResponseFiles
 +    if keep
 +        then do
 +            (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
 +            liftIO $ hClose h
 +            putInfo $ "Keeping response file: " ++ tmp
 +            action tmp
 +        else withTempFile action
++
  -- | Link a file tracking the link target. Create the target directory if
  -- missing.
  createFileLink :: FilePath -> FilePath -> Action ()

testsuite/driver/testlib.py

@@ -13,6 +13,7 @@ import time
  import datetime
  import copy
  import glob
 +import random
  import sys
  from math import ceil, trunc, floor, log
  from pathlib import Path, PurePath
@@ -648,6 +649,11 @@ def extra_files(files):
  def _extra_files(name, opts, files):
      opts.extra_files.extend(files)
 +def mini_quickcheck(name, opts):
 +    miniqc = os.path.relpath(config.top / 'tests' / 'MiniQuickCheck.hs', opts.srcdir)
 +    opts.extra_files.extend([miniqc])
 +    opts.extra_run_opts += ' ' + str(random.getrandbits(64))
++
  # Record the size of a specific file
  def collect_size ( deviation, path ):
      return collect_size_func(deviation, lambda: path)

testsuite/tests/MiniQuickCheck.hs

 +{-# LANGUAGE DataKinds                  #-}
 +{-# LANGUAGE DerivingStrategies         #-}
 +{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 +{-# LANGUAGE RecordWildCards            #-}
 +{-# LANGUAGE TypeFamilies               #-}
++
 +-- | A minimal QuickCheck-like property testing framework for use in the GHC
 +-- test suite.
 +--
 +-- We vendor this package to avoid depending on the real QuickCheck package,
 +-- as the latter (or one of its dependencies) may not build with the GHC version
 +-- being tested.
 +module MiniQuickCheck
 +  ( -- * QuickCheck generator
 +    Gen(..)
++
 +    -- * QuickCheck typeclasses
 +  , Arbitrary(..)
 +  , IsProperty(..)
++
 +    -- * QuickCheck properties
 +  , PropertyCheck(..)
 +  , PropertyTestArg(..)
 +  , Property(..)
 +  , forAll
 +  , (===)
 +  , propertyCompare
 +  , propertyAnd
 +  , getCheck
++
 +    -- * QuickCheck test tree
 +  , Test(..)
++
 +    -- * Running QuickCheck tests
 +  , Result(..)
 +  , Iterations(..)
 +  , runTestsMain
 +  , runTests
 +  , runTestInternal
++
 +    -- * QuickCheck primitive generators
 +  , arbitraryInt64
 +  , arbitraryWord64
 +  , integralDownsize
 +  , wordDownsize
++
 +    -- * QuickCheck newtypes
 +  , NonZero(..)
 +  , nonZero
 +  , BoundedShiftAmount(..)
 +  , BoundedBy(..)
 +  ) where
++
 +-- base
 +import Control.Monad.IO.Class
 +  ( liftIO )
 +import Data.Bits
 +  ( (.|.), shiftL, shiftR
 +  , FiniteBits, finiteBitSize
 +  )
 +import Data.Int
 +  ( Int8, Int16, Int32, Int64 )
 +import Data.IORef
 +  ( newIORef, atomicModifyIORef' )
 +import Data.Kind
 +  ( Type )
 +import Data.List
 +  ( intercalate )
 +import Data.Proxy
 +  ( Proxy(..) )
 +import Data.Word
 +  ( Word8, Word16, Word32, Word64 )
 +import GHC.TypeNats
 +  ( Nat, KnownNat, natVal )
 +import Numeric.Natural
 +  ( Natural )
 +import System.Environment
 +  ( getArgs )
 +import System.Exit
 +  ( die, exitFailure )
 +import Text.Read
 +  ( readMaybe )
++
 +-- transformers
 +import Control.Monad.Trans.Reader
 +  ( ReaderT, runReaderT, ask, local )
 +import Control.Monad.Trans.State.Strict
 +  ( State, state, runState )
++
 +--------------------------------------------------------------------------------
 +-- Core framework
++
 +newtype Gen a = Gen { runGen :: State Word64 a }
 +  deriving newtype ( Functor, Applicative, Monad )
++
 +class Arbitrary a where
 +  arbitrary :: Gen a
++
 +class IsProperty p where
 +  property :: p -> Property
++
 +data PropertyCheck
 +  = PropertyBinaryOp Bool String String String
 +  | PropertyAnd PropertyCheck PropertyCheck
++
 +instance IsProperty PropertyCheck where
 +  property check = Prop (pure (PropertyEOA check))
++
 +data PropertyTestArg
 +  = PropertyEOA PropertyCheck
 +  | PropertyArg String PropertyTestArg
++
 +getCheck :: PropertyTestArg -> ([String], PropertyCheck)
 +getCheck (PropertyEOA pc)    = ([], pc)
 +getCheck (PropertyArg s pta) = let (ss, pc) = getCheck pta in (s:ss, pc)
++
 +data Property = Prop { unProp :: Gen PropertyTestArg }
++
 +instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
 +  property p = forAll arbitrary p
++
 +-- | Run a generator for a value of the given type and add it as an argument
 +-- to the property test.
 +forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
 +forAll generator tst = Prop $ do
 +  a <- generator
 +  augment a <$> unProp (property (tst a))
 +  where
 +    augment a arg = PropertyArg (show a) arg
++
 +-- | Build a @PropertyCheck@ by comparing two values with a named predicate.
 +propertyCompare :: Show a => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
 +propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b)
++
 +-- | Check that two values are equal (by '==').
 +(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
 +(===) = propertyCompare "==" (==)
 +infix 4 ===
++
 +-- | Conjunction of two property checks.
 +propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck
 +propertyAnd = PropertyAnd
++
 +--------------------------------------------------------------------------------
 +-- Test tree
++
 +-- | A named test or group of tests.
 +data Test where
 +  Group    :: String -> [Test] -> Test
 +  Property :: IsProperty prop => String -> prop -> Test
++
 +--------------------------------------------------------------------------------
 +-- Test runner
++
 +newtype Iterations = Iterations { nbIterations :: Word }
 +  deriving newtype ( Show, Eq, Ord )
++
 +-- | Outcome of running a test suite.
 +data Result = Success | Failure [[String]]
++
 +instance Semigroup Result where
 +  Success    <> y          = y
 +  x          <> Success    = x
 +  Failure xs <> Failure ys = Failure (xs ++ ys)
++
 +instance Monoid Result where
 +  mempty = Success
++
 +data RunS = RunS
 +  { depth       :: Int
 +  , currentSeed :: Word64
 +  , context     :: [String]
 +  }
++
 +putMsg :: String -> ReaderT RunS IO ()
 +putMsg s = do
 +  n <- depth <$> ask
 +  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
++
 +nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
 +nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
++
 +runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
 +runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
 +  if ok
 +    then return Success
 +    else do
 +      ctx <- context <$> ask
 +      let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
 +      putMsg msg
 +      return (Failure [msg : ctx])
 +runPropertyCheck (PropertyAnd a b) =
 +  (<>) <$> runPropertyCheck a <*> runPropertyCheck b
++
 +runProperty :: Iterations -> Property -> ReaderT RunS IO Result
 +runProperty (Iterations iters) (Prop p) = do
 +  startingSeed <- currentSeed <$> ask
 +  loop iters startingSeed
 +  where
 +    loop 0 _ = do
 +      putMsg ("Passed " ++ show iters ++ " iterations")
 +      return Success
 +    loop n s = do
 +      let (pt, s') = runState (runGen p) s
 +          (ss, pc) = getCheck pt
 +      res <- runPropertyCheck pc
 +      case res of
 +        Success      -> loop (n - 1) s'
 +        Failure msgs -> do
 +          let msg = "With arguments " ++ intercalate ", " ss ++ " (Seed: " ++ show s ++ ")"
 +          putMsg msg
 +          return (Failure (map (msg :) msgs))
++
 +-- | Run a single 'Test', accumulating all failures.
 +runTestInternal :: Iterations -> Test -> ReaderT RunS IO Result
 +runTestInternal iters (Group name tests) = do
 +  let label = "Group " ++ name
 +  putMsg label
 +  env <- ask
 +  nest label $ do
 +    -- Compute initial seed for each test in the group, based on the
 +    -- index of the test in the group.
 +    let runOne idx t = do
 +          let !s = snd $ stepLCG (currentSeed env + fromIntegral idx)
 +          local (\e -> e { currentSeed = s }) (runTestInternal iters t)
 +    mconcat <$> traverse (uncurry runOne) (zip [1..] tests)
++
 +runTestInternal iters (Property name p) = do
 +  let label = "Running " ++ name
 +  putMsg label
 +  nest label (runProperty iters (property p))
++
 +showStack :: Int -> [String] -> String
 +showStack _  []     = ""
 +showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
++
 +-- | Standard @main@ entry point for tests using 'MiniQuickCheck'.
 +--
 +-- Reads a 'Word64' seed from the first command-line argument, then
 +-- delegates to 'runTests'.
 +runTestsMain :: Iterations -> Test -> IO ()
 +runTestsMain iters t = do
 +  args <- getArgs
 +  seed <- case args of
 +    [arg] -> case readMaybe arg of
 +      Just s  -> pure s
 +      Nothing -> die $ "Invalid seed: " ++ show arg
 +    _ -> die "Usage: <test-name> <seed>"
 +  runTests iters seed t
++
 +runTests :: Iterations -> Word64 -> Test -> IO ()
 +runTests iters seed t = do
 +  res <- runReaderT (runTestInternal iters t) (RunS 0 seed [])
 +  case res of
 +    Success      -> return ()
 +    Failure tests -> do
 +      putStrLn $ "Seed: " ++ show seed
 +      putStrLn $ "These tests failed:\n"
 +              ++ intercalate "\n" (map (showStack 0 . reverse) tests)
 +      exitFailure
++
 +--------------------------------------------------------------------------------
 +-- Random number generation (linear congruences)
++
 +-- Constants from Knuth's MMIX
++
 +lcgMultiplier :: Word64
 +lcgMultiplier = 6364136223846793005
 +lcgIncrement :: Word64
 +lcgIncrement = 1442695040888963407
++
 +-- | Pure step function for the linear congruential generator
 +stepLCG :: Word64 -> (Word64, Word64)
 +stepLCG s =
 +  let s' = s * lcgMultiplier + lcgIncrement
 +  in (s', s')
++
 +--------------------------------------------------------------------------------
 +-- Primitive generators
++
 +-- | Generate a uniformly random 'Word64'.
 +arbitraryWord64 :: Gen Word64
 +arbitraryWord64 = Gen $ state stepLCG
++
 +-- | Generate a uniformly random 'Int64' (bit-reinterpretation of a Word64).
 +arbitraryInt64 :: Gen Int64
 +arbitraryInt64 = fromIntegral <$> arbitraryWord64
++
 +-- | Shrink a random 'Int64' down to a smaller integral type.
 +integralDownsize :: (Integral a, FiniteBits a) => Int64 -> a
 +integralDownsize = wordDownsize . fromIntegral
++
 +-- | Shrink a random 'Word64' down to a smaller integral type.
 +wordDownsize :: forall a. (Integral a, FiniteBits a) => Word64 -> a
 +wordDownsize w =
 +  fromIntegral (w `shiftR` (64 - finiteBitSize (undefined :: a)))
 +    -- take the higher bits (more random with our LCG)
++
 +--------------------------------------------------------------------------------
 +-- Basic Arbitrary instances
++
 +instance Arbitrary Bool where
 +  arbitrary = ( == 1 ) . ( `shiftR` 63 ) <$> arbitraryWord64
++
 +instance Arbitrary Word64 where
 +  arbitrary = arbitraryWord64
 +instance Arbitrary Word32 where
 +  arbitrary = wordDownsize <$> arbitraryWord64
 +instance Arbitrary Word16 where
 +  arbitrary = wordDownsize <$> arbitraryWord64
 +instance Arbitrary Word8 where
 +  arbitrary = wordDownsize <$> arbitraryWord64
 +instance Arbitrary Word where
 +  arbitrary = fromIntegral <$> arbitraryWord64
++
 +instance Arbitrary Int64 where
 +  arbitrary = arbitraryInt64
 +instance Arbitrary Int32 where
 +  arbitrary = integralDownsize <$> arbitraryInt64
 +instance Arbitrary Int16 where
 +  arbitrary = integralDownsize <$> arbitraryInt64
 +instance Arbitrary Int8 where
 +  arbitrary = integralDownsize <$> arbitraryInt64
 +instance Arbitrary Int where
 +  arbitrary = fromIntegral <$> arbitraryInt64
++
 +-- | Generates a natural number with at most 192 bits set.
 +instance Arbitrary Natural where
 +  arbitrary = do
 +    cx <- ( `shiftR` 62 ) <$> arbitraryWord64
 +    n1 <- fromIntegral <$> arbitraryWord64
 +    n2 <- fromIntegral <$> arbitraryWord64
 +    n3 <- fromIntegral <$> arbitraryWord64
++
 +    pure $ case cx of
 +      0 -> n1
 +      1 -> (n1 `shiftL` 64) .|. n2
 +      _ -> (n1 `shiftL` 128) .|. (n2 `shiftL` 64) .|. n3
++
 +-- | Generates an integer with at most 192 bits set.
 +instance Arbitrary Integer where
 +  arbitrary = do
 +    nat <- arbitrary @Natural
 +    neg <- arbitrary @Bool
++
 +    pure $
 +      if neg
 +      then negate (fromIntegral nat)
 +      else fromIntegral nat
++
 +instance Arbitrary Char where
 +  arbitrary = do
 +    let high = fromIntegral (fromEnum (maxBound :: Char)) :: Word
 +    x <- arbitrary
 +    return (toEnum . fromIntegral $ x `mod` (high + 1))
++
 +--------------------------------------------------------------------------------
 +-- Useful newtypes for different Arbitrary instances
++
 +-- | Wrapper for non-zero values.
 +newtype NonZero a = NonZero { getNonZero :: a }
 +  deriving (Eq, Ord, Bounded, Show)
++
 +-- | Generator that rejects zero values.
 +nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
 +nonZero = do
 +  x <- arbitrary
 +  if x == 0 then nonZero else pure (NonZero x)
++
 +instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
 +  arbitrary = nonZero
++
 +-- | Shift amount bounded to @[0, finiteBitSize - 1]@.
 +newtype BoundedShiftAmount a = BoundedShiftAmount { getBoundedShiftAmount :: Int }
 +  deriving (Eq, Ord, Show)
++
 +instance FiniteBits a => Arbitrary (BoundedShiftAmount a) where
 +  arbitrary = do
 +    x <- arbitrary
 +    let w = finiteBitSize (undefined :: a)
 +    pure $ BoundedShiftAmount (abs x `mod` w)
++
 +-- | @a `BoundedBy` n@ represents numbers with maximum absolute value @n@ (inclusive).
 +type BoundedBy :: Type -> Nat -> Type
 +newtype BoundedBy a n = BoundedBy { getBoundedBy :: a }
 +  deriving (Eq, Ord, Show)
++
 +instance
 +  forall n a
 +  .  ( KnownNat n, Integral a, Arbitrary a )
 +  => Arbitrary ( a `BoundedBy` n ) where
 +  arbitrary = BoundedBy . (`rem` (n + 1)) <$> arbitrary
 +    where
 +      n :: a
 +      n = fromIntegral $ natVal @n Proxy

testsuite/tests/numeric/should_run/all.T

@@ -3,8 +3,6 @@
  #	extra run flags
  #	expected process return value, if not zero
 -import random
+-
  # some bugs only surface with -O, omitting optasm may cause them to
  # slip into releases! (e.g. #26711)
  setTestOpts(when(have_ncg(), extra_ways(['optasm'])))
@@ -89,7 +87,14 @@ test('T20291', normal, compile_and_run, [''])
  test('T22282', normal, compile_and_run, [''])
  test('T22671', js_fragile(24259), compile_and_run, [''])
  # the high run timeout multiplier exists because of timeouts with the wasm backend
 -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'])
 +test('foundation',
 +     [ mini_quickcheck
 +     , run_timeout_multiplier(4)
 +     , js_fragile(24259)
 +     , extra_ways(['optasm','ghci','ghci-opt'])
 +     ]
 +     , multimod_compile_and_run
 +     , ['foundation', '-fno-break-points'])
  test('T24066', normal, compile_and_run, [''])
  test('div01', normal, compile_and_run, [''])
  test('T24245', normal, compile_and_run, [''])

testsuite/tests/numeric/should_run/foundation.hs

@@ -23,252 +23,20 @@ module Main
      ( main
      ) where
 -import Data.Array.Byte
 -import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize)
 -import Data.Word
 +import Data.Bits       (Bits((.&.), bit))
 +import Data.Function   (on)
  import Data.Int
 -import GHC.Natural
  import Data.Typeable
 +import Data.Word
  import GHC.Int
 -import GHC.Word
 -import Data.Function
 +import GHC.Natural
  import GHC.Prim
 -import Control.Monad.Reader
 -import Data.List (intercalate)
 -import System.Environment (getArgs)
 -import Text.Read (readMaybe)
 -import Unsafe.Coerce
  import GHC.Types
 -import Data.Char
 -import System.Exit
+-
 +import GHC.Word
  import qualified GHC.Internal.PrimopWrappers as Wrapper
 -import qualified GHC.Internal.Prim as Primop
+-
 -newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
 -  deriving newtype (Functor, Applicative, Monad)
+-
 -class Arbitrary a where
 -  arbitrary :: Gen a
+-
 -class IsProperty p where
 -    property :: p -> Property
 +import qualified GHC.Internal.Prim           as Primop
 -data PropertyCheck = PropertyBinaryOp Bool String String String
 -                   | PropertyAnd PropertyCheck PropertyCheck
+-
 -instance IsProperty PropertyCheck where
 -    property check = Prop $ pure (PropertyEOA check)
+-
 -data PropertyTestArg = PropertyEOA PropertyCheck
 -                     | PropertyArg String PropertyTestArg
+-
 -getCheck :: PropertyTestArg -> ([String], PropertyCheck)
 -getCheck (PropertyEOA pc) = ([], pc)
 -getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
+-
 -data Property = Prop { unProp :: Gen PropertyTestArg }
+-
 -instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
 -    property p = forAll arbitrary p
+-
 --- | Running a generator for a specific type under a property
 -forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
 -forAll generator tst = Prop $ do
 -    a <- generator
 -    augment a <$> unProp (property (tst a))
 -  where
 -    augment a arg = PropertyArg (show a) arg
+-
 --- | A property that check for equality of its 2 members.
 -propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
 -propertyCompare s f a b =
 -    let sa = show a
 -        sb = show b
 -     in PropertyBinaryOp (a `f` b) s sa sb
+-
 -(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
 -(===) = propertyCompare "==" (==)
 -infix 4 ===
+-
 -propertyAnd = PropertyAnd
+-
+-
 -data Test where
 -  Group :: String -> [Test] -> Test
 -  Property :: IsProperty prop => String -> prop -> Test
+-
+-
 -arbitraryInt64 :: Gen Int64
 -arbitraryInt64 = Gen $ do
 -    h <- ask
 -    W64# w <- liftIO (randomWord64 h)
 -    return (I64# (unsafeCoerce# w))
+-
 -integralDownsize :: (Integral a) => Int64 -> a
 -integralDownsize = fromIntegral
+-
 -wordDownsize :: (Integral a) => Word64 -> a
 -wordDownsize = fromIntegral
+-
 -arbitraryWord64 :: Gen Word64
 -arbitraryWord64 = Gen $ do
 -    h <- ask
 -    liftIO (randomWord64 h)
+-
 -nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
 -nonZero = do
 -  x <- arbitrary
 -  if x == 0 then nonZero else pure $ NonZero x
+-
 -newtype NonZero a = NonZero { getNonZero :: a }
 -  deriving (Eq,Ord,Bounded,Show)
+-
 -instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
 -  arbitrary = nonZero
+-
 --- | A newtype for shift amounts that are bounded by @wordSize - 1@
 -newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int}
 -  deriving (Eq, Ord, Show)
+-
 -instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where
 -  arbitrary = do
 -    x <- arbitrary
 -    let widthBits = finiteBitSize (undefined :: a)
 -    pure $ BoundedShiftAmount (abs x `mod` widthBits)
+-
 -instance Arbitrary Natural where
 -    arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
+-
 --- Bounded by Int64
 -instance Arbitrary Integer where
 -    arbitrary = fromIntegral <$> arbitraryInt64
+-
 -instance Arbitrary Int where
 -    arbitrary = int64ToInt <$> arbitraryInt64
 -instance Arbitrary Word where
 -    arbitrary = word64ToWord <$> arbitraryWord64
 -instance Arbitrary Word64 where
 -    arbitrary = arbitraryWord64
 -instance Arbitrary Word32 where
 -    arbitrary = wordDownsize <$> arbitraryWord64
 -instance Arbitrary Word16 where
 -    arbitrary = wordDownsize <$> arbitraryWord64
 -instance Arbitrary Word8 where
 -    arbitrary = wordDownsize <$> arbitraryWord64
 -instance Arbitrary Int64 where
 -    arbitrary = arbitraryInt64
 -instance Arbitrary Int32 where
 -    arbitrary = integralDownsize <$> arbitraryInt64
 -instance Arbitrary Int16 where
 -    arbitrary = integralDownsize <$> arbitraryInt64
 -instance Arbitrary Int8 where
 -    arbitrary = integralDownsize <$> arbitraryInt64
+-
 -instance Arbitrary Char where
 -    arbitrary = do
 -      let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
 -      (x::Word) <- arbitrary
 -      let x' = mod x high
 -      return (chr $ fromIntegral x')
+-
 -int64ToInt :: Int64 -> Int
 -int64ToInt (I64# i) = I# (int64ToInt# i)
+-
+-
 -word64ToWord :: Word64 -> Word
 -word64ToWord (W64# i) = W# (word64ToWord# i)
+-
+-
 -data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
+-
 -newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
+-
 -data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
+-
 -newLCGGen :: LCGParams -> IO LCGGen
 -newLCGGen LCGParams {seed = W64# seed#, ..} = do
 -  MutableByteArray mba# <- IO $ \s0 -> case newByteArray# 8# s0 of
 -    (# s1, mba# #) -> case writeWord64Array# mba# 0# seed# s1 of
 -      s2 -> (# s2, MutableByteArray mba# #)
 -  pure $ LCGGen $ IO $ \s0 -> case readWord64Array# mba# 0# s0 of
 -    (# s1, old_val# #) ->
 -      let old_val = W64# old_val#
 -          !new_val@(W64# new_val#) = (old_val * a + c) `mod` m
 -       in case writeWord64Array# mba# 0# new_val# s1 of
 -            s2 -> (# s2, new_val #)
+-
 -runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
 -  if res then return Success
 -         else do
 -          ctx <- context <$> ask
 -          let msg = "Failure: " ++ s1 ++ desc ++ s2
 -          putMsg msg
 -          return (Failure [msg : ctx])
 -runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPropertyCheck a2
+-
 -runProperty :: Property -> ReaderT RunS IO Result
 -runProperty (Prop p) = do
 -  let iterations = 1000 :: Int
 -  loop iterations iterations
 -  where
 -    loop iterations 0 = do
 -      putMsg ("Passed " ++ show iterations ++ " iterations")
 -      return Success
 -    loop iterations n = do
 -      h <- rg <$> ask
 -      p <- liftIO (runReaderT (runGen p) h)
 -      let (ss, pc) = getCheck p
 -      res <- runPropertyCheck pc
 -      case res of
 -        Success -> loop iterations (n-1)
 -        Failure msgs -> do
 -          let msg = ("With arguments " ++ intercalate ", " ss)
 -          putMsg msg
 -          return (Failure (map (msg :) msgs))
+-
 -data Result = Success | Failure [[String]]
+-
 -instance Semigroup Result where
 -  Success <> x = x
 -  x <> Success = x
 -  (Failure xs) <> (Failure ys) = Failure (xs ++ ys)
+-
 -instance Monoid Result where
 -  mempty = Success
+-
 -putMsg s = do
 -  n <- depth <$> ask
 -  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
+-
+-
 -nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
+-
 -runTestInternal :: Test -> ReaderT RunS IO Result
 -runTestInternal (Group name tests) = do
 -  let label = ("Group " ++ name)
 -  putMsg label
 -  nest label (mconcat <$> mapM runTestInternal tests)
 -runTestInternal (Property name p) = do
 -  let label = ("Running " ++ name)
 -  putMsg label
 -  nest label $ runProperty (property p)
+-
+-
 -runTests :: Word64 -> Test -> IO ()
 -runTests seed t = do
 -  -- These params are the same ones as glibc uses.
 -  h <- newLCGGen (LCGParams { seed, m = 2 ^ (31 :: Int), a = 1103515245, c = 12345 })
 -  res <- runReaderT  (runTestInternal t) (RunS 0 h [])
 -  case res of
 -    Success -> return ()
 -    Failure tests -> do
 -      putStrLn $ "Seed: " ++ show seed
 -      putStrLn $ "These tests failed:  \n" ++ intercalate "  \n" (map (showStack 0 . reverse) tests)
 -      exitFailure
+-
 -showStack _ [] = ""
 -showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
 +import MiniQuickCheck
  -------------------------------------------------------------------------------
@@ -325,8 +93,11 @@ testOperatorPrecedence _ = Group "Precedence"
      , Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c)
      , Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c))
      , Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c)
 -    , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
 -    , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
++
 +      -- Bound the exponent to avoid OOM errors e.g.
 +      --   GNU MP: Cannot allocate memory (size=4294938656)
 +    , Property "* and ^ (1)" $ \(a :: a) (BoundedBy b :: Natural `BoundedBy` 100) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
 +    , Property "* and ^ (2)" $ \(a :: a) (BoundedBy c :: Natural `BoundedBy` 100) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
+     ]
@@ -454,19 +225,8 @@ instance TestPrimop LowerBitsAreDefined where
  twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
  twoNonZero f x (NonZero y) = f x y
 -getSeedFromArgs :: IO Word64
 -getSeedFromArgs = do
 -  args <- getArgs
 -  case args of
 -    [arg] -> case readMaybe arg of
 -      Just seed -> pure seed
 -      Nothing -> die $ "Invalid seed (expected Word64): " ++ show arg
 -    _ -> die "Usage: foundation <seed>"
+-
  main :: IO ()
 -main = do
 -  seed <- getSeedFromArgs
 -  runTests seed (Group "ALL" [testNumberRefs, testPrimops])
 +main = runTestsMain (Iterations 1000) (Group "ALL" [testNumberRefs, testPrimops])
  -- Test an interpreted primop vs a compiled primop
  testPrimops = Group "primop"

testsuite/tests/simd/should_run/all.T

@@ -80,7 +80,7 @@ test('simd002', [], compile_and_run, [''])
  test('simd003', [], compile_and_run, [''])
  test('simd004', [], compile_and_run, ['-O2'])
  test('simd005', [], compile_and_run, [''])
 -test('simd006', [], compile_and_run, [''])
 +test('simd006', [mini_quickcheck], multimod_compile_and_run, ['simd006', ''])
  test('simd007', [], compile_and_run, [''])
  test('simd008', [], compile_and_run, [''])
  test('simd009', [ req_th

testsuite/tests/simd/should_run/simd006.hs

 -{-# LANGUAGE MagicHash #-}
 -{-# LANGUAGE UnboxedTuples #-}
 -{-# LANGUAGE FlexibleContexts    #-}
 -{-# LANGUAGE OverloadedStrings   #-}
 -{-# LANGUAGE ScopedTypeVariables #-}
 -{-# LANGUAGE TypeFamilies        #-}
 -{-# LANGUAGE DerivingStrategies #-}
 +{-# LANGUAGE MagicHash           #-}
 +{-# LANGUAGE UnboxedTuples       #-}
 +{-# LANGUAGE DerivingStrategies  #-}
  {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 -{-# LANGUAGE MagicHash #-}
 -{-# LANGUAGE RecordWildCards #-}
 +{-# LANGUAGE ScopedTypeVariables #-}
 --- QuickCheck testing for SIMD operations
 +-- QuickCheck-like property tests for SIMD vector operations.
 -module Main
 -    ( main
 -    ) where
 +module Main (main) where
 -import Data.Word
 -import Data.Int
 -import GHC.Natural
  import Data.Coerce
 -import Data.Typeable
 -import Data.Proxy
 -import GHC.Int
 -import GHC.Word
 -import Data.Function
 +import Data.Word
  import GHC.Prim
 -import Control.Monad.Reader
 -import System.IO
 -import Foreign.Marshal.Alloc
 -import Foreign.Storable
 -import Foreign.Ptr
 -import Data.List (intercalate)
 -import Data.IORef
 -import Unsafe.Coerce
  import GHC.Exts
  import GHC.Float
    ( castFloatToWord32 , castWord32ToFloat
    , castDoubleToWord64, castWord64ToDouble
+   )
 +import MiniQuickCheck
 +--------------------------------------------------------------------------------
 +-- Scalar wrappers that use bit-equality to test for equality.
 -newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
 -  deriving newtype (Functor, Applicative, Monad)
+-
 -class Arbitrary a where
 -  arbitrary :: Gen a
+-
 -class IsProperty p where
 -    property :: p -> Property
+-
 -data PropertyCheck = PropertyBinaryOp Bool String String String
 -                   | PropertyAnd PropertyCheck PropertyCheck
+-
 -instance IsProperty PropertyCheck where
 -    property check = Prop $ pure (PropertyEOA check)
+-
 -data PropertyTestArg = PropertyEOA PropertyCheck
 -                     | PropertyArg String PropertyTestArg
+-
 -getCheck :: PropertyTestArg -> ([String], PropertyCheck)
 -getCheck (PropertyEOA pc) = ([], pc)
 -getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
+-
 -data Property = Prop { unProp :: Gen PropertyTestArg }
+-
 -instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
 -    property p = forAll arbitrary p
+-
 --- | Running a generator for a specific type under a property
 -forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
 -forAll generator tst = Prop $ do
 -    a <- generator
 -    augment a <$> unProp (property (tst a))
 -  where
 -    augment a arg = PropertyArg (show a) arg
+-
 --- | A property that check for equality of its 2 members.
 -propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
 -propertyCompare s f a b =
 -    let sa = show a
 -        sb = show b
 -     in PropertyBinaryOp (a `f` b) s sa sb
+-
 -(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
 -(===) = propertyCompare "==" (==)
 -infix 4 ===
+-
 -propertyAnd = PropertyAnd
+-
+-
 -data Test where
 -  Group :: String -> [Test] -> Test
 -  Property :: IsProperty prop => String -> prop -> Test
+-
 +newtype FloatNT = FloatNT Float
 +  deriving newtype (Show, Num)
 -arbitraryInt64 :: Gen Int64
 -arbitraryInt64 = Gen $ do
 -    h <- ask
 -    W64# w <- liftIO (randomWord64 h)
 -    return (I64# (unsafeCoerce# w))
 +instance Eq FloatNT where
 +  FloatNT f1 == FloatNT f2 = castFloatToWord32 f1 == castFloatToWord32 f2
 -integralDownsize :: (Integral a) => Int64 -> a
 -integralDownsize = fromIntegral
 +instance Arbitrary FloatNT where
 +  arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
 -wordDownsize :: (Integral a) => Word64 -> a
 -wordDownsize = fromIntegral
 +newtype DoubleNT = DoubleNT Double
 +  deriving newtype (Show, Num)
 -arbitraryWord64 :: Gen Word64
 -arbitraryWord64 = Gen $ do
 -    h <- ask
 -    liftIO (randomWord64 h)
 +instance Eq DoubleNT where
 +  DoubleNT d1 == DoubleNT d2 = castDoubleToWord64 d1 == castDoubleToWord64 d2
 +instance Arbitrary DoubleNT where
 +  arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
 -instance Arbitrary Word64 where
 -    arbitrary = arbitraryWord64
 -instance Arbitrary Word32 where
 -    arbitrary = wordDownsize <$> arbitraryWord64
 +--------------------------------------------------------------------------------
 +-- Min/max for the types under test
  class HasMinMax a where
    mini, maxi :: a -> a -> a
++
  instance HasMinMax FloatNT where
    mini (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (minFloat# f1 f2))
    maxi (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (maxFloat# f1 f2))
++
  instance HasMinMax DoubleNT where
    mini (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (minDouble# d1 d2))
    maxi (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (maxDouble# d1 d2))
 -newtype FloatNT = FloatNT Float
 -  deriving newtype (Show, Num)
 -instance Eq FloatNT where
 -  FloatNT f1 == FloatNT f2 =
 -    castFloatToWord32 f1 == castFloatToWord32 f2
 -instance Arbitrary FloatNT where
 -  arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
 -newtype DoubleNT = DoubleNT Double
 -  deriving newtype (Show, Num)
 -instance Eq DoubleNT where
 -  DoubleNT d1 == DoubleNT d2 =
 -    castDoubleToWord64 d1 == castDoubleToWord64 d2
 -instance Arbitrary DoubleNT where
 -  arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
+-
 +--------------------------------------------------------------------------------
 +-- SIMD vector types
  data FloatX4 = FX4# FloatX4#
++
  instance Show FloatX4 where
 -  show (FX4# f) = case (unpackFloatX4# f) of
 -    (# a, b, c, d #) -> show ((F# a), (F# b), (F# c), (F# d))
 +  show (FX4# f) = case unpackFloatX4# f of
 +    (# a, b, c, d #) -> show (F# a, F# b, F# c, F# d)
++
  instance Eq FloatX4 where
 -  (FX4# a) == (FX4# b)
 -    = case (unpackFloatX4# a) of
 +  FX4# a == FX4# b
 +    = case unpackFloatX4# a of
          (# a1, a2, a3, a4 #) ->
 -          case (unpackFloatX4# b) of
 -            (# b1, b2, b3, b4 #) -> FloatNT (F# a1) == FloatNT (F# b1) &&
 -                                    FloatNT (F# a2) == FloatNT (F# b2) &&
 -                                    FloatNT (F# a3) == FloatNT (F# b3) &&
 -                                    FloatNT (F# a4) == FloatNT (F# b4)
 +          case unpackFloatX4# b of
 +            (# b1, b2, b3, b4 #) ->
 +              FloatNT (F# a1) == FloatNT (F# b1) &&
 +              FloatNT (F# a2) == FloatNT (F# b2) &&
 +              FloatNT (F# a3) == FloatNT (F# b3) &&
 +              FloatNT (F# a4) == FloatNT (F# b4)
++
  instance Arbitrary FloatX4 where
    arbitrary = do
      FloatNT (F# f1) <- arbitrary
@@ -163,52 +81,59 @@ instance Arbitrary FloatX4 where
      FloatNT (F# f3) <- arbitrary
      FloatNT (F# f4) <- arbitrary
      return $ FX4# (packFloatX4# (# f1, f2, f3, f4 #))
++
  instance Num FloatX4 where
 -  FX4# x + FX4# y =
 -    FX4# ( x `plusFloatX4#` y )
 -  FX4# x - FX4# y =
 -    FX4# ( x `minusFloatX4#` y )
 -  negate ( FX4# x ) = FX4# ( negateFloatX4# x )
 -  FX4# x * FX4# y =
 -    FX4# ( x `timesFloatX4#` y )
 -  abs = error "no"
 -  signum = error "no"
 -  fromInteger = error "no"
 +  FX4# x + FX4# y = FX4# (x `plusFloatX4#`  y)
 +  FX4# x - FX4# y = FX4# (x `minusFloatX4#` y)
 +  negate (FX4# x) = FX4# (negateFloatX4# x)
 +  FX4# x * FX4# y = FX4# (x `timesFloatX4#` y)
 +  abs    = error "FloatX4: no abs"
 +  signum = error "FloatX4: no signum"
 +  fromInteger = error "FloatX4: no fromInteger"
++
  instance HasMinMax FloatX4 where
    mini (FX4# a) (FX4# b) = FX4# (minFloatX4# a b)
    maxi (FX4# a) (FX4# b) = FX4# (maxFloatX4# a b)
 +--------------------------------------------------------------------------------
++
  data DoubleX2 = DX2# DoubleX2#
++
  instance Show DoubleX2 where
 -  show (DX2# d) = case (unpackDoubleX2# d) of
 -    (# a, b #) -> show ((D# a), (D# b))
 +  show (DX2# d) = case unpackDoubleX2# d of
 +    (# a, b #) -> show (D# a, D# b)
++
  instance Eq DoubleX2 where
 -  (DX2# a) == (DX2# b)
 -    = case (unpackDoubleX2# a) of
 +  DX2# a == DX2# b
 +    = case unpackDoubleX2# a of
          (# a1, a2 #) ->
 -          case (unpackDoubleX2# b) of
 -            (# b1, b2 #) -> DoubleNT (D# a1) == DoubleNT (D# b1) &&
 -                            DoubleNT (D# a2) == DoubleNT (D# b2)
 +          case unpackDoubleX2# b of
 +            (# b1, b2 #) ->
 +              DoubleNT (D# a1) == DoubleNT (D# b1) &&
 +              DoubleNT (D# a2) == DoubleNT (D# b2)
++
  instance Arbitrary DoubleX2 where
    arbitrary = do
      DoubleNT (D# d1) <- arbitrary
      DoubleNT (D# d2) <- arbitrary
      return $ DX2# (packDoubleX2# (# d1, d2 #))
++
  instance Num DoubleX2 where
 -  DX2# x + DX2# y =
 -    DX2# ( x `plusDoubleX2#` y )
 -  DX2# x - DX2# y =
 -    DX2# ( x `minusDoubleX2#` y )
 -  negate ( DX2# x ) = DX2# ( negateDoubleX2# x )
 -  DX2# x * DX2# y =
 -    DX2# ( x `timesDoubleX2#` y )
 -  abs = error "no"
 -  signum = error "no"
 -  fromInteger = error "no"
 +  DX2# x + DX2# y = DX2# (x `plusDoubleX2#`  y)
 +  DX2# x - DX2# y = DX2# (x `minusDoubleX2#` y)
 +  negate (DX2# x) = DX2# (negateDoubleX2# x)
 +  DX2# x * DX2# y = DX2# (x `timesDoubleX2#` y)
 +  abs    = error "DoubleX2: no abs"
 +  signum = error "DoubleX2: no signum"
 +  fromInteger = error "DoubleX2: no fromInteger"
++
  instance HasMinMax DoubleX2 where
    mini (DX2# a) (DX2# b) = DX2# (minDoubleX2# a b)
    maxi (DX2# a) (DX2# b) = DX2# (maxDoubleX2# a b)
 +--------------------------------------------------------------------------------
 +-- Expression language for generating random expressions over vector types.
++
  data Expr a where
    Lit :: a -> Expr a
    Add :: Expr a -> Expr a -> Expr a
@@ -218,11 +143,12 @@ data Expr a where
    Min :: Expr a -> Expr a -> Expr a
    Max :: Expr a -> Expr a -> Expr a
    deriving (Show, Eq)
++
  fmapExpr :: (a -> b) -> Expr a -> Expr b
 -fmapExpr f (Lit a) = Lit (f a)
 +fmapExpr f (Lit a)   = Lit (f a)
  fmapExpr f (Add a b) = Add (fmapExpr f a) (fmapExpr f b)
  fmapExpr f (Sub a b) = Sub (fmapExpr f a) (fmapExpr f b)
 -fmapExpr f (Neg a) = Neg (fmapExpr f a)
 +fmapExpr f (Neg a)   = Neg (fmapExpr f a)
  fmapExpr f (Mul a b) = Mul (fmapExpr f a) (fmapExpr f b)
  fmapExpr f (Min a b) = Min (fmapExpr f a) (fmapExpr f b)
  fmapExpr f (Max a b) = Max (fmapExpr f a) (fmapExpr f b)
@@ -240,75 +166,16 @@ instance Arbitrary a => Arbitrary (Expr a) where
        _ -> Lit <$> arbitrary
  eval :: (Num a, HasMinMax a) => Expr a -> a
 -eval (Lit a) = a
 +eval (Lit a)   = a
  eval (Add a b) = eval a + eval b
  eval (Sub a b) = eval a - eval b
 -eval (Neg a) = negate (eval a)
 +eval (Neg a)   = negate (eval a)
  eval (Mul a b) = eval a * eval b
  eval (Min a b) = mini (eval a) (eval b)
  eval (Max a b) = maxi (eval a) (eval b)
 -int64ToInt :: Int64 -> Int
 -int64ToInt (I64# i) = I# (int64ToInt# i)
+-
+-
 -word64ToWord :: Word64 -> Word
 -word64ToWord (W64# i) = W# (word64ToWord# i)
+-
+-
 -data RunS = RunS { depth :: Int, rg :: LCGGen  }
+-
 -newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
+-
 -data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
+-
 -newLCGGen :: LCGParams -> IO LCGGen
 -newLCGGen LCGParams{..}  = do
 -  var <- newIORef (fromIntegral seed)
 -  return $ LCGGen $ do
 -    atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val))
+-
+-
 -runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
 -  if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
 -runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
+-
 -runProperty :: Property -> ReaderT RunS IO ()
 -runProperty (Prop p) = do
 -  let iterations = 100
 -  loop iterations iterations
 -  where
 -    loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
 -    loop iterations n = do
 -      h <- rg <$> ask
 -      p <- liftIO (runReaderT (runGen p) h)
 -      let (ss, pc) = getCheck p
 -      res <- runPropertyCheck pc
 -      if res then loop iterations (n-1)
 -             else putMsg ("With arguments " ++ intercalate ", " ss)
+-
 -putMsg s = do
 -  n <- depth <$> ask
 -  liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
+-
 -nest = local (\s -> s { depth = depth s + 1 })
+-
 -runTestInternal :: Test -> ReaderT RunS IO ()
 -runTestInternal (Group name tests) = do
 -  putMsg ("Group " ++ name)
 -  nest (mapM_ runTestInternal tests)
 -runTestInternal (Property name p) = do
 -  putMsg ("Running " ++ name)
 -  nest $ runProperty (property p)
+-
+-
 -runTests :: Test -> IO ()
 -runTests t = do
 -  -- These params are the same ones as glibc uses.
 -  h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
 -  runReaderT  (runTestInternal t) (RunS 0 h)
+-
 --------------------------------------------------------------------------------
 +--------------------------------------------------------------------------------
 +-- Test groups
  testFloatX4 :: Test
  testFloatX4 = Group "FloatX4"
@@ -324,15 +191,12 @@ testFloatX4 = Group "FloatX4"
      unpack :: FloatX4 -> ( FloatNT, FloatNT, FloatNT, FloatNT )
      unpack (FX4# f) = case unpackFloatX4# f of
        (# f1, f2, f3, f4 #) -> coerce ( F# f1, F# f2, F# f3, F# f4 )
++
      get1, get2, get3, get4 :: FloatX4 -> FloatNT
 -    get1 (FX4# f) = case unpackFloatX4# f of
 -      (# f1, _, _, _ #) -> FloatNT (F# f1)
 -    get2 (FX4# f) = case unpackFloatX4# f of
 -      (# _, f2, _, _ #) -> FloatNT (F# f2)
 -    get3 (FX4# f) = case unpackFloatX4# f of
 -      (# _, _, f3, _ #) -> FloatNT (F# f3)
 -    get4 (FX4# f) = case unpackFloatX4# f of
 -      (# _, _, _, f4 #) -> FloatNT (F# f4)
 +    get1 (FX4# f) = case unpackFloatX4# f of (# f1,  _,  _,  _ #) -> FloatNT (F# f1)
 +    get2 (FX4# f) = case unpackFloatX4# f of (#  _, f2,  _,  _ #) -> FloatNT (F# f2)
 +    get3 (FX4# f) = case unpackFloatX4# f of (#  _,  _, f3,  _ #) -> FloatNT (F# f3)
 +    get4 (FX4# f) = case unpackFloatX4# f of (#  _,  _,  _, f4 #) -> FloatNT (F# f4)
  testDoubleX2 :: Test
  testDoubleX2 = Group "DoubleX2"
@@ -346,16 +210,15 @@ testDoubleX2 = Group "DoubleX2"
      unpack :: DoubleX2 -> ( DoubleNT, DoubleNT )
      unpack (DX2# d) = case unpackDoubleX2# d of
        (# d1, d2 #) -> coerce ( D# d1, D# d2 )
++
      get1, get2 :: DoubleX2 -> DoubleNT
      get1 (DX2# d) = case unpackDoubleX2# d of
 -      (# d1, _ #) -> DoubleNT (D# d1)
 +      (# d1,  _ #) -> DoubleNT (D# d1)
      get2 (DX2# d) = case unpackDoubleX2# d of
 -      (# _, d2 #) -> DoubleNT (D# d2)
 +      (#  _, d2 #) -> DoubleNT (D# d2)
  testSIMD :: Test
 -testSIMD = Group "ALL"
 -    [ testFloatX4
 -    , testDoubleX2
 -    ]
 +testSIMD = Group "ALL" [testFloatX4, testDoubleX2]
 -main = runTests testSIMD
 +main :: IO ()
 +main = runTestsMain (Iterations 100) testSIMD