From b09e10d0669a71c834530a83eaa6c870a8bcc925 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 15 Jan 2021 15:58:10 -0700
Subject: [PATCH] cs: prevent a future from waiting on a semaphore

A `semaphore-wait` or `semaphore-post` has a shortcut that uses a CAS
operation, which means that a future could affect a semaphore if it's
allowed to take that shortcut. But futures aren't supposed to succeed
in that way, because thread-level synchronization should generally
suspend a future. Disallow the shortcut when in a future.
---
 pkgs/racket-test/tests/future/hash-lock.rkt | 31 +++++++++++++++++++++
 racket/src/cs/schemified/thread.scm         | 12 ++++++--
 racket/src/thread/semaphore.rkt             |  2 ++
 3 files changed, 43 insertions(+), 2 deletions(-)
 create mode 100644 pkgs/racket-test/tests/future/hash-lock.rkt

diff --git a/pkgs/racket-test/tests/future/hash-lock.rkt b/pkgs/racket-test/tests/future/hash-lock.rkt
new file mode 100644
index 0000000000..05a5f7c537
--- /dev/null
+++ b/pkgs/racket-test/tests/future/hash-lock.rkt
@@ -0,0 +1,31 @@
+#lang racket/base
+(require racket/future)
+
+;; Check that a future won't take a lock on an `equal?`-based hash
+;; table and then leave the table stuck as the future is suspended.
+;; Indirectly, that's checking that a future won't succeed waiting
+;; on a semaphore, since a semaphore is used as a lock.
+
+(struct a (x)
+  #:property
+  prop:equal+hash
+  (list
+   (lambda (a b eql?)
+     (sync (system-idle-evt))
+     (eql? (a-x a) (a-x b)))
+   (lambda (a hc)
+     (sync (system-idle-evt))
+     (hc (a-x a)))
+   (lambda (a hc)
+     (hc (a-x a)))))
+
+(define ht (make-hash (list
+                       (cons (a 1) 'one)
+                       (cons (a 2) 'two))))
+
+(define f (future
+           (lambda ()
+             (hash-ref ht (a 1) #f))))
+(sync (system-idle-evt))
+(unless (eq? (hash-ref ht (a 1) #f) 'one)
+  (error "hash failed"))
diff --git a/racket/src/cs/schemified/thread.scm b/racket/src/cs/schemified/thread.scm
index 85e2e35a5f..b8014c464d 100644
--- a/racket/src/cs/schemified/thread.scm
+++ b/racket/src/cs/schemified/thread.scm
@@ -4348,7 +4348,11 @@
 (define unsafe-semaphore-post
   (lambda (s_0)
     (let ((c_0 (semaphore-count s_0)))
-      (if (if (>= c_0 0) (unsafe-struct*-cas! s_0 2 c_0 (add1 c_0)) #f)
+      (if (if (>= c_0 0)
+            (if (not (current-future$1))
+              (unsafe-struct*-cas! s_0 2 c_0 (add1 c_0))
+              #f)
+            #f)
         (void)
         (begin (start-atomic) (semaphore-post/atomic s_0) (end-atomic))))))
 (define semaphore-post/atomic
@@ -4417,7 +4421,11 @@
 (define unsafe-semaphore-wait
   (lambda (s_0)
     (let ((c_0 (semaphore-count s_0)))
-      (if (if (positive? c_0) (unsafe-struct*-cas! s_0 2 c_0 (sub1 c_0)) #f)
+      (if (if (positive? c_0)
+            (if (not (current-future$1))
+              (unsafe-struct*-cas! s_0 2 c_0 (sub1 c_0))
+              #f)
+            #f)
         (void)
         (|#%app|
          (begin
diff --git a/racket/src/thread/semaphore.rkt b/racket/src/thread/semaphore.rkt
index b838b9a075..75c85b15db 100644
--- a/racket/src/thread/semaphore.rkt
+++ b/racket/src/thread/semaphore.rkt
@@ -71,6 +71,7 @@
   (define c (semaphore-count s))
   (cond
     [(and (c . >= . 0)
+          (not (current-future))
           (unsafe-struct*-cas! s count-field-pos c (add1 c)))
      (void)]
     [else
@@ -132,6 +133,7 @@
   (define c (semaphore-count s))
   (cond
     [(and (positive? c)
+          (not (current-future))
           (unsafe-struct*-cas! s count-field-pos c (sub1 c)))
      (void)]
     [else