unused import

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index c25a617..f8402f8 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -14,7 +14,8 @@ module GHC (
        newSession,
 
        -- * Flags and settings
        newSession,
 
        -- * Flags and settings

-       DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+       DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+        GhcMode(..), GhcLink(..),

        parseDynamicFlags,
        getSessionDynFlags,
        setSessionDynFlags,
        parseDynamicFlags,
        getSessionDynFlags,
        setSessionDynFlags,

@@ -40,6 +41,9 @@ module GHC (
        checkModule, CheckedModule(..),
        TypecheckedSource, ParsedSource, RenamedSource,
 
        checkModule, CheckedModule(..),
        TypecheckedSource, ParsedSource, RenamedSource,
 

+       -- * Parsing Haddock comments
+       parseHaddockComment,
+

        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
        getModuleGraph,
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
        getModuleGraph,

@@ -73,11 +77,18 @@ module GHC (
        exprType,
        typeKind,
        parseName,
        exprType,
        typeKind,
        parseName,

-       RunResult(..),
+       RunResult(..),  ResumeHandle,

        runStmt,
        runStmt,

+        resume,

        showModule,
        showModule,

+        isModuleInterpreted,

        compileExpr, HValue, dynCompileExpr,
        lookupName,
        compileExpr, HValue, dynCompileExpr,
        lookupName,

+        obtainTerm, obtainTerm1,
+        ModBreaks(..), BreakIndex,
+        BreakInfo(breakInfo_number, breakInfo_module),
+        BreakArray, setBreakOn, setBreakOff, getBreak,
+        modInfoModBreaks, 

 #endif
 
        -- * Abstract syntax elements
 #endif
 
        -- * Abstract syntax elements

@@ -91,7 +102,7 @@ module GHC (
 
        -- ** Names
        Name, 
 
        -- ** Names
        Name, 

-       nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+       nameModule, pprParenSymName, nameSrcLoc,

        NamedThing(..),
        RdrName(Qual,Unqual),
        
        NamedThing(..),
        RdrName(Qual,Unqual),
        

@@ -133,7 +144,8 @@ module GHC (
        instanceDFunId, pprInstance, pprInstanceHdr,
 
        -- ** Types and Kinds
        instanceDFunId, pprInstance, pprInstanceHdr,
 
        -- ** Types and Kinds

-       Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+       Type, dropForAlls, splitForAllTys, funResultTy, 
+       pprParendType, pprTypeApp,

        Kind,
        PredType,
        ThetaType, pprThetaArrow,
        Kind,
        PredType,
        ThetaType, pprThetaArrow,

@@ -152,6 +164,14 @@ module GHC (
 
        -- ** Source locations
        SrcLoc, pprDefnLoc,
 
        -- ** Source locations
        SrcLoc, pprDefnLoc,

+        mkSrcLoc, isGoodSrcLoc,
+       srcLocFile, srcLocLine, srcLocCol,
+        SrcSpan,
+        mkSrcSpan, srcLocSpan,
+        srcSpanStart, srcSpanEnd,
+       srcSpanFile, 
+        srcSpanStartLine, srcSpanEndLine, 
+        srcSpanStartCol, srcSpanEndCol,

 
        -- * Exceptions
        GhcException(..), showGhcException,
 
        -- * Exceptions
        GhcException(..), showGhcException,

@@ -171,71 +191,62 @@ module GHC (
 #include "HsVersions.h"
 
 #ifdef GHCI
 #include "HsVersions.h"
 
 #ifdef GHCI

-import qualified Linker
-import Data.Dynamic     ( Dynamic )
-import Linker          ( HValue, extendLinkEnv )
+import RtClosureInspect ( cvObtainTerm, Term )

 import TcRnDriver      ( tcRnLookupRdrName, tcRnGetInfo,
                          tcRnLookupName, getModuleExports )
 import TcRnDriver      ( tcRnLookupRdrName, tcRnGetInfo,
                          tcRnLookupName, getModuleExports )

-import RdrName         ( plusGlobalRdrEnv, Provenance(..), 
-                         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
-                         mkGlobalRdrEnv )
-import HscMain         ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name            ( nameOccName )
-import Type            ( tidyType )
-import VarEnv          ( emptyTidyEnv )
-import GHC.Exts                ( unsafeCoerce# )
+import GHC.Exts         ( unsafeCoerce#, Ptr )
+import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign          ( poke )
+import qualified Linker
+import Linker           ( HValue )
+
+import Data.Dynamic     ( Dynamic )
+
+import ByteCodeInstr
+import IdInfo
+import HscMain          ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
+import BreakArray

 #endif
 
 #endif
 

-import Packages                ( initPackages )
-import NameSet         ( NameSet, nameSetToList, elemNameSet )
-import RdrName         ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), 
-                         globalRdrEnvElts, extendGlobalRdrEnv,
-                          emptyGlobalRdrEnv )
-import HsSyn
-import Type            ( Kind, Type, dropForAlls, PredType, ThetaType,
-                         pprThetaArrow, pprParendType, splitForAllTys,
-                         funResultTy )
-import Id              ( Id, idType, isImplicitId, isDeadBinder,
-                          isExportedId, isLocalId, isGlobalId,
-                          isRecordSelector, recordSelectorFieldLabel,
-                          isPrimOpId, isFCallId, isClassOpId_maybe,
-                          isDataConWorkId, idDataCon,
-                          isBottomingId )
-import Var             ( TyVar )
+import Packages
+import NameSet
+import RdrName
+import HsSyn 
+import Type             hiding (typeKind)
+import TcType           hiding (typeKind)
+import Id
+import Var              hiding (setIdType)
+import VarEnv
+import VarSet

 import TysPrim         ( alphaTyVars )
 import TysPrim         ( alphaTyVars )

-import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
-                         isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
-                         tyConTyVars, tyConDataCons, synTyConDefn,
-                         synTyConType, synTyConResKind )
-import Class           ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps         ( pprFundeps )
-import DataCon         ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
-                         dataConFieldLabels, dataConStrictMarks, 
-                         dataConIsInfix, isVanillaDataCon )
-import Name            ( Name, nameModule, NamedThing(..), nameParent_maybe,
-                         nameSrcLoc )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name             hiding ( varName )

 import OccName         ( parenSymOcc )
 import OccName         ( parenSymOcc )

-import NameEnv         ( nameEnvElts )
+import NameEnv

 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo      ( getImports, getOptions )
 import Finder
 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo      ( getImports, getOptions )
 import Finder

-import HscMain         ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )

 import HscTypes
 import DynFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM
 import HscTypes
 import DynFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM

-import PackageConfig    ( PackageId, stringToPackageId )
+import PackageConfig

 import FiniteMap
 import Panic
 import Digraph
 import FiniteMap
 import Panic
 import Digraph

-import Bag             ( unitBag )
+import Bag             ( unitBag, listToBag )

 import ErrUtils                ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
 import ErrUtils                ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,

-                         mkPlainErrMsg, printBagOfErrors )
+                         mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
+                         WarnMsg )

 import qualified ErrUtils
 import Util
 import StringBuffer    ( StringBuffer, hGetStringBuffer )
 import qualified ErrUtils
 import Util
 import StringBuffer    ( StringBuffer, hGetStringBuffer )

@@ -243,13 +254,18 @@ import Outputable
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )

+import HaddockParse
+import HaddockLex       ( tokenise )
+import PrelNames
+import Unique

 
 

+import Data.Array

 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )

