Trac #9878: Make the static form illegal in interpreted mode.

Summary:
The entries of the static pointers table are expected to exist as
object code. Thus we have ghci complain with an intelligible error
message if the static form is used in interpreted mode.

It also includes a fix to keysHashTable in Hash.c which could cause a
crash. The iteration of the hashtable internals was incorrect. This
patch has the function keysHashTable imitate the iteration in
freeHashTable.

Finally, we submit here some minor edits to comments and
GHC.StaticPtr.StaticPtrInfo field names.

Authored-by: Alexander Vershilov <alexander.vershilov@tweag.
Authored-by: Facundo Domínguez <facundo.dominguez@tweag.io>

Test Plan: ./validate

Reviewers: simonpj, hvr, austin

Reviewed By: austin

Subscribers: carter, thomie, qnikst, mboes

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

GHC Trac Issues: #9878

12 files changed, 57 insertions, 19 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index dbc9a76664..4bffdbc06a 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -403,8 +403,8 @@ dsExpr (PArrSeq _ _)
     g = ... static f ...
 ==>
     sptEntry:N = StaticPtr
-        (fingerprintString "pkgId:module.sptEntry:N")
-        (StaticPtrInfo "current pkg id" "current module" "sptEntry:0")
+        (fingerprintString "pkgKey:module.sptEntry:N")
+        (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
         f
     g = ... sptEntry:N
 \end{verbatim}
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index cf5457eca1..f210b5a929 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -317,6 +317,15 @@ wired-in. See the Notes about the NameSorts in Name.hs.
 -}
 
 rnExpr e@(HsStatic expr) = do
+    target <- fmap hscTarget getDynFlags
+    case target of
+      -- SPT entries are expected to exist in object code so far, and this is
+      -- not the case in interpreted mode. See bug #9878.
+      HscInterpreted -> addErr $ sep
+        [ text "The static form is not supported in interpreted mode."
+        , text "Please use -fobject-code."
+        ]
+      _ -> return ()
     (expr',fvExpr) <- rnLExpr expr
     stage <- getStage
     case stage of
diff --git a/includes/rts/StaticPtrTable.h b/includes/rts/StaticPtrTable.h
index d863160342..9c03d05ed3 100644
--- a/includes/rts/StaticPtrTable.h
+++ b/includes/rts/StaticPtrTable.h
@@ -16,8 +16,8 @@
 
 /** Inserts an entry in the Static Pointer Table.
  *
- * The key is a fingerprint computed from the StaticName of a static pointer
- * and the spe_closure is a pointer to the closure defining the table entry.
+ * The key is a fingerprint computed from the static pointer and the spe_closure
+ * is a pointer to the closure defining the table entry.
  *
  * A stable pointer to the closure is made to prevent it from being garbage
  * collected while the entry exists on the table.
diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
index efaabf2dd2..ab7998402f 100644
--- a/libraries/base/GHC/StaticPtr.hs
+++ b/libraries/base/GHC/StaticPtr.hs
@@ -85,8 +85,8 @@ foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a)
 
 -- | Miscelaneous information available for debugging purposes.
 data StaticPtrInfo = StaticPtrInfo
-    { -- | PackageId of the package where the static pointer is defined
-      spInfoPackageId  :: String
+    { -- | Package key of the package where the static pointer is defined
+      spInfoPackageKey  :: String
       -- | Name of the module where the static pointer is defined
     , spInfoModuleName :: String
       -- | An internal name that is distinct for every static pointer defined in
diff --git a/rts/Hash.c b/rts/Hash.c
index 422c3d9182..aab3b2361b 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -212,19 +212,27 @@ lookupHashTable(HashTable *table, StgWord key)
 // If the table is modified concurrently, the function behavior is undefined.
 //
 int keysHashTable(HashTable *table, StgWord keys[], int szKeys) {
-    int segment;
+    int segment, index;
     int k = 0;
-    for(segment=0;segment<HDIRSIZE && table->dir[segment];segment+=1) {
-        int index;
-        for(index=0;index<HSEGSIZE;index+=1) {
-            HashList *hl;
-            for(hl=table->dir[segment][index];hl;hl=hl->next) {
-                if (k == szKeys)
-                  return k;
+    HashList *hl;
+
+
+    /* The last bucket with something in it is table->max + table->split - 1 */
+    segment = (table->max + table->split - 1) / HSEGSIZE;
+    index = (table->max + table->split - 1) % HSEGSIZE;
+
+    while (segment >= 0 && k < szKeys) {
+        while (index >= 0 && k < szKeys) {
+            hl = table->dir[segment][index];
+            while (hl && k < szKeys) {
                 keys[k] = hl->key;
                 k += 1;
+                hl = hl->next;
             }
+            index--;
         }
+        segment--;
+        index = HSEGSIZE - 1;
     }
     return k;
 }
diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
index b9d683e712..962352684f 100644
--- a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
+++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
@@ -1,5 +1,5 @@
-StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spInfoSrcLoc = (10,32)}
-StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spInfoSrcLoc = (11,33)}
-StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spInfoSrcLoc = (21,13)}
-StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spInfoSrcLoc = (13,33)}
-StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spInfoSrcLoc = (14,33)}
+StaticPtrInfo {spInfoPackageKey = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spInfoSrcLoc = (10,32)}
+StaticPtrInfo {spInfoPackageKey = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spInfoSrcLoc = (11,33)}
+StaticPtrInfo {spInfoPackageKey = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spInfoSrcLoc = (21,13)}
+StaticPtrInfo {spInfoPackageKey = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spInfoSrcLoc = (13,33)}
+StaticPtrInfo {spInfoPackageKey = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spInfoSrcLoc = (14,33)}
diff --git a/testsuite/tests/ghci/scripts/T9878.hs b/testsuite/tests/ghci/scripts/T9878.hs
new file mode 100644
index 0000000000..fcecedab20
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9878.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE StaticPointers #-}
+module T9878 where
+
+import GHC.StaticPtr
+
+f = deRefStaticPtr (static True)
diff --git a/testsuite/tests/ghci/scripts/T9878.script b/testsuite/tests/ghci/scripts/T9878.script
new file mode 100644
index 0000000000..498183fa60
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9878.script
@@ -0,0 +1 @@
+:l T9878.hs
diff --git a/testsuite/tests/ghci/scripts/T9878.stderr b/testsuite/tests/ghci/scripts/T9878.stderr
new file mode 100644
index 0000000000..98a8edfe25
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9878.stderr
@@ -0,0 +1,4 @@
+
+T9878.hs:6:21:
+    The static form is not supported in interpreted mode.
+    Please use -fobject-code.
diff --git a/testsuite/tests/ghci/scripts/T9878b.script b/testsuite/tests/ghci/scripts/T9878b.script
new file mode 100644
index 0000000000..a855858bd6
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9878b.script
@@ -0,0 +1,2 @@
+:l T9878.hs
+f
diff --git a/testsuite/tests/ghci/scripts/T9878b.stdout b/testsuite/tests/ghci/scripts/T9878b.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9878b.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 3e2ea77d61..fbcdb259e0 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -199,3 +199,10 @@ test('T9762',
  ],
  ghci_script, ['T9762.script'])
 test('T9881', normal, ghci_script, ['T9881.script'])
+test('T9878',
+    [extra_clean(['T9878.hi','T9878.o'])],
+    ghci_script, ['T9878.script'])
+test('T9878b',
+    [ extra_run_opts('-fobject-code'),
+      extra_clean(['T9878.hi','T9878.o'])],
+    ghci_script, ['T9878b.script'])