X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=cdb6c9455c8374f3347399d21a20a0e7e9396d7a;hb=d5036717526fdd27f6a1c770fd19a6090af60254;hp=8579901afc4610596d683c9cc644c8dc58c60238;hpb=c9a8811e407ea25e271d850468839935d0cf5e4f;p=ghc-hetmet.git

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 8579901..cdb6c94 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -6,11 +6,11 @@
 --
 -- -----------------------------------------------------------------------------
 
-{-# OPTIONS_GHC -w #-}
+{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module InteractiveEval (
@@ -21,6 +21,7 @@ module InteractiveEval (
         abandon, abandonAll,
         getResumeContext,
         getHistorySpan,
+        getModBreaks,
         getHistoryModule,
         back, forward,
 	setContext, getContext,	
@@ -158,9 +159,17 @@ getHistorySpan hsc_env hist =
    let inf = historyBreakInfo hist
        num = breakInfo_number inf
    in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
-       Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num
+       Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
        _ -> panic "getHistorySpan"
 
+getModBreaks :: HomeModInfo -> ModBreaks
+getModBreaks hmi
+  | Just linkable <- hm_linkable hmi, 
+    [BCOs _ modBreaks] <- linkableUnlinked linkable
+  = modBreaks
+  | otherwise
+  = emptyModBreaks -- probably object code
+
 {- | Finds the enclosing top level function name -}
 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
 -- by the coverage pass, which gives the list of lexically-enclosing bindings
@@ -202,7 +211,7 @@ runStmt (Session ref) expr step
               withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
 
               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-              status <- sandboxIO statusMVar thing_to_run
+              status <- sandboxIO dflags' statusMVar thing_to_run
               
               let ic = hsc_IC hsc_env
                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
@@ -285,7 +294,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 isBreakEnabled hsc_env inf =
    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
        Just hmi -> do
-         w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
+         w <- getBreak (modBreaks_flags (getModBreaks hmi))
                        (breakInfo_number inf)
          case w of Just n -> return (n /= 0); _other -> return False
        _ ->
@@ -306,10 +315,10 @@ foreign import ccall "&rts_breakpoint_io_action"
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
-sandboxIO :: MVar Status -> IO [HValue] -> IO Status
-sandboxIO statusMVar thing = 
+sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
+sandboxIO dflags statusMVar thing = 
   withInterruptsSentTo 
-        (forkIO (do res <- Exception.try (rethrow thing)
+        (forkIO (do res <- Exception.try (rethrow dflags thing)
                     putMVar statusMVar (Complete res)))
         (takeMVar statusMVar)
 
@@ -321,12 +330,24 @@ sandboxIO statusMVar thing =
 -- to :continue twice, which looks strange).  So if the exception is
 -- not "Interrupted", we unset the exception flag before throwing.
 --
-rethrow :: IO a -> IO a
-rethrow io = Exception.catch io $ \e -> -- NB. not catchDyn
+rethrow :: DynFlags -> IO a -> IO a
+rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
+                   -- If -fbreak-on-error, we break unconditionally,
+                   --  but with care of not breaking twice 
+                   _ | dopt Opt_BreakOnError dflags && 
+                       not(dopt Opt_BreakOnException dflags)
+                        -> poke exceptionFlag 1
+
+                   -- If it is an "Interrupted" exception, we allow
+                   --  a possible break by way of -fbreak-on-exception
                    DynException d | Just Interrupted <- fromDynamic d
-                        -> Exception.throwIO e
-                   _ -> do poke exceptionFlag 0; Exception.throwIO e
+                        -> return ()
+
+                   -- In any other case, we don't want to break
+                   _    -> poke exceptionFlag 0
+
+                Exception.throwIO e
 
 
 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
@@ -501,9 +522,10 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 
    let 
-       mod_name    = moduleName (breakInfo_module info)
-       mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
-       breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
+       mod_name  = moduleName (breakInfo_module info)
+       hmi       = expectJust "bindLocalsAtBreakpoint" $ 
+                        lookupUFM (hsc_HPT hsc_env) mod_name
+       breaks    = getModBreaks hmi
        index     = breakInfo_number info
        vars      = breakInfo_vars info
        result_ty = breakInfo_resty info
@@ -575,7 +597,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
                , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
                               , isSkolemTyVar v]
                , (occNameFS.nameOccName.idName) id /= result_fs]
-   tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
+   tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
    
    let substs = [computeRTTIsubst ty ty' 
@@ -925,8 +947,8 @@ obtainTerm hsc_env force id =  do
               cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
-reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
-reconstructType hsc_env force id = do
+reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
+reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 
-              cvReconstructType hsc_env force (Just$ idType id) hv
+              cvReconstructType hsc_env bound (Just$ idType id) hv
 #endif /* GHCI */