-import Data.Maybe      ( isJust, isNothing )
-import Data.List       ( partition, nub )
+import Data.Maybe
+import Data.List

 import qualified Data.List as List
 import qualified Data.List as List

-import Control.Monad   ( unless, when )
+import Control.Monad

 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime )
 import Control.Exception as Exception hiding (handle)
 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime )
 import Control.Exception as Exception hiding (handle)

@@ -310,9 +326,8 @@ defaultErrorHandler dflags inner =
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
     -- make sure we clean up after ourselves
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
     -- make sure we clean up after ourselves

-    later (unless (dopt Opt_KeepTmpFiles dflags) $
-               do cleanTempFiles dflags
-                  cleanTempDirs dflags
+    later (do cleanTempFiles dflags
+              cleanTempDirs dflags

           )
           -- exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
           )
           -- exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further

@@ -322,18 +337,16 @@ defaultCleanupHandler dflags inner =
 
 -- | Starts a new session.  A session consists of a set of loaded
 -- modules, a set of options (DynFlags), and an interactive context.
 
 -- | Starts a new session.  A session consists of a set of loaded
 -- modules, a set of options (DynFlags), and an interactive context.

--- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
--- code".
-newSession :: GhcMode -> Maybe FilePath -> IO Session
-newSession mode mb_top_dir = do
+newSession :: Maybe FilePath -> IO Session
+newSession mb_top_dir = do

   -- catch ^C
   main_thread <- myThreadId
   -- catch ^C
   main_thread <- myThreadId

-  putMVar interruptTargetThread [main_thread]
+  modifyMVar_ interruptTargetThread (return . (main_thread :))

   installSignalHandlers
 
   dflags0 <- initSysTools mb_top_dir defaultDynFlags
   dflags  <- initDynFlags dflags0
   installSignalHandlers
 
   dflags0 <- initSysTools mb_top_dir defaultDynFlags
   dflags  <- initDynFlags dflags0

-  env <- newHscEnv dflags{ ghcMode=mode }
+  env <- newHscEnv dflags

   ref <- newIORef env
   return (Session ref)
 
   ref <- newIORef env
   return (Session ref)
 

@@ -474,6 +487,12 @@ setGlobalTypeScope session ids
       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 
 -- -----------------------------------------------------------------------------
       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 
 -- -----------------------------------------------------------------------------

+-- Parsing Haddock comments
+
+parseHaddockComment :: String -> Either String (HsDoc RdrName)
+parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+
+-- -----------------------------------------------------------------------------

 -- Loading the program
 
 -- Perform a dependency analysis starting from the current targets
 -- Loading the program
 
 -- Perform a dependency analysis starting from the current targets

@@ -483,15 +502,13 @@ depanal (Session ref) excluded_mods allow_dup_roots = do
   hsc_env <- readIORef ref
   let
         dflags  = hsc_dflags hsc_env
   hsc_env <- readIORef ref
   let
         dflags  = hsc_dflags hsc_env

-        gmode   = ghcMode (hsc_dflags hsc_env)

         targets = hsc_targets hsc_env
         old_graph = hsc_mod_graph hsc_env
        
   showPass dflags "Chasing dependencies"
         targets = hsc_targets hsc_env
         old_graph = hsc_mod_graph hsc_env
        
   showPass dflags "Chasing dependencies"

-  when (gmode == BatchCompile) $
-       debugTraceMsg dflags 2 (hcat [
-                    text "Chasing modules from: ",
-                       hcat (punctuate comma (map pprTarget targets))])
+  debugTraceMsg dflags 2 (hcat [
+            text "Chasing modules from: ",
+            hcat (punctuate comma (map pprTarget targets))])

 
   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
   case r of
 
   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
   case r of

@@ -541,7 +558,6 @@ load2 s@(Session ref) how_much mod_graph = do
 
         let hpt1      = hsc_HPT hsc_env
         let dflags    = hsc_dflags hsc_env
 
         let hpt1      = hsc_HPT hsc_env
         let dflags    = hsc_dflags hsc_env

