From 79502fb6ccbe61385e21c8d43a8f2a42bdc44516 Mon Sep 17 00:00:00 2001
From: Nick Bowler <nbowler@draconx.ca>
Date: Wed, 13 Oct 2010 18:38:58 -0400
Subject: [PATCH] fenv: Add an example program to show problems with forkIO.

---
 Data/Floating/Environment.hs |  6 ++++--
 examples/.gitignore          |  1 +
 examples/fenv-race.hs        | 37 +++++++++++++++++++++++++++++++++++++
 3 files changed, 42 insertions(+), 2 deletions(-)
 create mode 100644 examples/fenv-race.hs

diff --git a/Data/Floating/Environment.hs b/Data/Floating/Environment.hs
index ccc38d8..11d50cd 100644
--- a/Data/Floating/Environment.hs
+++ b/Data/Floating/Environment.hs
@@ -29,8 +29,10 @@
 -- they can be performed later, thus one should be take care not to construct
 -- huge thunks when using this interface.
 --
--- This interface has not been tested in multi-threaded programs.  It might
--- work: more info is needed about GHC's threading support.
+-- Be careful when using these functions in multi-threaded programs.  Due to
+-- an implementation bug (as of GHC 6.12.3), nothing in this module is safe
+-- from races while there are /any/ unbound threads that might potentially
+-- perform /any/ floating point operation whatsoever.
 {-# LANGUAGE CPP, ForeignFunctionInterface, ExistentialQuantification #-}
 {-# OPTIONS_GHC -I. #-}
 module Data.Floating.Environment (
diff --git a/examples/.gitignore b/examples/.gitignore
index 22d1940..3f65e5e 100644
--- a/examples/.gitignore
+++ b/examples/.gitignore
@@ -1 +1,2 @@
 fenv-impure
+fenv-race
diff --git a/examples/fenv-race.hs b/examples/fenv-race.hs
new file mode 100644
index 0000000..70e15d6
--- /dev/null
+++ b/examples/fenv-race.hs
@@ -0,0 +1,37 @@
+{-
+ - Copyright (C) 2010 Nick Bowler.
+ -
+ - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
+ - This is free software: you are free to change and redistribute it.
+ - There is NO WARRANTY, to the extent permitted by law.
+ -}
+
+-- | Demonstration of why the functions in "Data.Floating.Environment" are
+-- not safe for use concurrently with unbound threads that perform floating
+-- point operations.
+
+{-# LANGUAGE NoImplicitPrelude #-}
+module Main where
+
+import Data.Floating.Prelude
+import Data.Floating.Environment
+import Control.Concurrent
+import Control.Exception
+
+theThread :: MVar () -> MVar Double -> IO ()
+theThread input output = do
+    takeMVar input
+    evaluate (1/10) >>= putMVar output
+
+main :: IO ()
+main = do
+    input  <- newEmptyMVar
+    output <- newEmptyMVar
+    forkIO $ theThread input output
+    ref <- evaluate (1 / 10)
+    -- This rounding mode should not be visible to the other thread.
+    unsafeSetRoundingMode TowardZero
+    putMVar input ()
+    ret <- takeMVar output
+    -- At this point, the output should equal the reference value.
+    print $ ref == ret
-- 
2.11.4.GIT