[commit: ghc] ghc-lwc2: Added debug messages to tease out the unsafe use of withArrayLen. Added comment. (622ae3c)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/622ae3c18cf6537ebda4fcc7ade77e2dfafea16b

>---------------------------------------------------------------

commit 622ae3c18cf6537ebda4fcc7ade77e2dfafea16b
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Sun May 12 16:47:36 2013 -0400

    Added debug messages to tease out the unsafe use of withArrayLen. Added comment.

>---------------------------------------------------------------

 tests/Benchmarks/ChameneosRedux/Makefile           |  2 +-
 .../ChameneosRedux/chameneos-redux-lwc.hs          | 33 +++++++++++++++++++---
 2 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/tests/Benchmarks/ChameneosRedux/Makefile b/tests/Benchmarks/ChameneosRedux/Makefile
index 677ca4f..eb51680 100644
--- a/tests/Benchmarks/ChameneosRedux/Makefile
+++ b/tests/Benchmarks/ChameneosRedux/Makefile
@@ -4,7 +4,7 @@ include ../../config.mk
 
 TOP := ../../../
 EXTRA_LIBS=/scratch/chandras/install
-GHC_OPTS_EXTRA=-O2 -threaded -XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -optc-O3
+GHC_OPTS_EXTRA=-threaded -XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -debug
 
 PROFILE_FLAGS := -DPROFILE_ENABLED -prof -fprof-auto -auto -auto-all
 
diff --git a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
index 415e6fa..d1bc470 100644
--- a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
+++ b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
@@ -5,7 +5,13 @@
    Modified by Péter Diviánszky, 19 May 2010
    Modified by Louis Wasserman, 14 June 2010
 
-   Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS -N<number of cores>.
+	 Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS
+	 -N<number of cores>.
+
+	 XXX KC: The user of withArrayLen is unsafe. We obtain pointers to
+	 addresses inside the array but not the byte array itself. This is a
+	 recipie for disaster. See
+	 http://hackage.haskell.org/trac/ghc/ticket/7012. Solution?
    -}
 
 import LwConc.Substrate
@@ -30,42 +36,61 @@ instance Show Color where
   show Y = "yellow"
   show R = "red"
   show B = "blue"
+  show (C v) = error ("show: impossible " ++ show v)
 
 complement :: Color -> Color -> Color
 complement !a !b = case a of
     B -> case b of R -> Y; B -> B; _ -> R
     R -> case b of B -> Y; R -> R; _ -> B
     Y -> case b of B -> R; Y -> Y; _ -> B
-    _ -> error "complement: impossible"
+    C v -> error ("complement: impossible " ++ show v)
 
 type Chameneous = Ptr Color
 data MP = Nobody !Int | Somebody !Int !Chameneous !(MVar Chameneous)
 
 arrive :: MVar MP -> MVar (Int, Int) -> Chameneous -> IO ()
 arrive !mpv !finish !ch = do
+    sc <- getSContIO
     !waker <- newEmptyMVar
     !hole1 <- newIORef undefined
     !hole2 <- newIORef undefined
     !tk <- atomically $ newResumeToken
     let inc x = (fromEnum (ch == x) +)
         go !t !b = do
+            -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
             w <- takeMVarWithHole mpv hole1 tk
+            -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
             case w of
                 Nobody 0 -> do
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     putMVar mpv w tk
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     putMVar finish (t, b) tk
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
+                    return ()
                 Nobody q -> do
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     putMVar mpv (Somebody q ch waker) tk
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     ch' <- takeMVarWithHole waker hole2 tk
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     go (t+1) $ inc ch' b
                 Somebody q ch' waker' -> do
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     c  <- peek ch
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     c' <- peek ch'
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     let !c'' = complement c c'
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     poke ch  c''
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     poke ch' c''
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     let !q' = q-1
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     putMVar waker' ch tk
+                    -- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
                     putMVar mpv (Nobody q') tk
                     go (t+1) $ inc ch' b
     go 0 0
@@ -95,11 +120,11 @@ initSched = do
   replicateM_ (n-1) newCapability
 
 main = do
+    initSched
     putStrLn . map toLower . unlines $
         [unwords [show a, "+", show b, "->", show $ complement a b]
             | a <- [B..Y], b <- [B..Y]]
 
     n <- readIO . head =<< getArgs
-    initSched
-    actions <- zipWithM (run n) [0..] [[B..Y],[B,R,Y,R,Y,B,R,Y,R,B]]
+    actions <- zipWithM (run n) [0..] [[B..Y], [B,R,Y,R,Y,B,R,Y,R,B]]
     sequence_ actions