-        let ghci_mode = ghcMode dflags -- this never changes

 
        -- The "bad" boot modules are the ones for which we have
        -- B.hs-boot in the module graph, but no B.hs
 
        -- The "bad" boot modules are the ones for which we have
        -- B.hs-boot in the module graph, but no B.hs

@@ -563,10 +579,14 @@ load2 s@(Session ref) how_much mod_graph = do
         let mg2_with_srcimps :: [SCC ModSummary]
            mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 
         let mg2_with_srcimps :: [SCC ModSummary]
            mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 

+       -- If we can determine that any of the {-# SOURCE #-} imports
+       -- are definitely unnecessary, then emit a warning.
+       warnUnnecessarySourceImports dflags mg2_with_srcimps
+
+       let

            -- check the stability property for each module.
            stable_mods@(stable_obj,stable_bco)
            -- check the stability property for each module.
            stable_mods@(stable_obj,stable_bco)

-               | BatchCompile <- ghci_mode = ([],[])
-               | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
+               = checkStability hpt1 mg2_with_srcimps all_home_mods

 
            -- prune bits of the HPT which are definitely redundant now,
            -- to save space.
 
            -- prune bits of the HPT which are definitely redundant now,
            -- to save space.

@@ -637,6 +657,8 @@ load2 s@(Session ref) how_much mod_graph = do
        let cleanup = cleanTempFilesExcept dflags
                          (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 
        let cleanup = cleanTempFilesExcept dflags
                          (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 

+       debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 
+                                  2 (ppr mg))

         (upsweep_ok, hsc_env1, modsUpswept)
            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
                           pruned_hpt stable_mods cleanup mg
         (upsweep_ok, hsc_env1, modsUpswept)
            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
                           pruned_hpt stable_mods cleanup mg

@@ -672,13 +694,16 @@ load2 s@(Session ref) how_much mod_graph = do
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
                do_linking = a_root_is_Main || no_hs_main
 
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
                do_linking = a_root_is_Main || no_hs_main
 

-             when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
-               debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
-                                             "but no output will be generated\n" ++
-                                             "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
+             when (ghcLink dflags == LinkBinary 
+                    && isJust ofile && not do_linking) $
+               debugTraceMsg dflags 1 $
+                    text ("Warning: output was redirected with -o, " ++
+                          "but no output will be generated\n" ++
+                         "because there is no " ++ 
+                          moduleNameString (moduleName main_mod) ++ " module.")

 
              -- link everything together
 
              -- link everything together

-              linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
+              linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)

 
              loadFinish Succeeded linkresult ref hsc_env1
 
 
              loadFinish Succeeded linkresult ref hsc_env1
 

@@ -708,7 +733,7 @@ load2 s@(Session ref) how_much mod_graph = do
                        (eltsUFM (hsc_HPT hsc_env))) do
        
              -- Link everything together
                        (eltsUFM (hsc_HPT hsc_env))) do
        
              -- Link everything together

-              linkresult <- link ghci_mode dflags False hpt4
+              linkresult <- link (ghcLink dflags) dflags False hpt4

 
              let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
              loadFinish Failed linkresult ref hsc_env4
 
              let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
              loadFinish Failed linkresult ref hsc_env4

@@ -756,7 +781,8 @@ data CheckedModule =
        --  fields within CheckedModule.
 
 type ParsedSource      = Located (HsModule RdrName)
        --  fields within CheckedModule.
 
 type ParsedSource      = Located (HsModule RdrName)

-type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+                          Maybe (HsDoc Name), HaddockModInfo Name)

 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:
 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:

