Untag the potential AP_STACK in stg_getApStackValzh

If the AP_STACK has been evaluated and a GC has run, the BLACKHOLE
indirection will have been removed, and the StablePtr for the original
AP_STACK referred to be GHCi will therefore now point directly to the
value, and may be tagged. Add a hist002 test for this, and make sure
hist001 doesn't do an idle GC, so the case when it's still a BLACKHOLE
is definitely also tested.

Reviewers: austin, bgamari, erikd, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie

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

4 files changed, 62 insertions, 2 deletions

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index bcf7b62fb7..ca519b60e7 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2391,7 +2391,7 @@ stg_noDuplicatezh /* no arg list: explicit stack layout */
 
 stg_getApStackValzh ( P_ ap_stack, W_ offset )
 {
-   if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
+   if (%INFO_PTR(UNTAG(ap_stack)) == stg_AP_STACK_info) {
        return (1,StgAP_STACK_payload(ap_stack,offset));
    } else {
        return (0,ap_stack);
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index d62dcd97e0..00a39d704e 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -84,7 +84,10 @@ test('listCommand001', [extra_files(['../Test3.hs']),
                         combined_output], ghci_script, ['listCommand001.script'])
 test('listCommand002', normal, ghci_script, ['listCommand002.script'])
 
-test('hist001', extra_files(['../Test3.hs']), ghci_script, ['hist001.script'])
+test('hist001', [extra_files(['../Test3.hs']), extra_run_opts('+RTS -I0')],
+     ghci_script, ['hist001.script'])
+test('hist002', [extra_files(['../Test3.hs']), extra_run_opts('+RTS -I0')],
+     ghci_script, ['hist002.script'])
 
 test('T2740', normal, ghci_script, ['T2740.script'])
 
diff --git a/testsuite/tests/ghci.debugger/scripts/hist002.script b/testsuite/tests/ghci.debugger/scripts/hist002.script
new file mode 100644
index 0000000000..0198207192
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/hist002.script
@@ -0,0 +1,20 @@
+:l Test3.hs
+-- set a break on the [] case in map
+:b 1
+-- trace an execution
+:tr mymap (+1) [1,2]
+:hist
+:back
+:show bindings
+:back
+:show bindings
+:force _result
+-- Run a GC so the BLACKHOLE indirection for _result (the AP_STACK) is removed,
+-- ensuring _result now points directly to the value (in this case, the integer
+-- 3).  This will be tagged, so we are checking that the pointer isn't naively
+-- dereferenced to generate an unaligned load.
+System.Mem.performGC
+:back
+:forward
+-- at this point, we can't retrieve the bindings because _result (the AP_STACK)
+-- was evaluated previously.  GHCi should not crash, preferably.
diff --git a/testsuite/tests/ghci.debugger/scripts/hist002.stdout b/testsuite/tests/ghci.debugger/scripts/hist002.stdout
new file mode 100644
index 0000000000..523605b00a
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/hist002.stdout
@@ -0,0 +1,37 @@
+Breakpoint 0 activated at Test3.hs:1:14-15
+[2,3Stopped in Main.mymap, Test3.hs:1:14-15
+_result :: [a] = _
+-1  : mymap (Test3.hs:2:22-31)
+-2  : mymap (Test3.hs:2:18-20)
+-3  : mymap (Test3.hs:2:18-31)
+-4  : mymap (Test3.hs:2:22-31)
+-5  : mymap (Test3.hs:2:18-20)
+-6  : mymap (Test3.hs:2:18-31)
+<end of history>
+Logged breakpoint at Test3.hs:2:22-31
+_result :: [a]
+f :: t -> a
+xs :: [t]
+Ghci1._result :: [a] = _
+xs :: [t] = []
+f :: t -> a = _
+_result :: [a] = _
+Logged breakpoint at Test3.hs:2:18-20
+_result :: a
+f :: Integer -> a
+x :: Integer
+Ghci1._result :: [a] = _
+xs :: [t] = []
+Ghci2.f :: t -> a = _
+Ghci2._result :: [a] = _
+x :: Integer = 2
+f :: Integer -> a = _
+_result :: a = _
+_result = 3
+Logged breakpoint at Test3.hs:2:18-31
+_result :: [a]
+f :: Integer -> a
+x :: Integer
+xs :: [Integer]
+Logged breakpoint at Test3.hs:2:18-20
+_result :: a