Fix segmentation fault when .prof file not writeable

There are two ways to do retainer profiling. Quoting from the user's guide:
  1. `+RTS -hr` "Breaks down the graph by retainer set"
  2. `+RTS -hr<cc> -h<x>`, where `-h<x>` is one of normal heap profiling
     break-down options (e.g. `-hc`), and `-hr<cc> means "Restrict the
     profile to closures with retainer sets containing cost-centre
     stacks with one of the specified cost centres at the top."

Retainer profiling writes to a .hp file, like the other heap profiling
options, but also to a .prof file. Therefore, when the .prof file is not
writeable for whatever reason, retainer profiling should be turned off
completely.

This worked ok when running the program with `+RTS -hr` (option 1), but a
segfault would occur when using `+RTS -hr<cc> -h<x>`, with `x!=r` (option 2).

This commit fixes that.

Reviewed by: bgamari

Differential Revision: https://phabricator.haskell.org/D1849

GHC Trac Issues: #11489

5 files changed, 18 insertions, 2 deletions

diff --git a/testsuite/tests/profiling/should_run/Makefile b/testsuite/tests/profiling/should_run/Makefile
index 577fc3491f..e46dd973f3 100644
--- a/testsuite/tests/profiling/should_run/Makefile
+++ b/testsuite/tests/profiling/should_run/Makefile
@@ -23,3 +23,13 @@ scc001:
 	$(call scc001Rule,-O0)
 	$(call scc001Rule,-O)
 
+.PHONY: T11489
+T11489:
+	$(RM) T11489
+	touch T11489.prof
+	chmod -w T11489.prof
+	"$(TEST_HC)" -v0 -prof T11489.hs
+	# Should print some message about not being to open the .prof file,
+	# then continue to run and exit normally.
+	# Caused a segmentation fault in GHC <= 7.10.3
+	./T11489 +RTS -hr{} -hc
diff --git a/testsuite/tests/profiling/should_run/T11489.hs b/testsuite/tests/profiling/should_run/T11489.hs
new file mode 100644
index 0000000000..b3549c2fe3
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11489.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/testsuite/tests/profiling/should_run/T11489.stderr b/testsuite/tests/profiling/should_run/T11489.stderr
new file mode 100644
index 0000000000..4f19dd9094
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11489.stderr
@@ -0,0 +1 @@
+Can't open profiling report file T11489.prof
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 7804d46670..ca37fe5704 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -134,3 +134,8 @@ test('T5363',
 test('profinline001',
     [ req_profiling, extra_ways(['prof']), only_ways(prof_ways) ],
     compile_and_run, [''])
+
+test('T11489', [
+     req_profiling,
+     extra_clean(['T11489.prof', 'T11489.hp']),
+     ], run_command, ['$MAKE -s --no-print-directory T11489'])
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index c88bd62267..951acbe4b3 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -55,8 +55,7 @@ test('divbyzero',
 
 test('outofmem', when(opsys('darwin'), skip),
                  run_command, ['$MAKE -s --no-print-directory outofmem'])
-test('outofmem2', extra_run_opts('+RTS -M5m -RTS'),
-                  run_command, ['$MAKE -s --no-print-directory outofmem2'])
+test('outofmem2', normal, run_command, ['$MAKE -s --no-print-directory outofmem2'])
 
 test('T2047', [ignore_output, extra_run_opts('+RTS -c -RTS')],
               compile_and_run, ['-package containers'])