@@ -801,9 +827,13 @@ checkModule session@(Session ref) mod = do
                           (Just (tc_binds, rdr_env, details))) -> do
                   let minf = ModuleInfo {
                                minf_type_env  = md_types details,
                           (Just (tc_binds, rdr_env, details))) -> do
                   let minf = ModuleInfo {
                                minf_type_env  = md_types details,

-                               minf_exports   = md_exports details,
+                               minf_exports   = availsToNameSet $
+                                                     md_exports details,

                                minf_rdr_env   = Just rdr_env,
                                minf_instances = md_insts details
                                minf_rdr_env   = Just rdr_env,
                                minf_instances = md_insts details

+#ifdef GHCI
+                               ,minf_modBreaks = emptyModBreaks 
+#endif

                              }
                   return (Just (CheckedModule {
                                        parsedSource = parsed,
                              }
                   return (Just (CheckedModule {
                                        parsedSource = parsed,

@@ -816,15 +846,13 @@ checkModule session@(Session ref) mod = do
 
 unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables        -- Unload everthing *except* 'stable_linkables'
 
 unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables        -- Unload everthing *except* 'stable_linkables'

-  = case ghcMode (hsc_dflags hsc_env) of
-       BatchCompile  -> return ()
-       JustTypecheck -> return ()
+  = case ghcLink (hsc_dflags hsc_env) of

 #ifdef GHCI
 #ifdef GHCI

-       Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+       LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables

 #else
 #else

-       Interactive -> panic "unload: no interpreter"
+       LinkInMemory -> panic "unload: no interpreter"

 #endif
 #endif

-       other -> panic "unload: strange mode"
+       other -> return ()

 
 -- -----------------------------------------------------------------------------
 -- checkStability
 
 -- -----------------------------------------------------------------------------
 -- checkStability

@@ -841,9 +869,6 @@ unload hsc_env stable_linkables     -- Unload everthing *except* 'stable_linkables'
      module.  So we need to know that we will definitely not be recompiling
      any of these modules, and we can use the object code.
 
      module.  So we need to know that we will definitely not be recompiling
      any of these modules, and we can use the object code.
 

-  NB. stability is of no importance to BatchCompile at all, only Interactive.
-  (ToDo: what about JustTypecheck?)
-

   The stability check is as follows.  Both stableObject and
   stableBCO are used during the upsweep phase later.
 
   The stability check is as follows.  Both stableObject and
   stableBCO are used during the upsweep phase later.
 

@@ -862,7 +887,7 @@ unload hsc_env stable_linkables     -- Unload everthing *except* 'stable_linkables'
 
   These properties embody the following ideas:
 
 
   These properties embody the following ideas:
 

-    - if a module is stable:
+    - if a module is stable, then:

        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.
         - if it has not been compiled in a previous pass,
        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.
         - if it has not been compiled in a previous pass,

@@ -1073,95 +1098,133 @@ upsweep_mod :: HscEnv
             -> IO (Maybe HomeModInfo)  -- Nothing => Failed
 
 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
             -> IO (Maybe HomeModInfo)  -- Nothing => Failed
 
 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods

-   = do 
-        let 
-           this_mod_name = ms_mod_name summary
+   =    let 
+                   this_mod_name = ms_mod_name summary

            this_mod    = ms_mod summary
            mb_obj_date = ms_obj_date summary
            obj_fn      = ml_obj_file (ms_location summary)
            hs_date     = ms_hs_date summary
 
            this_mod    = ms_mod summary
            mb_obj_date = ms_obj_date summary
            obj_fn      = ml_obj_file (ms_location summary)
            hs_date     = ms_hs_date summary
 

+           is_stable_obj = this_mod_name `elem` stable_obj
+           is_stable_bco = this_mod_name `elem` stable_bco
+
+           old_hmi = lookupUFM old_hpt this_mod_name
+
+            -- We're using the dflags for this module now, obtained by
+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+            dflags = ms_hspp_opts summary
+            prevailing_target = hscTarget (hsc_dflags hsc_env)
+            local_target      = hscTarget dflags
+
+            -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
+            -- we don't do anything dodgy: these should only work to change
+            -- from -fvia-C to -fasm and vice-versa, otherwise we could 
+            -- end up trying to link object code to byte code.
+            target = if prevailing_target /= local_target
+                        && (not (isObjectTarget prevailing_target)
+                            || not (isObjectTarget local_target))
+                        then prevailing_target
+                        else local_target 
+
+            -- store the corrected hscTarget into the summary
+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+           -- The old interface is ok if
+           --  a) we're compiling a source file, and the old HPT
+           --     entry is for a source file
+           --  b) we're compiling a hs-boot file
+           -- Case (b) allows an hs-boot file to get the interface of its
+           -- real source file on the second iteration of the compilation
+           -- manager, but that does no harm.  Otherwise the hs-boot file
+           -- will always be recompiled
+            
+            mb_old_iface 
+               = case old_hmi of
+                    Nothing                              -> Nothing
+                    Just hm_info | isBootSummary summary -> Just iface
+                                 | not (mi_boot iface)   -> Just iface
+                                 | otherwise             -> Nothing
+                                  where 
+                                    iface = hm_iface hm_info
+

            compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
            compile_it  = upsweep_compile hsc_env old_hpt this_mod_name 
            compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
            compile_it  = upsweep_compile hsc_env old_hpt this_mod_name 

-                               summary mod_index nmods
-
-       case ghcMode (hsc_dflags hsc_env) of
-           BatchCompile ->
-               case () of
-                  -- Batch-compilating is easy: just check whether we have
-                  -- an up-to-date object file.  If we do, then the compiler
-                  -- needs to do a recompilation check.
-                  _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
-                          linkable <- 
-                               findObjectLinkable this_mod obj_fn obj_date
-                          compile_it (Just linkable)
-
-                    | otherwise ->
-                          compile_it Nothing
-
-           interactive ->
-               case () of
-                   _ | is_stable_obj, isJust old_hmi ->
-                          return old_hmi
+                               summary' mod_index nmods mb_old_iface
+
+            compile_it_discard_iface 
+                        = upsweep_compile hsc_env old_hpt this_mod_name 
+                               summary' mod_index nmods Nothing
+
+        in
+       case target of
+
+            _any
+                -- Regardless of whether we're generating object code or
+                -- byte code, we can always use an existing object file
+                -- if it is *stable* (see checkStability).
+               | is_stable_obj, isJust old_hmi ->
+                       return old_hmi

                        -- object is stable, and we have an entry in the
                        -- old HPT: nothing to do
 
                        -- object is stable, and we have an entry in the
                        -- old HPT: nothing to do
 

-                     | is_stable_obj, isNothing old_hmi -> do
-                          linkable <-
-                               findObjectLinkable this_mod obj_fn 
+               | is_stable_obj, isNothing old_hmi -> do
+                       linkable <- findObjectLinkable this_mod obj_fn 

                                        (expectJust "upseep1" mb_obj_date)
                                        (expectJust "upseep1" mb_obj_date)

-                          compile_it (Just linkable)
+                       compile_it (Just linkable)

                        -- object is stable, but we need to load the interface
                        -- off disk to make a HMI.
 
                        -- object is stable, but we need to load the interface
                        -- off disk to make a HMI.
 

-                     | is_stable_bco -> 
-                          ASSERT(isJust old_hmi) -- must be in the old_hpt
-                          return old_hmi
+            HscInterpreted
+               | is_stable_bco -> 
+                       ASSERT(isJust old_hmi) -- must be in the old_hpt
+                       return old_hmi

                        -- BCO is stable: nothing to do
 
                        -- BCO is stable: nothing to do
 

-                     | Just hmi <- old_hmi,
-                       Just l <- hm_linkable hmi, not (isObjectLinkable l),
-                       linkableTime l >= ms_hs_date summary ->
-                          compile_it (Just l)
+               | Just hmi <- old_hmi,
+                 Just l <- hm_linkable hmi, not (isObjectLinkable l),
+                 linkableTime l >= ms_hs_date summary ->
+                       compile_it (Just l)

                        -- we have an old BCO that is up to date with respect
                        -- to the source: do a recompilation check as normal.
 
                        -- we have an old BCO that is up to date with respect
                        -- to the source: do a recompilation check as normal.
 

-                     | otherwise ->
-                         compile_it Nothing
+               | otherwise -> 
+                        compile_it Nothing

                        -- no existing code at all: we must recompile.
                        -- no existing code at all: we must recompile.

-                  where
-                   is_stable_obj = this_mod_name `elem` stable_obj
-                   is_stable_bco = this_mod_name `elem` stable_bco

 
 

-                   old_hmi = lookupUFM old_hpt this_mod_name
+              -- When generating object code, if there's an up-to-date
+              -- object file on the disk, then we can use it.
+              -- However, if the object file is new (compared to any
+              -- linkable we had from a previous compilation), then we
+              -- must discard any in-memory interface, because this
+              -- means the user has compiled the source file
+              -- separately and generated a new interface, that we must
+              -- read from the disk.
+              --
+            obj | isObjectTarget obj,
+                 Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
+                     case old_hmi of
+                        Just hmi 
+                          | Just l <- hm_linkable hmi,
+                            isObjectLinkable l && linkableTime l == obj_date
+                            -> compile_it (Just l)
+                        _otherwise -> do
+                         linkable <- findObjectLinkable this_mod obj_fn obj_date
+                          compile_it_discard_iface (Just linkable)
+
+           _otherwise ->
+                 compile_it Nothing
+

 
 -- Run hsc to compile a module
 upsweep_compile hsc_env old_hpt this_mod summary
                 mod_index nmods
 
 -- Run hsc to compile a module
 upsweep_compile hsc_env old_hpt this_mod summary
                 mod_index nmods

-                mb_old_linkable = do
-  let
-       -- The old interface is ok if it's in the old HPT 
-       --      a) we're compiling a source file, and the old HPT
-       --         entry is for a source file
-       --      b) we're compiling a hs-boot file
-       -- Case (b) allows an hs-boot file to get the interface of its
-       -- real source file on the second iteration of the compilation
-       -- manager, but that does no harm.  Otherwise the hs-boot file
-       -- will always be recompiled
-
-        mb_old_iface 
-               = case lookupUFM old_hpt this_mod of
-                    Nothing                              -> Nothing
-                    Just hm_info | isBootSummary summary -> Just iface
-                                 | not (mi_boot iface)   -> Just iface
-                                 | otherwise             -> Nothing
-                                  where 
-                                    iface = hm_iface hm_info
-
-  compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+                mb_old_iface
+                mb_old_linkable
+ = do
+   compresult <- compile hsc_env summary mb_old_linkable mb_old_iface

                         mod_index nmods
 
                         mod_index nmods
 

-  case compresult of
+   case compresult of

         -- Compilation failed.  Compile may still have updated the PCS, tho.
         CompErrs -> return Nothing
 
         -- Compilation failed.  Compile may still have updated the PCS, tho.
         CompErrs -> return Nothing
 

@@ -1231,13 +1294,29 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
 
        -- We use integers as the keys for the SCC algorithm
        nodes :: [(ModSummary, Int, [Int])]     
 
        -- We use integers as the keys for the SCC algorithm
        nodes :: [(ModSummary, Int, [Int])]     

-       nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)), 
+       nodes = [(s, expectJust "topSort" $ 
+                       lookup_key (ms_hsc_src s) (ms_mod_name s),

                     out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
                     out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++

-                    out_edge_keys HsSrcFile   (map unLoc (ms_imps s))    )
+                    out_edge_keys HsSrcFile   (map unLoc (ms_imps s)) ++
+                    (-- see [boot-edges] below
+                     if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile 
+                       then [] 
+                       else case lookup_key HsBootFile (ms_mod_name s) of
+                               Nothing -> []
+                               Just k  -> [k])
+                )

                | s <- summaries
                , not (isBootSummary s && drop_hs_boot_nodes) ]
                -- Drop the hi-boot ones if told to do so
 
                | s <- summaries
                , not (isBootSummary s && drop_hs_boot_nodes) ]
                -- Drop the hi-boot ones if told to do so
 

