Repository : http://darcs.haskell.org/ghc.git/
On branch : ghc-lwc2 https://github.com/ghc/ghc/commit/622ae3c18cf6537ebda4fcc7ade77e2dfafea16b >--------------------------------------------------------------- commit 622ae3c18cf6537ebda4fcc7ade77e2dfafea16b Author: KC Sivaramakrishnan <[email protected]> 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
_______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
