[commit: ghc] ghc-lwc2: Added exception handler for scheduleSContAction and yieldControlAction. (0596458)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

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

On branch  : ghc-lwc2

http://hackage.haskell.org/trac/ghc/changeset/0596458019d868ea591b1eafc2e4887c16d1012a

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

commit 0596458019d868ea591b1eafc2e4887c16d1012a
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Thu Feb 28 18:09:34 2013 -0500

    Added exception handler for scheduleSContAction and yieldControlAction.

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

 libraries/base/LwConc/Substrate.hs | 14 ++++++++++----
 rts/Schedule.c                     |  6 +++---
 tests/config.mk                    |  5 +++--
 3 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/libraries/base/LwConc/Substrate.hs b/libraries/base/LwConc/Substrate.hs
index 3717ffa..30e447d 100644
--- a/libraries/base/LwConc/Substrate.hs
+++ b/libraries/base/LwConc/Substrate.hs
@@ -417,7 +417,7 @@ getYieldControlAction = do
 
 {-# INLINE yieldControlActionRts #-}
 yieldControlActionRts :: SCont -> IO () -- used by RTS
-yieldControlActionRts sc = atomically $ do
+yieldControlActionRts sc = Exception.catch (atomically $ do
   mySC <- getSCont
   setSContSwitchReason mySC Completed
   stat <- getSContStatus sc
@@ -426,7 +426,10 @@ yieldControlActionRts sc = atomically $ do
       SContSwitched Yielded -> return () -- Has been unblocked and put on the run queue
       otherwise -> error "yieldControlAction: Impossible status"
   switch <- getYieldControlActionSCont sc
-  switch
+  switch) (\e -> do {
+											print ("ERROR:" ++ show (e::IOException));
+											error "LwConc.Substrate.yieldControlActionRTS"
+											})
 
 -----------------------------------------------------------------------------------
 -- scheduleSContAction and friends..
@@ -451,14 +454,17 @@ getScheduleSContAction = do
 
 {-# INLINE scheduleSContActionRts #-}
 scheduleSContActionRts :: SCont -> IO () -- used by RTS
-scheduleSContActionRts sc = atomically $ do
+scheduleSContActionRts sc = Exception.catch (atomically $ do
   stat <- getSContStatus sc
   case stat of
     SContSwitched (BlockedInHaskell (ResumeToken t)) -> writePVar t False
     otherwise -> return ()
   setSContStatus sc $ SContSwitched Yielded
   unblock <- getScheduleSContActionSCont sc
-  unblock sc
+  unblock sc) (\e -> do {
+											print ("ERROR:" ++ show (e::IOException));
+											error "LwConc.Substrate.scheduleSContActionRTS"
+											})
 
 
 -----------------------------------------------------------------------------------
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 500c8ad..b3df6f0 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -2836,7 +2836,7 @@ void wakeUpRts(void)
    exception.
    -------------------------------------------------------------------------- */
 
-    static void
+static void
 deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
 {
     // NOTE: must only be called on a TSO that we have exclusive
@@ -2851,7 +2851,7 @@ deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
 }
 
 #ifdef FORKPROCESS_PRIMOP_SUPPORTED
-    static void
+static void
 deleteThread_(Capability *cap, StgTSO *tso)
 { // for forkProcess only:
     // like deleteThread(), but we delete threads in foreign calls, too.
@@ -2874,7 +2874,7 @@ deleteThread_(Capability *cap, StgTSO *tso)
    C.  Who knows, it might be a useful re-useable thing here too.
    -------------------------------------------------------------------------- */
 
-    StgWord
+StgWord
 raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
 {
     Capability *cap = regTableToCapability(reg);
diff --git a/tests/config.mk b/tests/config.mk
index a0ca7ec..f89a001 100644
--- a/tests/config.mk
+++ b/tests/config.mk
@@ -1,5 +1,6 @@
 PROFILE := false
 DEBUG := false
+TOP := ..
 
 ifeq ($(DEBUG),true)
   DEBUG_FLG := -debug
@@ -16,12 +17,12 @@ endif
 
 GHC_OPTS = -rtsopts --make
 
-GHC    := ../inplace/bin/ghc-stage1 $(DEBUG_FLG) $(PROFILE_FLG) $(GHC_OPTS) $(GHC_OPTS_EXTRA)
+GHC := inplace/bin/ghc-stage1 $(DEBUG_FLG) $(PROFILE_FLG) $(GHC_OPTS)
 
 all: $(TARGETS)
 
 %.bin:	%.hs
-	$(GHC) $< -o $@
+	$(TOP)/$(GHC) $(GHC_OPTS_EXTRA) $< -o $@
 
 
 %.cmm:  %.hs