+       -- [boot-edges] if this is a .hs and there is an equivalent
+       -- .hs-boot, add a link from the former to the latter.  This
+       -- has the effect of detecting bogus cases where the .hs-boot
+       -- depends on the .hs, by introducing a cycle.  Additionally,
+       -- it ensures that we will always process the .hs-boot before
+       -- the .hs, and so the HomePackageTable will always have the
+       -- most up to date information.
+

        key_map :: NodeMap Int
        key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
                            | s <- summaries]
        key_map :: NodeMap Int
        key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
                            | s <- summaries]

@@ -1267,6 +1346,24 @@ nodeMapElts = eltsFM
 ms_mod_name :: ModSummary -> ModuleName
 ms_mod_name = moduleName . ms_mod
 
 ms_mod_name :: ModSummary -> ModuleName
 ms_mod_name = moduleName . ms_mod
 

+-- If there are {-# SOURCE #-} imports between strongly connected
+-- components in the topological sort, then those imports can
+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
+-- were necessary, then the edge would be part of a cycle.
+warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO ()
+warnUnnecessarySourceImports dflags sccs = 
+  printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
+  where check ms =
+          let mods_in_this_cycle = map ms_mod_name ms in
+          [ warn m i | m <- ms, i <- ms_srcimps m,
+                       unLoc i `notElem`  mods_in_this_cycle ]
+
+       warn :: ModSummary -> Located ModuleName -> WarnMsg
+       warn ms (L loc mod) = 
+          mkPlainErrMsg loc
+               (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+                <+> quotes (ppr mod))
+

 -----------------------------------------------------------------------------
 -- Downsweep (dependency analysis)
 
 -----------------------------------------------------------------------------
 -- Downsweep (dependency analysis)
 

@@ -1676,9 +1773,12 @@ getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
        minf_type_env  :: TypeEnv,
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
        minf_type_env  :: TypeEnv,

-       minf_exports   :: NameSet,
+       minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?

        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
        minf_instances :: [Instance]
        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
        minf_instances :: [Instance]

+#ifdef GHCI
+        ,minf_modBreaks :: ModBreaks 
+#endif

        -- ToDo: this should really contain the ModIface too
   }
        -- We don't want HomeModInfo here, because a ModuleInfo applies
        -- ToDo: this should really contain the ModIface too
   }
        -- We don't want HomeModInfo here, because a ModuleInfo applies

