diff options
Diffstat (limited to 'testsuite/tests/codeGen')
35 files changed, 1186 insertions, 10 deletions
diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile index a3e03d244b..c94c8b6f92 100644 --- a/testsuite/tests/codeGen/should_compile/Makefile +++ b/testsuite/tests/codeGen/should_compile/Makefile @@ -5,6 +5,9 @@ include $(TOP)/mk/test.mk T2578: '$(TEST_HC)' $(TEST_HC_OPTS) --make T2578 -fforce-recomp -v0 +T14626: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-prep -dsuppress-uniques T14626.hs | grep case + debug: # Without optimisations, we should get annotations for basically # all expressions in the example program. @@ -30,3 +33,11 @@ debug: ./debug rm debug + +T14999: + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -g -c T14999.cmm -o T14999.o + gdb --batch -ex 'file T14999.o' -ex 'disassemble stg_catch_frame_info' --nx | tr -s '[[:blank:]\n]' + readelf --debug-dump=frames-interp T14999.o | tr -s '[[:blank:]\n]' + +T15196: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-asm T15196.hs | grep "jp " ; echo $$? diff --git a/testsuite/tests/codeGen/should_compile/T14626.hs b/testsuite/tests/codeGen/should_compile/T14626.hs new file mode 100644 index 0000000000..a665694bfc --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T14626.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} + +module T14626 where + +import GHC.Prim + +data T = MkT !Bool + +f v = case v of + MkT y -> dataToTag# y + +-- This should /not/ produce an inner case on the y, thus: +-- f v = case v of +-- MkT y -> case y of z -> dataToTag# z +-- But it was! See Trac #14626 comment:4 diff --git a/testsuite/tests/codeGen/should_compile/T14626.stdout b/testsuite/tests/codeGen/should_compile/T14626.stdout new file mode 100644 index 0000000000..389d3e733a --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T14626.stdout @@ -0,0 +1,2 @@ + case dt of dt [Occ=Once] { __DEFAULT -> T14626.MkT dt } + case v of { T14626.MkT y [Occ=Once] -> diff --git a/testsuite/tests/codeGen/should_compile/T14999.cmm b/testsuite/tests/codeGen/should_compile/T14999.cmm new file mode 100644 index 0000000000..a3e283b0be --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T14999.cmm @@ -0,0 +1,11 @@ +#define CATCH_FRAME 34 + +#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16) + +INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, + bits64 info_ptr, bits64 exceptions_blocked, gcptr handler) + return (gcptr ret) +{ + return (ret); +} + diff --git a/testsuite/tests/codeGen/should_compile/T14999.stdout b/testsuite/tests/codeGen/should_compile/T14999.stdout new file mode 100644 index 0000000000..546be1b73c --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T14999.stdout @@ -0,0 +1,13 @@ +Dump of assembler code for function stg_catch_frame_info: + 0x0000000000000010 <+0>: add $0x18,%rbp + 0x0000000000000014 <+4>: jmpq *0x0(%rbp) +End of assembler dump. +Contents of the .debug_frame section: +00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16 + LOC CFA rbp rsp ra +0000000000000000 rbp+0 v+0 s c+0 +00000018 000000000000002c 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017 + LOC CFA rbp rsp ra +000000000000000f rbp+0 v+0 s c+0 +000000000000000f rbp+24 v+0 s c+0 +0000000000000014 rbp+0 v+0 s c+0 diff --git a/testsuite/tests/codeGen/should_compile/T15196.hs b/testsuite/tests/codeGen/should_compile/T15196.hs new file mode 100644 index 0000000000..6df88d8432 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T15196.hs @@ -0,0 +1,4 @@ +module M where + +f :: Double -> Double -> Bool +f x y = if x < y then True else False diff --git a/testsuite/tests/codeGen/should_compile/T15196.stdout b/testsuite/tests/codeGen/should_compile/T15196.stdout new file mode 100644 index 0000000000..56a6051ca2 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T15196.stdout @@ -0,0 +1 @@ +1
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T index 6ae4e1cb4e..dd6931f235 100644 --- a/testsuite/tests/codeGen/should_compile/all.T +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -30,8 +30,22 @@ test('debug', run_command, ['$MAKE -s --no-print-directory debug']) test('T9964', normal, compile, ['-O']) test('T10518', [cmm_src], compile, ['']) -test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')), +test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))], compile, ['-g']) test('T12115', normal, compile, ['']) test('T12355', normal, compile, ['']) +test('T14626', + normal, + run_command, ['$MAKE -s --no-print-directory T14626']) +test('T14999', + [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261)), + unless(opsys('linux') and arch('x86_64') and have_gdb() and + have_readelf(), skip)], + run_command, ['$MAKE -s --no-print-directory T14999']) + +# Verify that we optimize away redundant jumps for unordered comparisons. +test('T15196', + [ unless(arch('x86_64'),skip), + only_ways('normal'), + ], run_command, ['$MAKE -s --no-print-directory T15196']) diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs index fa5a37b046..1facb77914 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.hs +++ b/testsuite/tests/codeGen/should_fail/T13233.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MagicHash #-} diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr index c1cbb97d21..c3683138f8 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.stderr +++ b/testsuite/tests/codeGen/should_fail/T13233.stderr @@ -8,7 +8,9 @@ T13233.hs:14:11: error: T13233.hs:22:16: error: Cannot use primitive with levity-polymorphic arguments: - GHC.Prim.(#,#) :: forall (a :: TYPE rep1) (b :: TYPE rep2). + GHC.Prim.(#,#) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep) (a :: TYPE + rep1) (b :: TYPE + rep2). a -> b -> (# a, b #) Levity-polymorphic arguments: a :: TYPE rep1 diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs new file mode 100644 index 0000000000..1197dc60fe --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs @@ -0,0 +1,78 @@ +module Main where + +import DynFlags +import RepType +import SMRep +import StgCmmLayout +import StgCmmClosure +import GHC +import GhcMonad +import System.Environment +import Platform + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) tests + + +-- How to read tests: +-- F(a,8) = field a at offset 8 +-- P(4,8) = 4 bytes of padding at offset 8 +tests :: Ghc () +tests = do + (_, _, off) <- runTest [("a", FloatRep), ("b", DoubleRep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,8)"] + ["F(a,8)", "P(4,12)", "F(b,16)"] + + (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,8)"] + ["F(a,8)", "F(b,12)"] + + (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", FloatRep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,8)", "F(c,12)"] + ["F(a,8)", "F(b,12)", "F(c,16)", "P(4,20)"] + + (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", Int64Rep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,8)", "F(c,12)"] + ["F(a,8)", "F(b,12)", "F(c,16)"] + + (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", FloatRep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,12)", "F(c,16)"] + ["F(a,8)", "F(b,16)", "F(c,20)"] + + (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", Int64Rep)] + assert_32_64 (map fmt off) + ["F(a,4)", "F(b,12)", "F(c,16)"] + ["F(a,8)", "F(b,16)", "P(4,20)", "F(c,24)"] + + +assert_32_64 :: (Eq a, Show a) => a -> a -> a -> Ghc () +assert_32_64 actual expected32 expected64 = do + dflags <- getDynFlags + let + expected + | word_size == 4 = expected32 + | word_size == 8 = expected64 + word_size = wORD_SIZE dflags + case actual == expected of + True -> return () + False -> + error $ "Expected:\n" ++ show expected + ++ "\nBut got:\n" ++ show actual + +runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a]) +runTest prim_reps = do + dflags <- getDynFlags + return $ mkVirtHeapOffsetsWithPadding dflags StdHeader (mkNonVoids prim_reps) + where + mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a)) + +fmt :: FieldOffOrPadding String -> String +fmt (FieldOff (NonVoid id) off) = "F(" ++ id ++ "," ++ show off ++ ")" +fmt (Padding len off) = "P(" ++ show len ++ "," ++ show off ++ ")" diff --git a/testsuite/tests/codeGen/should_run/T14251.hs b/testsuite/tests/codeGen/should_run/T14251.hs new file mode 100644 index 0000000000..d31498efe4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14251.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +module Main where + +import GHC.Exts + +{-# NOINLINE f #-} +f :: (Int# -> Float# -> Double# -> Float# -> Double# -> String) -> String +f g = g 3# 4.0# 5.0## 6.0# 6.9## ++ " World!" + +{-# NOINLINE p #-} +p :: Int# -> Float# -> Double# -> Float# -> Double# -> String +p i j k l m = "Hello" + +{-# NOINLINE q #-} +q :: Int# -> Int# -> Float# -> Double# -> Float# -> Double# -> String +q _ i j k l m = "Hello " ++ show (F# l) ++ " " ++ show (D# m) + +{-# NOINLINE r #-} +r :: Int# -> Float# -> Double# -> Float# -> Double# -> String +r i = let !(I# z) = length [I# 1# .. I# i] in \j k l m -> p z j k l m + -- ghc won't eta-expand around the length, because it has unknown cost + +main = do + putStrLn (f p) -- fast call + putStrLn (f r) -- slow call: function but wrong arity + let g = last [q 1#] + putStrLn (f g) -- slow call: thunk diff --git a/testsuite/tests/codeGen/should_run/T14251.stdout b/testsuite/tests/codeGen/should_run/T14251.stdout new file mode 100644 index 0000000000..de803214d4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14251.stdout @@ -0,0 +1,4 @@ +Hello World! +Hello World! +Hello 6.0 6.9 World! + diff --git a/testsuite/tests/codeGen/should_run/T14346.hs b/testsuite/tests/codeGen/should_run/T14346.hs new file mode 100644 index 0000000000..b61b92bd07 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14346.hs @@ -0,0 +1,21 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import Data.Word +import Foreign.Marshal.Alloc +import Foreign.Storable +import Numeric +import GHC.Ptr + +main :: IO () +main = do + replicateM_ 49 $ threadDelay 1 + _ <- forkIO $ do + allocaBytes 4 $ \p -> do + forever $ do + poke p (0xDEADBEEF :: Word32) + threadDelay 10 + x <- peek p + unless (x == 0xDEADBEEF) $ putStrLn (showHex x "") + threadDelay 1000000 diff --git a/testsuite/tests/codeGen/should_run/T14619.hs b/testsuite/tests/codeGen/should_run/T14619.hs new file mode 100644 index 0000000000..7af16dff67 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14619.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -O1 #-} + +{- + On windows some xmm registers are callee saved. This means + they can't be used as scratch registers before a call to C. + + In #14619 this wasn't respected which lead to a wrong value + ending up in xmm6 and being returned in the final result. + + This code compiles to a non trivial fp computation followed + by a call to sqrt at O1+. If xmm6 isn't properly handled it + will be used as a scratch register failing the test. + + The original code used regular sqrt which on 8.2 generated + a C call in the backend. To imitate this behaviour on 8.4+ + we force a call to a C function instead. +-} + +module Main (main) where + + + +import Prelude hiding((*>), (<*)) +import Foreign.C +import Unsafe.Coerce + +foreign import ccall unsafe "sqrt" call_sqrt :: CDouble -> CDouble + +type V3 = (Double, Double, Double) + +absf :: V3 -> V3 -> Double +absf (x, y, z) (x', y', z') = x*x' +y*y'+z*z' + + +{-# NOINLINE sphereIntersection #-} +sphereIntersection :: V3 -> V3 -> (V3) +sphereIntersection orig dir@(_, _, dirz) + | b < 0 = undefined + | t1 > 0 = dir + | t1 < 0 = orig + | otherwise = undefined + where b = orig `absf` dir + sqrtDisc = realToFrac . call_sqrt $ CDouble b + t1 = b - sqrtDisc + +main = print $ sphereIntersection (11, 22, 33) (44, 55, 66) diff --git a/testsuite/tests/codeGen/should_run/T14619.stdout b/testsuite/tests/codeGen/should_run/T14619.stdout new file mode 100644 index 0000000000..a11c04de2e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14619.stdout @@ -0,0 +1 @@ +(44.0,55.0,66.0) diff --git a/testsuite/tests/codeGen/should_run/T14754.hs b/testsuite/tests/codeGen/should_run/T14754.hs new file mode 100644 index 0000000000..181659d4eb --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14754.hs @@ -0,0 +1,15 @@ +module Main where + +import Debug.Trace + +main :: IO () +main = print (alg 3 1) + +alg :: Word -> Word -> Word +alg a b + | traceShow (a, b) False = undefined + | c < b = alg b c + | c > b = alg c b + | otherwise = c + where + c = a - b diff --git a/testsuite/tests/codeGen/should_run/T14754.stderr b/testsuite/tests/codeGen/should_run/T14754.stderr new file mode 100644 index 0000000000..42c78ed097 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14754.stderr @@ -0,0 +1,2 @@ +(3,1) +(2,1) diff --git a/testsuite/tests/codeGen/should_run/T14754.stdout b/testsuite/tests/codeGen/should_run/T14754.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T14754.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/codeGen/should_run/T15038/Makefile b/testsuite/tests/codeGen/should_run/T15038/Makefile new file mode 100644 index 0000000000..48493c08ef --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/Makefile @@ -0,0 +1,15 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T15038 +T15038: + '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -o Main \ + ./test/Main.hs \ + ./test/Parser.hs \ + ./src/Packed/Bytes/Stream/ST.hs \ + ./src/Packed/Bytes/Parser.hs \ + ./src/Packed/Bytes.hs \ + ./common/Data/Trie/Naive.hs \ + -package containers -package ghc-prim -package primitive + ./Main diff --git a/testsuite/tests/codeGen/should_run/T15038/all.T b/testsuite/tests/codeGen/should_run/T15038/all.T new file mode 100644 index 0000000000..6b284784ae --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/all.T @@ -0,0 +1,4 @@ +test('T15038', + [reqlib('containers'), reqlib('ghc-prim'), reqlib('primitive')], + run_command, + ['$MAKE -s --no-print-directory T15038']) diff --git a/testsuite/tests/codeGen/should_run/T15038/common/Data/Trie/Naive.hs b/testsuite/tests/codeGen/should_run/T15038/common/Data/Trie/Naive.hs new file mode 100644 index 0000000000..a138615b2d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/common/Data/Trie/Naive.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Data.Trie.Naive + ( Trie + , singleton + , singletonString + , lookup + , parser + , fromList + , fromListAppend + , fromStringList + ) where + +import Prelude hiding (lookup) + +import Data.Semigroup (Semigroup) +import Data.Word (Word8) +import Data.Map (Map) +import Data.Bifunctor (second) +import Packed.Bytes (Bytes) +import qualified Data.Char +import qualified GHC.OldList as L +import qualified Packed.Bytes.Parser as P +import qualified Packed.Bytes as B +import qualified Data.Semigroup as SG +import qualified Data.Map.Strict as M + +data Trie a = Trie (Maybe a) (Map Word8 (Trie a)) + deriving (Functor) + +instance Semigroup a => Semigroup (Trie a) where + (<>) = append + +instance Semigroup a => Monoid (Trie a) where + mempty = Trie Nothing M.empty + mappend = (SG.<>) + +append :: Semigroup a => Trie a -> Trie a -> Trie a +append (Trie v1 m1) (Trie v2 m2) = Trie + (SG.getOption (SG.Option v1 SG.<> SG.Option v2)) + (M.unionWith append m1 m2) + +singleton :: Bytes -> a -> Trie a +singleton k v = B.foldr (\b r -> Trie Nothing (M.singleton b r)) (Trie (Just v) M.empty) k + +singletonString :: String -> a -> Trie a +singletonString k v = L.foldr (\c r -> Trie Nothing (M.singleton (c2w c) r)) (Trie (Just v) M.empty) k + +lookup :: Bytes -> Trie a -> Maybe a +lookup k t0 = case B.foldr lookupStep (Just t0) k of + Nothing -> Nothing + Just (Trie v _) -> v + +lookupStep :: Word8 -> Maybe (Trie a) -> Maybe (Trie a) +lookupStep w Nothing = Nothing +lookupStep w (Just (Trie _ m)) = M.lookup w m + +parser :: Trie (P.Parser a) -> P.Parser a +parser (Trie mp m) = case mp of + Just p -> p + Nothing -> do + w <- P.any + case M.lookup w m of + Nothing -> P.failure + Just t -> parser t + +fromList :: [(Bytes,a)] -> Trie a +fromList = fmap SG.getFirst . fromListAppend . map (second SG.First) + +fromListAppend :: Semigroup a => [(Bytes,a)] -> Trie a +fromListAppend = foldMap (uncurry singleton) + +fromStringList :: [(String,a)] -> Trie a +fromStringList = fmap SG.getFirst . fromStringListAppend . map (second SG.First) + +fromStringListAppend :: Semigroup a => [(String,a)] -> Trie a +fromStringListAppend = foldMap (uncurry singletonString) + +c2w :: Char -> Word8 +c2w = fromIntegral . Data.Char.ord diff --git a/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes.hs b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes.hs new file mode 100644 index 0000000000..224e03f75d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC + -fno-warn-unsafe + -fno-warn-implicit-prelude + -fno-warn-missing-import-lists + -O2 +#-} + +module Packed.Bytes + ( Bytes(..) + , pack + , unpack + , length + -- * Folds + , foldr + -- * Unsliced Byte Arrays + , fromByteArray + ) where + +import Prelude hiding (take,length,replicate,drop,null,concat,foldr) + +import Data.Primitive (ByteArray(..)) +import Data.Word (Word8) +import Control.Monad.ST (runST, ST) +import qualified Data.Primitive as PM +import qualified GHC.OldList as L + +data Bytes = Bytes + {-# UNPACK #-} !ByteArray -- payload + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + +instance Show Bytes where + show x = "pack " ++ show (unpack x) + +pack :: [Word8] -> Bytes +pack bs = let arr = packByteArray bs in Bytes arr 0 (lengthByteArray arr) + +unpack :: Bytes -> [Word8] +unpack (Bytes arr off len) = go off + where + go :: Int -> [Word8] + go !ix = if ix < len + off + then PM.indexByteArray arr ix : go (ix + 1) + else [] + +fromByteArray :: ByteArray -> Bytes +fromByteArray ba = Bytes ba 0 (lengthByteArray ba) + +length :: Bytes -> Int +length (Bytes _ _ len) = len + +foldr :: (Word8 -> a -> a) -> a -> Bytes -> a +foldr f a0 (Bytes arr off0 len) = go off0 where + !end = off0 + len + go !ix = if ix < end + then f (PM.indexByteArray arr ix) (go (ix + 1)) + else a0 + +packByteArray :: [Word8] -> ByteArray +packByteArray ws0 = runST $ do + marr <- PM.newByteArray (L.length ws0) + let go [] !_ = return () + go (w : ws) !ix = PM.writeByteArray marr ix w >> go ws (ix + 1) + go ws0 0 + PM.unsafeFreezeByteArray marr + +unpackByteArray :: ByteArray -> [Word8] +unpackByteArray arr = go 0 where + go :: Int -> [Word8] + go !ix = if ix < lengthByteArray arr + then PM.indexByteArray arr ix : go (ix + 1) + else [] + +lengthByteArray :: ByteArray -> Int +lengthByteArray = PM.sizeofByteArray diff --git a/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Parser.hs b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Parser.hs new file mode 100644 index 0000000000..3f9c42ad52 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Parser.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC + -Weverything + -fno-warn-unsafe + -fno-warn-implicit-prelude + -fno-warn-missing-import-lists + -fno-warn-noncanonical-monoid-instances + -O2 +#-} + +module Packed.Bytes.Parser + ( Parser(..) + , Result(..) + , Leftovers(..) + , parseStreamST + , any + , failure + ) where + +import Control.Applicative +import Data.Primitive (ByteArray(..)) +import GHC.Int (Int(I#)) +import GHC.ST (ST(..),runST) +import GHC.Types (TYPE) +import GHC.Word (Word8(W8#)) +import Packed.Bytes (Bytes(..)) +import Packed.Bytes.Stream.ST (ByteStream(..)) +import Prelude hiding (any,replicate) + +import qualified Data.Primitive as PM +import qualified Control.Monad + +import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#) + +type Bytes# = (# ByteArray#, Int#, Int# #) +type Maybe# (a :: TYPE r) = (# (# #) | a #) +type Leftovers# s = (# Bytes# , ByteStream s #) +type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #) + +data Result s a = Result + { resultLeftovers :: !(Maybe (Leftovers s)) + , resultValue :: !(Maybe a) + } + +data Leftovers s = Leftovers + { leftoversChunk :: {-# UNPACK #-} !Bytes + -- ^ The last chunk pulled from the stream + , leftoversStream :: ByteStream s + -- ^ The remaining stream + } + +data PureResult a = PureResult + { pureResultLeftovers :: {-# UNPACK #-} !Bytes + , pureResultValue :: !(Maybe a) + } deriving (Show) + +emptyByteArray :: ByteArray +emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray) + +parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a) +parseStreamST stream (Parser f) = ST $ \s0 -> + case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of + (# s1, r #) -> (# s1, boxResult r #) + +boxResult :: Result# s a -> Result s a +boxResult (# leftovers, val #) = case val of + (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing + (# | a #) -> Result (boxLeftovers leftovers) (Just a) + +boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s) +boxLeftovers (# (# #) | #) = Nothing +boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream) + +instance Functor Parser where + fmap = mapParser + +-- Remember to write liftA2 by hand at some point. +instance Applicative Parser where + pure = pureParser + (<*>) = Control.Monad.ap + +instance Monad Parser where + return = pure + (>>=) = bindLifted + +newtype Parser a = Parser + { getParser :: forall s. + Maybe# (Leftovers# s) + -> State# s + -> (# State# s, Result# s a #) + } + +nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #) +nextNonEmpty (ByteStream f) s0 = case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, (# (# #) | #) #) + (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of + 0# -> nextNonEmpty stream s1 + _ -> (# s1, (# | (# theBytes, stream #) #) #) + +withNonEmpty :: forall s b. + Maybe# (Leftovers# s) + -> State# s + -> (State# s -> (# State# s, Result# s b #)) + -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #)) + -- The first argument is a Word8, not a full machine word. + -- The second argument is the complete,non-empty chunk + -- with the head byte still intact. + -> (# State# s, Result# s b #) +withNonEmpty (# (# #) | #) s0 g _ = g s0 +withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of + 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0 + _ -> case nextNonEmpty stream0 s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> g s1 + (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) -> + f (indexWord8Array# arr1 off1) bytes1 stream1 s1 + +-- | Consume the next byte from the input. +any :: Parser Word8 +any = Parser go where + go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #) + go m s0 = withNonEmpty m s0 + (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #)) + (\theByte theBytes stream s -> + (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #) + ) + +-- TODO: improve this +mapParser :: (a -> b) -> Parser a -> Parser b +mapParser f p = bindLifted p (pureParser . f) + +pureParser :: a -> Parser a +pureParser a = Parser $ \leftovers0 s0 -> + (# s0, (# leftovers0, (# | a #) #) #) + +bindLifted :: Parser a -> (a -> Parser b) -> Parser b +bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of + (# s1, (# leftovers1, val #) #) -> case val of + (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #) + (# | x #) -> case g x of + Parser k -> k leftovers1 s1 + +-- This assumes that the Bytes is longer than the index. It also does +-- not eliminate zero-length references to byte arrays. +unsafeDrop# :: Int# -> Bytes# -> Bytes# +unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #) + +unboxByteArray :: ByteArray -> ByteArray# +unboxByteArray (ByteArray arr) = arr + +boxBytes :: Bytes# -> Bytes +boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) + +failure :: Parser a +failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #)) diff --git a/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Stream/ST.hs b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Stream/ST.hs new file mode 100644 index 0000000000..ffba9c2596 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/src/Packed/Bytes/Stream/ST.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} + +{-# OPTIONS_GHC -O2 #-} + +module Packed.Bytes.Stream.ST + ( ByteStream(..) + , empty + , unpack + , fromBytes + ) where + +import Data.Primitive (Array,ByteArray(..)) +import Data.Semigroup (Semigroup) +import Data.Word (Word8) +import GHC.Exts (RealWorld,State#,Int#,ByteArray#) +import GHC.Int (Int(I#)) +import GHC.ST (ST(..)) +import Packed.Bytes (Bytes(..)) +import System.IO (Handle) +import qualified Data.Primitive as PM +import qualified Data.Semigroup as SG +import qualified Packed.Bytes as B + +type Bytes# = (# ByteArray#, Int#, Int# #) + +newtype ByteStream s = ByteStream + (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) ) + +fromBytes :: Bytes -> ByteStream s +fromBytes b = ByteStream + (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #)) + +nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s)) +nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, Nothing #) + (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #) + +empty :: ByteStream s +empty = ByteStream (\s -> (# s, (# (# #) | #) #) ) + +boxBytes :: Bytes# -> Bytes +boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) + +unboxBytes :: Bytes -> Bytes# +unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) + +unpack :: ByteStream s -> ST s [Word8] +unpack stream = ST (unpackInternal stream) + +unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #) +unpackInternal (ByteStream f) s0 = case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, [] #) + (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of + (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #) diff --git a/testsuite/tests/codeGen/should_run/T15038/test/Main.hs b/testsuite/tests/codeGen/should_run/T15038/test/Main.hs new file mode 100644 index 0000000000..56acd042db --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/test/Main.hs @@ -0,0 +1,4 @@ +import qualified Parser as Parser + +main :: IO () +main = print (iterate Parser.byteParserBadOnce 5 !! 100000) diff --git a/testsuite/tests/codeGen/should_run/T15038/test/Parser.hs b/testsuite/tests/codeGen/should_run/T15038/test/Parser.hs new file mode 100644 index 0000000000..70f9f3336b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/T15038/test/Parser.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC -Wall #-} + +module Parser + ( byteParserBadOnce + ) where + +import Control.Monad.ST (runST) +import Data.Word (Word8) +import Packed.Bytes (Bytes) +import Packed.Bytes.Parser (Parser) +import Packed.Bytes.Stream.ST (ByteStream) +import qualified Data.Char +import qualified Packed.Bytes as B +import qualified Packed.Bytes.Parser as P +import qualified Packed.Bytes.Stream.ST as Stream + +-- from common directory +import qualified Data.Trie.Naive as Naive + +snmptrapdNaive :: Naive.Trie (Parser Word) +snmptrapdNaive = Naive.fromStringList + [ ("STRING: ", P.any >>= \_ -> return 5) + ] + +runExampleParser :: Parser a -> (forall s. ByteStream s) -> (Maybe a, Maybe String) +runExampleParser parser stream = runST $ do + P.Result mleftovers r <- P.parseStreamST stream parser + mextra <- case mleftovers of + Nothing -> return Nothing + Just (P.Leftovers chunk remainingStream) -> do + bs <- Stream.unpack remainingStream + return (Just (map word8ToChar (B.unpack chunk ++ bs))) + return (r,mextra) + +byteParserBadOnce :: Int -> Int +byteParserBadOnce x = do + let sample = ("STRING: _6_ " ++ show x) + stream = Stream.fromBytes (s2b sample) + expected = 6 + (r,mextra) = runExampleParser (Naive.parser snmptrapdNaive) stream + a1 = if Nothing == mextra then 1 else 0 + a2 = if Just expected == r then 1 else 0 + in a1 + (a2 + x) + +s2b :: String -> Bytes +s2b = B.pack . map charToWord8 + +charToWord8 :: Char -> Word8 +charToWord8 = fromIntegral . Data.Char.ord + +word8ToChar :: Word8 -> Char +word8ToChar = Data.Char.chr . fromIntegral diff --git a/testsuite/tests/codeGen/should_run/T5129.hs b/testsuite/tests/codeGen/should_run/T5129.hs index 6bc1912754..2808f54eae 100644 --- a/testsuite/tests/codeGen/should_run/T5129.hs +++ b/testsuite/tests/codeGen/should_run/T5129.hs @@ -10,12 +10,13 @@ throwIfNegative n | n < 0 = error "negative" data HUnitFailure = HUnitFailure String deriving (Show,Typeable) instance Exception HUnitFailure +assertFailure :: String -> a -- Not an IO function! assertFailure msg = E.throw (HUnitFailure msg) -case_negative = - handleJust errorCalls (const $ return ()) $ do - evaluate $ throwIfNegative (-1) - assertFailure "must throw when given a negative number" +main :: IO () +main = + handleJust errorCalls (const (return ())) (do + evaluate (throwIfNegative (-1)) -- Pure expression evaluated in IO + assertFailure "must throw when given a negative number") where errorCalls (ErrorCall _) = Just () -main = case_negative diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 6318341abb..49592951bc 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -77,6 +77,8 @@ test('cgrun069', omit_ways(['ghci']), multi_compile_and_run, test('cgrun070', normal, compile_and_run, ['']) test('cgrun071', normal, compile_and_run, ['']) test('cgrun072', normal, compile_and_run, ['']) +test('cgrun075', normal, compile_and_run, ['']) +test('cgrun076', normal, compile_and_run, ['']) test('T1852', normal, compile_and_run, ['']) test('T1861', extra_run_opts('0'), compile_and_run, ['']) @@ -88,11 +90,16 @@ test('T3677', extra_run_opts('+RTS -K8k -RTS'), compile_and_run, ['']) test('T4441', normal, compile_and_run, ['']) test('T5149', omit_ways(['ghci']), multi_compile_and_run, ['T5149', [('T5149_cmm.cmm', '')], '']) -test('T5129', normal, compile_and_run, ['']) +test('T5129', + # The bug is in simplifier when run with -O1 and above, so only run it + # optimised, using any backend. + only_ways(['optasm']), + compile_and_run, ['']) test('T5626', exit_code(1), compile_and_run, ['']) test('T5747', when(arch('i386'), extra_hc_opts('-msse2')), compile_and_run, ['-O2']) test('T5785', normal, compile_and_run, ['']) test('setByteArray', normal, compile_and_run, ['']) +test('compareByteArrays', normal, compile_and_run, ['']) test('T6146', normal, compile_and_run, ['']) test('T5900', normal, compile_and_run, ['']) @@ -148,7 +155,7 @@ test('PopCnt', omit_ways(['ghci']), multi_compile_and_run, ['PopCnt', [('PopCnt_cmm.cmm', '')], '']) test('T12059', normal, compile_and_run, ['']) test('T12433', normal, compile_and_run, ['']) -test('T12622', expect_broken_for(13481, ['ghci']), multimod_compile_and_run, ['T12622', '-O']) +test('T12622', normal, multimod_compile_and_run, ['T12622', '-O']) test('T12757', normal, compile_and_run, ['']) test('T12855', normal, compile_and_run, ['']) test('T9577', [ unless(arch('x86_64') or arch('i386'),skip), @@ -158,3 +165,12 @@ test('T9577', [ unless(arch('x86_64') or arch('i386'),skip), test('T13425', normal, compile_and_run, ['-O']) test('castFloatWord', normal, compile_and_run, ['-dcmm-lint']) +test('T13825-unit', + extra_run_opts('"' + config.libdir + '"'), + compile_and_run, + ['-package ghc']) +test('T14619', normal, compile_and_run, ['']) +test('T14754', normal, compile_and_run, ['']) +test('T14346', only_ways(['threaded1','threaded2']), compile_and_run, ['-O -threaded']) +test('T14251', [expect_broken_for(14251, ['optllvm'])], + compile_and_run, ['']) diff --git a/testsuite/tests/codeGen/should_run/cgrun075.hs b/testsuite/tests/codeGen/should_run/cgrun075.hs new file mode 100644 index 0000000000..09e35b4d8a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun075.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} + +module Main ( main ) where + +import Data.Bits +import GHC.Int +import GHC.Prim +import GHC.Word +import Data.Int +import Data.Word + +#include "MachDeps.h" + +main = putStr + ( test_pdep ++ "\n" + ++ test_pdep8 ++ "\n" + ++ test_pdep16 ++ "\n" + ++ test_pdep32 ++ "\n" + ++ test_pdep64 ++ "\n" + ++ "\n" + ) + +class Pdep a where + pdep :: a -> a -> a + +instance Pdep Word where + pdep (W# src#) (W# mask#) = W# (pdep# src# mask#) + +instance Pdep Word8 where + pdep (W8# src#) (W8# mask#) = W8# (pdep8# src# mask#) + +instance Pdep Word16 where + pdep (W16# src#) (W16# mask#) = W16# (pdep16# src# mask#) + +instance Pdep Word32 where + pdep (W32# src#) (W32# mask#) = W32# (pdep32# src# mask#) + +instance Pdep Word64 where + pdep (W64# src#) (W64# mask#) = W64# (pdep64# src# mask#) + +class SlowPdep a where + slowPdep :: a -> a -> a + +instance SlowPdep Word where + slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +instance SlowPdep Word8 where + slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +instance SlowPdep Word16 where + slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +instance SlowPdep Word32 where + slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +instance SlowPdep Word64 where + slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +slowPdep64 :: Word64 -> Word64 -> Word64 +slowPdep64 = slowPdep64' 0 + +slowPdep32 :: Word32 -> Word32 -> Word32 +slowPdep32 s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m)) + +lsb :: Word64 -> Word64 +lsb src = fromIntegral ((fromIntegral (src `shiftL` 63) :: Int64) `shiftR` 63) + +slowPdep64' :: Word64 -> Word64 -> Word64 -> Word64 +slowPdep64' result src mask = if lowest /= 0 + then slowPdep64' newResult (src `shiftR` 1) (mask .&. complement lowest) + else result + where lowest = (-mask) .&. mask + newResult = (result .|. ((lsb src) .&. lowest)) + +test_pdep = test (0 :: Word ) pdep slowPdep +test_pdep8 = test (0 :: Word8 ) pdep slowPdep +test_pdep16 = test (0 :: Word16) pdep slowPdep +test_pdep32 = test (0 :: Word32) pdep slowPdep +test_pdep64 = test (0 :: Word64) pdep slowPdep + +mask n = (2 ^ n) - 1 + +fst4 :: (a, b, c, d) -> a +fst4 (a, _, _, _) = a + +runCase :: Eq a + => (a -> a -> a) + -> (a -> a -> a) + -> (a, a) + -> (Bool, a, a, (a, a)) +runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y)) + +test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String +test _ fast slow = case failing of + [] -> "OK" + ((_, e, a, i):xs) -> + "FAIL\n" ++ " Input: " ++ show i ++ "\nExpected: " ++ show e ++ + "\n Actual: " ++ show a + where failing = dropWhile fst4 . map (runCase fast slow) $ cases + cases = (,) <$> numbers <*> numbers + -- 10 random numbers +#if SIZEOF_HSWORD == 4 + numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062 + , 65945563 , 1521588071, 791321966 , 1355466914, 2284998160 + ] +#elif SIZEOF_HSWORD == 8 + numbers = [ 11004539497957619752, 5625461252166958202 + , 1799960778872209546 , 16979826074020750638 + , 12789915432197771481, 11680809699809094550 + , 13208678822802632247, 13794454868797172383 + , 13364728999716654549, 17516539991479925226 + ] +#else +# error Unexpected word size +#endif diff --git a/testsuite/tests/codeGen/should_run/cgrun075.stdout b/testsuite/tests/codeGen/should_run/cgrun075.stdout new file mode 100644 index 0000000000..e22e2cd950 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun075.stdout @@ -0,0 +1,6 @@ +OK +OK +OK +OK +OK + diff --git a/testsuite/tests/codeGen/should_run/cgrun076.hs b/testsuite/tests/codeGen/should_run/cgrun076.hs new file mode 100644 index 0000000000..7fa42d74e0 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun076.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} + +module Main ( main ) where + +import Data.Bits +import GHC.Int +import GHC.Prim +import GHC.Word +import Data.Int +import Data.Word + +#include "MachDeps.h" + +main = putStr + ( test_pext ++ "\n" + ++ test_pext8 ++ "\n" + ++ test_pext16 ++ "\n" + ++ test_pext32 ++ "\n" + ++ test_pext64 ++ "\n" + ++ "\n" + ) + +class Pext a where + pext :: a -> a -> a + +instance Pext Word where + pext (W# src#) (W# mask#) = W# (pext# src# mask#) + +instance Pext Word8 where + pext (W8# src#) (W8# mask#) = W8# (pext8# src# mask#) + +instance Pext Word16 where + pext (W16# src#) (W16# mask#) = W16# (pext16# src# mask#) + +instance Pext Word32 where + pext (W32# src#) (W32# mask#) = W32# (pext32# src# mask#) + +instance Pext Word64 where + pext (W64# src#) (W64# mask#) = W64# (pext64# src# mask#) + +class SlowPext a where + slowPext :: a -> a -> a + +instance SlowPext Word where + slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +instance SlowPext Word8 where + slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +instance SlowPext Word16 where + slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +instance SlowPext Word32 where + slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +instance SlowPext Word64 where + slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +slowPext64 :: Word64 -> Word64 -> Word64 +slowPext64 = slowPext64' 0 0 0 + +slowPext32 :: Word32 -> Word32 -> Word32 +slowPext32 s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m)) + +slowPext64' :: Word64 -> Int -> Int -> Word64 -> Word64 -> Word64 +slowPext64' result offset index src mask = if index /= 64 + then if maskBit /= 0 + then slowPext64' nextResult (offset + 1) (index + 1) src mask + else slowPext64' result offset (index + 1) src mask + else result + where srcBit = (src `shiftR` index) .&. 1 + maskBit = (mask `shiftR` index) .&. 1 + nextResult = result .|. (srcBit `shiftL` offset) + +test_pext = test (0 :: Word ) pext slowPext +test_pext8 = test (0 :: Word8 ) pext slowPext +test_pext16 = test (0 :: Word16) pext slowPext +test_pext32 = test (0 :: Word32) pext slowPext +test_pext64 = test (0 :: Word64) pext slowPext + +mask n = (2 ^ n) - 1 + +fst4 :: (a, b, c, d) -> a +fst4 (a, _, _, _) = a + +runCase :: Eq a + => (a -> a -> a) + -> (a -> a -> a) + -> (a, a) + -> (Bool, a, a, (a, a)) +runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y)) + +test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String +test _ fast slow = case failing of + [] -> "OK" + ((_, e, a, i):xs) -> + "FAIL\n" ++ " Input: " ++ show i ++ "\nExpected: " ++ show e ++ + "\n Actual: " ++ show a + where failing = dropWhile fst4 . map (runCase fast slow) $ cases + cases = (,) <$> numbers <*> numbers + -- 10 random numbers +#if SIZEOF_HSWORD == 4 + numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062 + , 65945563 , 1521588071, 791321966 , 1355466914, 2284998160 + ] +#elif SIZEOF_HSWORD == 8 + numbers = [ 11004539497957619752, 5625461252166958202 + , 1799960778872209546 , 16979826074020750638 + , 12789915432197771481, 11680809699809094550 + , 13208678822802632247, 13794454868797172383 + , 13364728999716654549, 17516539991479925226 + ] +#else +# error Unexpected word size +#endif diff --git a/testsuite/tests/codeGen/should_run/cgrun076.stdout b/testsuite/tests/codeGen/should_run/cgrun076.stdout new file mode 100644 index 0000000000..e22e2cd950 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun076.stdout @@ -0,0 +1,6 @@ +OK +OK +OK +OK +OK + diff --git a/testsuite/tests/codeGen/should_run/compareByteArrays.hs b/testsuite/tests/codeGen/should_run/compareByteArrays.hs new file mode 100644 index 0000000000..e08328d27d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/compareByteArrays.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} + +-- exercise the 'compareByteArray#' primitive + +module Main (main) where + +import Control.Monad +import Control.Monad.ST +import Data.List +import GHC.Exts (Int (..)) +import GHC.Prim +import GHC.ST (ST (ST)) +import GHC.Word (Word8 (..)) +import Text.Printf + +data BA = BA# ByteArray# + +instance Show BA where + show xs = "[" ++ intercalate "," (map (printf "0x%02x") (unpack xs)) ++ "]" + +instance Eq BA where + x == y = eqByteArray x 0 (sizeofByteArray x) y 0 (sizeofByteArray y) + +instance Ord BA where + compare x y = ordByteArray x 0 (sizeofByteArray x) y 0 (sizeofByteArray y) + +compareByteArrays :: BA -> Int -> BA -> Int -> Int -> Int +compareByteArrays (BA# ba1#) (I# ofs1#) (BA# ba2#) (I# ofs2#) (I# n#) + = I# (compareByteArrays# ba1# ofs1# ba2# ofs2# n#) + +{- +copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () +copyByteArray (BA# src#) (I# srcOfs#) (MBA# dest#) (I# destOfs#) (I# n#) + = ST $ \s -> case copyByteArray# src# srcOfs# dest# destOfs# n# s of + s' -> (# s', () #) +-} + +indexWord8Array :: BA -> Int -> Word8 +indexWord8Array (BA# ba#) (I# i#) + = W8# (indexWord8Array# ba# i#) + +sizeofByteArray :: BA -> Int +sizeofByteArray (BA# ba#) = I# (sizeofByteArray# ba#) + + +data MBA s = MBA# (MutableByteArray# s) + +newByteArray :: Int -> ST s (MBA s) +newByteArray (I# n#) + = ST $ \s -> case newByteArray# n# s of + (# s', mba# #) -> (# s', MBA# mba# #) + +writeWord8Array :: MBA s -> Int -> Word8 -> ST s () +writeWord8Array (MBA# mba#) (I# i#) (W8# j#) + = ST $ \s -> case writeWord8Array# mba# i# j# s of + s' -> (# s', () #) + +unsafeFreezeByteArray :: MBA s -> ST s BA +unsafeFreezeByteArray (MBA# mba#) + = ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', BA# ba# #) + +---------------------------------------------------------------------------- +-- high-level operations + +createByteArray :: Int -> (forall s. MBA s -> ST s ()) -> BA +createByteArray n go = runST $ do + mba <- newByteArray n + go mba + unsafeFreezeByteArray mba + +pack :: [Word8] -> BA +pack xs = createByteArray (length xs) $ \mba -> do + let go _ [] = pure () + go i (y:ys) = do + writeWord8Array mba i y + go (i+1) ys + go 0 xs + +unpack :: BA -> [Word8] +unpack ba = go 0 + where + go i | i < sz = indexWord8Array ba i : go (i+1) + | otherwise = [] + sz = sizeofByteArray ba + +eqByteArray :: BA -> Int -> Int -> BA -> Int -> Int -> Bool +eqByteArray ba1 ofs1 n1 ba2 ofs2 n2 + | n1 /= n2 = False + | n1 == 0 = True + | otherwise = compareByteArrays ba1 ofs1 ba2 ofs2 n1 == 0 + +ordByteArray :: BA -> Int -> Int -> BA -> Int -> Int -> Ordering +ordByteArray ba1 ofs1 n1 ba2 ofs2 n2 + | n == 0 = compare n1 n2 + | otherwise = case compareByteArrays ba1 ofs1 ba2 ofs2 n of + r | r < 0 -> LT + | r > 0 -> GT + | n1 < n2 -> LT + | n1 > n2 -> GT + | otherwise -> EQ + where + n = n1 `min` n2 + +main :: IO () +main = do + putStrLn "BEGIN" + -- a couple of low-level tests + print (compareByteArrays s1 0 s2 0 4 `compare` 0) + print (compareByteArrays s2 0 s1 0 4 `compare` 0) + print (compareByteArrays s1 0 s2 0 3 `compare` 0) + print (compareByteArrays s1 0 s2 1 3 `compare` 0) + print (compareByteArrays s1 3 s2 2 1 `compare` 0) + + forM_ [(s1,s1),(s1,s2),(s2,s1),(s2,s2)] $ \(x,y) -> do + print (x == y, compare x y) + + -- realistic test + print (sort (map pack strs) == map pack (sort strs)) + + -- brute-force test + forM_ [1..15] $ \n -> do + forM_ [0..rnglen-(n+1)] $ \j -> do + forM_ [0..rnglen-(n+1)] $ \k -> do + let iut = compareByteArrays srng j srng k n `compare` 0 + ref = (take n (drop j rng) `compare` take n (drop k rng)) + unless (iut == ref) $ + print ("FAIL",n,j,k,iut,ref) + + putStrLn "END" + where + s1, s2 :: BA + s1 = pack [0xca,0xfe,0xba,0xbe] + s2 = pack [0xde,0xad,0xbe,0xef] + + strs = let go i xs = case splitAt (i `mod` 5) xs of + ([],[]) -> [] + (y,ys) -> y : go (i+1) ys + in go 1 rng + + srng = pack rng + + rnglen = length rng + + rng :: [Word8] + rng = [ 0xc1, 0x60, 0x31, 0xb6, 0x46, 0x81, 0xa7, 0xc6, 0xa8, 0xf4, 0x1e, 0x5d, 0xb7, 0x7c, 0x0b, 0xcd + , 0x10, 0xfa, 0xe3, 0xdd, 0xf4, 0x26, 0xf9, 0x50, 0x4b, 0x9c, 0xdf, 0xc4, 0xda, 0xca, 0xc1, 0x60 + , 0x91, 0xf8, 0x70, 0x1a, 0x53, 0x89, 0xf1, 0xd9, 0xee, 0xff, 0x52, 0xb8, 0x1c, 0x5e, 0x25, 0x69 + , 0xd1, 0xa1, 0x08, 0x47, 0x93, 0x89, 0x71, 0x7a, 0xe4, 0x56, 0x24, 0x1b, 0xa1, 0x43, 0x63, 0xc0 + , 0x4d, 0xec, 0x93, 0x30, 0xb7, 0x98, 0x19, 0x23, 0x4e, 0x00, 0x76, 0x7e, 0xf4, 0xcc, 0x8b, 0x92 + , 0x19, 0xc5, 0x3d, 0xf4, 0xa0, 0x4f, 0xe3, 0x64, 0x1b, 0x4e, 0x01, 0xc9, 0xfc, 0x47, 0x3e, 0x16 + , 0xa4, 0x78, 0xdd, 0x12, 0x20, 0xa6, 0x0b, 0xcd, 0x82, 0x06, 0xd0, 0x2a, 0x19, 0x2d, 0x2f, 0xf2 + , 0x8a, 0xf0, 0xc2, 0x2d, 0x0e, 0xfb, 0x39, 0x55, 0xb2, 0xfb, 0x6e, 0xd0, 0xfa, 0xf0, 0x87, 0x57 + , 0x93, 0xa3, 0xae, 0x36, 0x1f, 0xcf, 0x91, 0x45, 0x44, 0x11, 0x62, 0x7f, 0x18, 0x9a, 0xcb, 0x54 + , 0x78, 0x3c, 0x04, 0xbe, 0x3e, 0xd4, 0x2c, 0xbf, 0x73, 0x38, 0x9e, 0xf5, 0xc9, 0xbe, 0xd9, 0xf8 + , 0xe5, 0xf5, 0x41, 0xbb, 0x84, 0x03, 0x2c, 0xe2, 0x0d, 0xe5, 0x8b, 0x1c, 0x75, 0xf7, 0x4c, 0x49 + , 0xfe, 0xac, 0x9f, 0xf4, 0x36, 0xf2, 0xba, 0x5f, 0xc0, 0xda, 0x24, 0xfc, 0x10, 0x61, 0xf0, 0xb6 + , 0xa7, 0xc7, 0xba, 0xc6, 0xb0, 0x41, 0x04, 0x8c, 0xd0, 0xe8, 0x48, 0x41, 0x38, 0xa4, 0x84, 0x21 + , 0xb6, 0xb1, 0x21, 0x33, 0x58, 0xf2, 0xa5, 0xe5, 0x73, 0xf2, 0xd7, 0xbc, 0xc7, 0x7e, 0x86, 0xee + , 0x81, 0xb1, 0xcd, 0x42, 0xc0, 0x2c, 0xd0, 0xa0, 0x8d, 0xb5, 0x4a, 0x5b, 0xc1, 0xfe, 0xcc, 0x92 + , 0x59, 0xf4, 0x71, 0x96, 0x58, 0x6a, 0xb6, 0xa2, 0xf7, 0x67, 0x76, 0x01, 0xc5, 0x8b, 0xc9, 0x6f + , 0x38, 0x93, 0xf3, 0xaa, 0x89, 0xf7, 0xb2, 0x2a, 0x0f, 0x19, 0x7b, 0x48, 0xbe, 0x86, 0x37, 0xd1 + , 0x30, 0xfa, 0xce, 0x72, 0xf4, 0x25, 0x64, 0xee, 0xde, 0x3a, 0x5c, 0x02, 0x32, 0xe6, 0x31, 0x3a + , 0x4b, 0x18, 0x47, 0x30, 0xa4, 0x2c, 0xf8, 0x4d, 0xc5, 0xee, 0x0b, 0x9c, 0x75, 0x43, 0x2a, 0xf9 + ] diff --git a/testsuite/tests/codeGen/should_run/compareByteArrays.stdout b/testsuite/tests/codeGen/should_run/compareByteArrays.stdout new file mode 100644 index 0000000000..eaaa05ef44 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/compareByteArrays.stdout @@ -0,0 +1,12 @@ +BEGIN +LT +GT +LT +GT +EQ +(True,EQ) +(False,LT) +(False,GT) +(True,EQ) +True +END |