diff options
author | Andrew Martin <andrew.thaddeus@gmail.com> | 2019-11-13 11:20:05 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-23 13:37:01 -0400 |
commit | 49301ad6226d9a83d110bee8c419615dd94f5ded (patch) | |
tree | 907c00e2c81d1f2025ad569cedf2bc39833bcb07 /testsuite | |
parent | d830bbc9921bcc59164a0a18f0e0874ae4ce226e (diff) | |
download | haskell-49301ad6226d9a83d110bee8c419615dd94f5ded.tar.gz |
Implement cstringLength# and FinalPtr
This function and its accompanying rule resolve issue #5218.
A future PR to the bytestring library will make the internal
Data.ByteString.Internal.unsafePackAddress compute string length
with cstringLength#. This will improve the status quo because it is
eligible for constant folding.
Additionally, introduce a new data constructor to ForeignPtrContents
named FinalPtr. This additional data constructor, when used in the
IsString instance for ByteString, leads to more Core-to-Core
optimization opportunities, fewer runtime allocations, and smaller
binaries.
Also, this commit re-exports all the functions from GHC.CString
(including cstringLength#) in GHC.Exts. It also adds a new test
driver. This test driver is used to perform substring matches on Core
that is dumped after all the simplifier passes. In this commit, it is
used to check that constant folding of cstringLength# works.
Diffstat (limited to 'testsuite')
-rw-r--r-- | testsuite/.gitignore | 1 | ||||
-rw-r--r-- | testsuite/driver/testlib.py | 20 | ||||
-rw-r--r-- | testsuite/tests/primops/should_gen_core/CStringLength_core.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl | 1 | ||||
-rw-r--r-- | testsuite/tests/primops/should_gen_core/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/CStringLength.hs | 33 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/CStringLength.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/all.T | 1 |
8 files changed, 72 insertions, 0 deletions
diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 737c9f2385..76980608c2 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -43,6 +43,7 @@ Thumbs.db *.prof.sample.normalised *.run.stdout *.run.stderr +*.dump-simpl *.hp tests/**/*.ps diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index abc01fdf95..ad9c0852e9 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -1344,6 +1344,26 @@ def compile_grep_asm(name: TestName, # no problems found, this test passed return passed() +def compile_grep_core(name: TestName, + way: WayName, + extra_hc_opts: str + ) -> PassFail: + print('Compile only, extra args = ', extra_hc_opts) + result = simple_build(name + '.hs', way, '-ddump-to-file -dsuppress-all -ddump-simpl -O ' + extra_hc_opts, False, None, False, False) + + if badResult(result): + return result + + expected_pat_file = find_expected_file(name, 'substr-simpl') + actual_core_file = add_suffix(name, 'dump-simpl') + + if not grep_output(join_normalisers(normalise_errmsg), + expected_pat_file, actual_core_file): + return failBecause('simplified core mismatch') + + # no problems found, this test passed + return passed() + # ----------------------------------------------------------------------------- # Compile-and-run tests diff --git a/testsuite/tests/primops/should_gen_core/CStringLength_core.hs b/testsuite/tests/primops/should_gen_core/CStringLength_core.hs new file mode 100644 index 0000000000..98d33d5f51 --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/CStringLength_core.hs @@ -0,0 +1,11 @@ +{-# language MagicHash #-} + +module CStringLengthCore + ( ozymandias + ) where + +import GHC.Exts + +ozymandias :: Int +ozymandias = + I# (cstringLength# "I met a traveller from an antique land"#) diff --git a/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl b/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl new file mode 100644 index 0000000000..4b33d6629d --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl @@ -0,0 +1 @@ +I# 38# diff --git a/testsuite/tests/primops/should_gen_core/all.T b/testsuite/tests/primops/should_gen_core/all.T new file mode 100644 index 0000000000..d66255d8a1 --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/all.T @@ -0,0 +1 @@ +test('CStringLength_core', normal, compile_grep_core, ['']) diff --git a/testsuite/tests/primops/should_run/CStringLength.hs b/testsuite/tests/primops/should_run/CStringLength.hs new file mode 100644 index 0000000000..b580e61934 --- /dev/null +++ b/testsuite/tests/primops/should_run/CStringLength.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +import GHC.Exts + +main :: IO () +main = do + putStr "A: " + print $ + I# (cstringLength# "hello_world"#) + == + naiveStrlen "hello_world"# 0 + putStr "B: " + print $ + I# (cstringLength# "aaaaaaaaaaaaa\x00b"#) + == + naiveStrlen "aaaaaaaaaaaaa\x00b"# 0 + putStr "C: " + print $ + I# (cstringLength# "cccccccccccccccccc\x00b"#) + == + naiveStrlen "cccccccccccccccccc\x00b"# 0 + putStr "D: " + print $ + I# (cstringLength# "araña\NULb"#) + == + naiveStrlen "araña\NULb"# 0 + +naiveStrlen :: Addr# -> Int -> Int +naiveStrlen addr !n = case indexWord8OffAddr# addr 0# of + 0## -> n + _ -> naiveStrlen (plusAddr# addr 1#) (n + 1) diff --git a/testsuite/tests/primops/should_run/CStringLength.stdout b/testsuite/tests/primops/should_run/CStringLength.stdout new file mode 100644 index 0000000000..9413913c01 --- /dev/null +++ b/testsuite/tests/primops/should_run/CStringLength.stdout @@ -0,0 +1,4 @@ +A: True +B: True +C: True +D: True diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index 16579207fa..952145fd49 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -29,3 +29,4 @@ test('CmpWord16', normal, compile_and_run, ['']) test('ShrinkSmallMutableArrayA', normal, compile_and_run, ['']) test('ShrinkSmallMutableArrayB', normal, compile_and_run, ['']) test('T14664', normal, compile_and_run, ['']) +test('CStringLength', normal, compile_and_run, ['-O2']) |