@@ -1702,22 +1802,23 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do
 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
 getPackageModuleInfo hsc_env mdl = do
 #ifdef GHCI
 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
 getPackageModuleInfo hsc_env mdl = do
 #ifdef GHCI

-  (_msgs, mb_names) <- getModuleExports hsc_env mdl
-  case mb_names of
+  (_msgs, mb_avails) <- getModuleExports hsc_env mdl
+  case mb_avails of

     Nothing -> return Nothing
     Nothing -> return Nothing

-    Just names -> do
+    Just avails -> do

        eps <- readIORef (hsc_EPS hsc_env)
        let 
        eps <- readIORef (hsc_EPS hsc_env)
        let 

+            names  = availsToNameSet avails

            pte    = eps_PTE eps
            pte    = eps_PTE eps

-           n_list = nameSetToList names
-           tys    = [ ty | name <- n_list,
+           tys    = [ ty | name <- concatMap availNames avails,

                            Just ty <- [lookupTypeEnv pte name] ]
        --
        return (Just (ModuleInfo {
                        minf_type_env  = mkTypeEnv tys,
                        minf_exports   = names,
                        minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
                            Just ty <- [lookupTypeEnv pte name] ]
        --
        return (Just (ModuleInfo {
                        minf_type_env  = mkTypeEnv tys,
                        minf_exports   = names,
                        minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),

-                       minf_instances = error "getModuleInfo: instances for package module unimplemented"
+                       minf_instances = error "getModuleInfo: instances for package module unimplemented",
+                        minf_modBreaks = emptyModBreaks  

                }))
 #else
   -- bogusly different for non-GHCI (ToDo)
                }))
 #else
   -- bogusly different for non-GHCI (ToDo)

@@ -1731,9 +1832,12 @@ getHomeModuleInfo hsc_env mdl =
       let details = hm_details hmi
       return (Just (ModuleInfo {
                        minf_type_env  = md_types details,
       let details = hm_details hmi
       return (Just (ModuleInfo {
                        minf_type_env  = md_types details,

-                       minf_exports   = md_exports details,
+                       minf_exports   = availsToNameSet (md_exports details),

                        minf_rdr_env   = mi_globals $! hm_iface hmi,
                        minf_instances = md_insts details
                        minf_rdr_env   = mi_globals $! hm_iface hmi,
                        minf_instances = md_insts details

+#ifdef GHCI
+                       ,minf_modBreaks = md_modBreaks details  
+#endif

                        }))
 
 -- | The list of top-level entities defined in a module
                        }))
 
 -- | The list of top-level entities defined in a module

@@ -1767,6 +1871,10 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do
        return $! lookupType (hsc_dflags hsc_env) 
                            (hsc_HPT hsc_env) (eps_PTE eps) name
 
        return $! lookupType (hsc_dflags hsc_env) 
                            (hsc_HPT hsc_env) (eps_PTE eps) name
 

+#ifdef GHCI
+modInfoModBreaks = minf_modBreaks  
+#endif
+

 isDictonaryId :: Id -> Bool
 isDictonaryId id
   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
 isDictonaryId :: Id -> Bool
 isDictonaryId id
   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }

@@ -1832,7 +1940,7 @@ findModule' hsc_env mod_name maybe_pkg =
   case lookupUFM hpt mod_name of
     Just mod_info -> return (mi_module (hm_iface mod_info))
     _not_a_home_module -> do
   case lookupUFM hpt mod_name of
     Just mod_info -> return (mi_module (hm_iface mod_info))
     _not_a_home_module -> do

-         res <- findImportedModule hsc_env mod_name Nothing
+         res <- findImportedModule hsc_env mod_name maybe_pkg

          case res of
            Found _ m | modulePackageId m /= this_pkg -> return m
                      | otherwise -> throwDyn (CmdLineError (showSDoc $
          case res of
            Found _ m | modulePackageId m /= this_pkg -> return m
                      | otherwise -> throwDyn (CmdLineError (showSDoc $

@@ -1852,7 +1960,7 @@ setContext :: Session
           -> [Module]  -- entire top level scope of these modules
           -> [Module]  -- exports only of these modules
           -> IO ()
           -> [Module]  -- entire top level scope of these modules
           -> [Module]  -- exports only of these modules
           -> IO ()

-setContext (Session ref) toplev_mods export_mods = do 
+setContext sess@(Session ref) toplev_mods export_mods = do 

   hsc_env <- readIORef ref
   let old_ic  = hsc_IC     hsc_env
       hpt     = hsc_HPT    hsc_env
   hsc_env <- readIORef ref
   let old_ic  = hsc_IC     hsc_env
       hpt     = hsc_HPT    hsc_env

@@ -1864,15 +1972,14 @@ setContext (Session ref) toplev_mods export_mods = do
                                            ic_exports      = export_mods,
                                            ic_rn_gbl_env   = all_env }}
 
                                            ic_exports      = export_mods,
                                            ic_rn_gbl_env   = all_env }}
 

-

 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 mkExportEnv hsc_env mods = do
   stuff <- mapM (getModuleExports hsc_env) mods
   let 
        (_msgs, mb_name_sets) = unzip stuff
 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 mkExportEnv hsc_env mods = do
   stuff <- mapM (getModuleExports hsc_env) mods
   let 
        (_msgs, mb_name_sets) = unzip stuff

-       gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
-              | (Just name_set, mod) <- zip mb_name_sets mods ]
+       gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
+              | (Just avails, mod) <- zip mb_name_sets mods ]

   --
   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 
   --
   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 

@@ -2034,14 +2141,41 @@ data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
   | RunException Exception     -- ^ statement raised an exception
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
   | RunException Exception     -- ^ statement raised an exception

-
--- | Run a statement in the current interactive context.  Statemenet
+  | RunBreak ThreadId [Name] BreakInfo ResumeHandle
+
+data Status
+   = Break HValue BreakInfo ThreadId
+          -- ^ the computation hit a breakpoint
+   | Complete (Either Exception [HValue])
+          -- ^ the computation completed with either an exception or a value
+
+-- | This is a token given back to the client when runStmt stops at a
+-- breakpoint.  It allows the original computation to be resumed, restoring
+-- the old interactive context.
+data ResumeHandle
+  = ResumeHandle
+        (MVar ())               -- breakMVar
+        (MVar Status)           -- statusMVar
+        [Name]                  -- [Name] to bind on completion
+        InteractiveContext      -- IC on completion
+        InteractiveContext      -- IC to restore on resumption
+        [Name]                  -- [Name] to remove from the link env
+
+-- We need to track two InteractiveContexts:
+--      - the IC before runStmt, which is restored on each resume
+--      - the IC binding the results of the original statement, which
+--        will be the IC when runStmt returns with RunOk.
+
+-- | Run a statement in the current interactive context.  Statement

 -- may bind multple values.
 runStmt :: Session -> String -> IO RunResult
 runStmt (Session ref) expr
    = do 
        hsc_env <- readIORef ref
 
 -- may bind multple values.
 runStmt :: Session -> String -> IO RunResult
 runStmt (Session ref) expr
    = do 
        hsc_env <- readIORef ref
 

+        breakMVar  <- newEmptyMVar  -- wait on this when we hit a breakpoint
+        statusMVar <- newEmptyMVar  -- wait on this when a computation is running 
+

        -- Turn off -fwarn-unused-bindings when running a statement, to hide
        -- warnings about the implicit bindings we introduce.
        let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
        -- Turn off -fwarn-unused-bindings when running a statement, to hide
        -- warnings about the implicit bindings we introduce.
        let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds

@@ -2051,38 +2185,88 @@ runStmt (Session ref) expr
 
         case maybe_stuff of
           Nothing -> return RunFailed
 
         case maybe_stuff of
           Nothing -> return RunFailed

-          Just (new_hsc_env, names, hval) -> do
-
-               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-               either_hvals <- sandboxIO thing_to_run
-
+          Just (new_IC, names, hval) -> do
+
+              -- set the onBreakAction to be performed when we hit a
+              -- breakpoint this is visible in the Byte Code
+              -- Interpreter, thus it is a global variable,
+              -- implemented with stable pointers
+              stablePtr <- setBreakAction breakMVar statusMVar
+
+              let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+              status <- sandboxIO statusMVar thing_to_run
+              freeStablePtr stablePtr -- be careful not to leak stable pointers!
+              handleRunStatus ref new_IC names (hsc_IC hsc_env) 
+                              breakMVar statusMVar status
+
+handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
+   case status of  
+      -- did we hit a breakpoint or did we complete?
+      (Break apStack info tid) -> do
+        hsc_env <- readIORef ref
+        mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info))
+        let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info)
+        let index  = breakInfo_number info
+            occs   = modBreaks_vars breaks ! index
+            span   = modBreaks_locs breaks ! index
+        (new_hsc_env, names) <- extendEnvironment hsc_env apStack span
+                                        (breakInfo_vars info) 
+                                        (breakInfo_resty info) occs
+        writeIORef ref new_hsc_env 
+        let res = ResumeHandle breakMVar statusMVar final_names
+                               final_ic resume_ic names
+        return (RunBreak tid names info res)
+      (Complete either_hvals) ->

                case either_hvals of
                case either_hvals of

-                   Left e -> do
-                       -- on error, keep the *old* interactive context,
-                       -- so that 'it' is not bound to something
-                       -- that doesn't exist.
-                       return (RunException e)
-
+                   Left e -> return (RunException e)

                    Right hvals -> do
                    Right hvals -> do

-                       -- Get the newly bound things, and bind them.  
-                       -- Don't need to delete any shadowed bindings;
-                       -- the new ones override the old ones. 
-                       extendLinkEnv (zip names hvals)
-                       
-                       writeIORef ref new_hsc_env
-                       return (RunOk names)
+                        hsc_env <- readIORef ref
+                        writeIORef ref hsc_env{hsc_IC=final_ic}
+                       Linker.extendLinkEnv (zip final_names hvals)
+                       return (RunOk final_names)
+
+-- this points to the IO action that is executed when a breakpoint is hit
+foreign import ccall "&breakPointIOAction" 
+        breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) 

 
 -- When running a computation, we redirect ^C exceptions to the running
 -- 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".
 
 -- When running a computation, we redirect ^C exceptions to the running
 -- 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 :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
-  m <- newEmptyMVar
+sandboxIO :: MVar Status -> IO [HValue] -> IO Status
+sandboxIO statusMVar thing = do

   ts <- takeMVar interruptTargetThread
   ts <- takeMVar interruptTargetThread

-  child <- forkIO (do res <- Exception.try thing; putMVar m res)
+  child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))

   putMVar interruptTargetThread (child:ts)
   putMVar interruptTargetThread (child:ts)

-  takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
+  takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
+
+setBreakAction breakMVar statusMVar = do 
+  stablePtr <- newStablePtr onBreak
+  poke breakPointIOAction stablePtr
+  return stablePtr
+  where onBreak ids apStack = do
+                tid <- myThreadId
+                putMVar statusMVar (Break apStack ids tid)
+                takeMVar breakMVar
+
+resume :: Session -> ResumeHandle -> IO RunResult
+resume (Session ref) res@(ResumeHandle breakMVar statusMVar 
+                                       final_names final_ic resume_ic names)
+ = do
+   -- restore the original interactive context.  This is not entirely
+   -- satisfactory: any new bindings made since the breakpoint stopped
+   -- will be dropped from the interactive context, but not from the
+   -- linker's environment.
+   hsc_env <- readIORef ref
+   writeIORef ref hsc_env{ hsc_IC = resume_ic }
+   Linker.deleteFromLinkEnv names
+
+   stablePtr <- setBreakAction breakMVar statusMVar
+   putMVar breakMVar ()                 -- this awakens the stopped thread...
+   status <- takeMVar statusMVar        -- and wait for the result
+   freeStablePtr stablePtr -- be careful not to leak stable pointers!
+   handleRunStatus ref final_ic final_names resume_ic 
+                   breakMVar statusMVar status

 
 {-
 -- This version of sandboxIO runs the expression in a completely new
 
 {-
 -- This version of sandboxIO runs the expression in a completely new

@@ -2109,17 +2293,115 @@ sandboxIO thing = do
 foreign import "rts_evalStableIO"  {- safe -}
   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
   -- more informative than the C type!
 foreign import "rts_evalStableIO"  {- safe -}
   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
   -- more informative than the C type!

+
+XXX the type of rts_evalStableIO no longer matches the above
+

 -}
 
 -}
 

+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+-- Todo: turn this into a primop, and provide special version(s) for unboxed things
+foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+   -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+   apSptr <- newStablePtr apStack
+   resultSptr <- getApStackVal apSptr (stackDepth - 1)
+   result <- deRefStablePtr resultSptr
+   freeStablePtr apSptr
+   freeStablePtr resultSptr 
+   return (identifier, unsafeCoerce# result)
+
+extendEnvironment
+        :: HscEnv
+        -> a            -- the AP_STACK object built by the interpreter
+        -> SrcSpan
+        -> [(Id, Int)]  -- free variables and offsets into the AP_STACK
+        -> Type
+        -> [OccName]    -- names for the variables (from the source code)
+        -> IO (HscEnv, [Name])
+extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
+   idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
+   let (ids, hValues) = unzip idsVals 
+   new_ids <- zipWithM mkNewId occs ids
+   let names = map idName ids
+
+   -- make an Id for _result.  We use the Unique of the FastString "_result";
+   -- we don't care about uniqueness here, because there will only be one
+   -- _result in scope at any time.
+   let result_fs = FSLIT("_result")
+       result_name = mkInternalName (getUnique result_fs)
+                          (mkVarOccFS result_fs) (srcSpanStart span)
+       result_id   = Id.mkLocalId result_name result_ty
+
+   -- for each Id we're about to bind in the local envt:
+   --    - skolemise the type variables in its type, so they can't
+   --      be randomly unified with other types.  These type variables
+   --      can only be resolved by type reconstruction in RtClosureInspect
+   --    - tidy the type variables
+   --    - globalise the Id (Ids are supposed to be Global, apparently).
+   --
+   let all_ids = result_id : ids
+       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
+       new_tyvars = unionVarSets tyvarss             
+       new_ids = zipWith setIdType all_ids tidy_tys
+       global_ids = map (globaliseId VanillaGlobal) new_ids
+
+   let ictxt = extendInteractiveContext (hsc_IC hsc_env) 
+                                        global_ids new_tyvars
+
+   Linker.extendLinkEnv (zip names hValues)
+   Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+   return (hsc_env{hsc_IC = ictxt}, result_name:names)
+  where
+   mkNewId :: OccName -> Id -> IO Id
+   mkNewId occ id = do
+     let uniq = idUnique id
+         loc = nameSrcLoc (idName id)
+         name = mkInternalName uniq occ loc
+         ty = tidyTopType (idType id)
+         new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+     return new_id
+
+skolemiseTy :: Type -> (Type, TyVarSet)
+skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
+  where env           = mkVarEnv (zip tyvars new_tyvar_tys)
+        subst         = mkTvSubst emptyInScopeSet env
+        tyvars        = varSetElems (tyVarsOfType ty)
+        new_tyvars    = map skolemiseTyVar tyvars
+        new_tyvar_tys = map mkTyVarTy new_tyvars
+
+skolemiseTyVar :: TyVar -> TyVar
+skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
+                                 (SkolemTv RuntimeUnkSkol)
+

 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 
 showModule :: Session -> ModSummary -> IO String
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 
 showModule :: Session -> ModSummary -> IO String

-showModule s mod_summary = withSession s $ \hsc_env -> do
+showModule s mod_summary = withSession s $                        \hsc_env -> 
+                           isModuleInterpreted s mod_summary >>=  \interpreted -> 
+                           return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
+
+isModuleInterpreted :: Session -> ModSummary -> IO Bool
+isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> 

   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
        Nothing       -> panic "missing linkable"
   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
        Nothing       -> panic "missing linkable"

-       Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
+       Just mod_info -> return (not obj_linkable)

                      where
                         obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
                      where
                         obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 

+obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+
+obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
+obtainTerm sess force id = withSession sess $ \hsc_env -> do
+              mb_v <- Linker.getHValue (varName id) 
+              case mb_v of
+                Just v  -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
+                Nothing -> return Nothing
+

 #endif /* GHCI */
 #endif /* GHCI */