Enable stack traces with ghci -fexternal-interpreter -prof
authorSimon Marlow <marlowsd@gmail.com>
Thu, 7 Jan 2016 11:36:41 +0000 (11:36 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 8 Jan 2016 08:49:26 +0000 (08:49 +0000)
Summary:
The main goal here is enable stack traces in GHCi.  After this change,
if you start GHCi like this:

  ghci -fexternal-interpreter -prof

(which requires packages to be built for profiling, but not GHC
itself) then the interpreter manages cost-centre stacks during
execution and can produce a stack trace on request.  Call locations
are available for all interpreted code, and any compiled code that was
built with the `-fprof-auto` familiy of flags.

There are a couple of ways to get a stack trace:

* `error`/`undefined` automatically get one attached
* `Debug.Trace.traceStack` can be used anywhere, and prints the current
  stack

Because the interpreter is running in a separate process, only the
interpreted code is running in profiled mode and the compiler itself
isn't slowed down by profiling.

The GHCi debugger still doesn't work with -fexternal-interpreter,
although this patch gets it a step closer.  Most of the functionality
of breakpoints is implemented, but the runtime value introspection is
still not supported.

Along the way I also did some refactoring and added type arguments to
the various remote pointer types in `GHCi.RemotePtr`, so there's
better type safety and documentation in the bridge code between GHC
and ghc-iserv.

Test Plan: validate

Reviewers: bgamari, ezyang, austin, hvr, goldfire, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1747

GHC Trac Issues: #11047, #11100

39 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeInstr.hs
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/ByteCodeLink.hs
compiler/ghci/ByteCodeTypes.hs
compiler/ghci/Debugger.hs
compiler/ghci/GHCi.hs
compiler/ghci/Linker.hs
compiler/main/DriverPipeline.hs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/main/InteractiveEvalTypes.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
ghc.mk
ghc/GHCi/UI.hs
ghc/GHCi/UI/Monad.hs
libraries/ghci/GHCi/BreakArray.hs [moved from compiler/main/BreakArray.hs with 88% similarity]
libraries/ghci/GHCi/CreateBCO.hs
libraries/ghci/GHCi/FFI.hsc
libraries/ghci/GHCi/InfoTable.hsc
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/ObjLink.hs
libraries/ghci/GHCi/RemoteTypes.hs
libraries/ghci/GHCi/ResolvedBCO.hs
libraries/ghci/GHCi/Run.hs
libraries/ghci/GHCi/TH.hs
libraries/ghci/ghci.cabal.in
rts/Exception.cmm
rts/Interpreter.c
rules/build-prog.mk
testsuite/tests/ghci.debugger/scripts/break021.stdout

index 0801422..b0543ed 100644 (file)
@@ -10,6 +10,9 @@ module Coverage (addTicksToBinds, hpcInitCode) where
 #ifdef GHCI
 import qualified GHCi
 import GHCi.RemoteTypes
+import Data.Array
+import ByteCodeTypes
+import GHC.Stack.CCS
 #endif
 import Type
 import HsSyn
@@ -37,14 +40,14 @@ import Maybes
 import CLabel
 import Util
 
-import Data.Array
 import Data.Time
+import Foreign.C
 import System.Directory
 
 import Trace.Hpc.Mix
 import Trace.Hpc.Util
 
-import BreakArray
+import qualified Data.ByteString as B
 import Data.Map (Map)
 import qualified Data.Map as Map
 
@@ -65,7 +68,7 @@ addTicksToBinds
                                 -- hasn't set it), so we have to work from this set.
         -> [TyCon]              -- Type constructor in this module
         -> LHsBinds Id
-        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
+        -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)
 
 addTicksToBinds hsc_env mod mod_loc exports tyCons binds
   | let dflags = hsc_dflags hsc_env
@@ -73,7 +76,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
     Just orig_file <- ml_hs_file mod_loc = do
 
      if "boot" `isSuffixOf` orig_file
-         then return (binds, emptyHpcInfo False, emptyModBreaks)
+         then return (binds, emptyHpcInfo False, Nothing)
          else do
 
      us <- mkSplitUniqSupply 'C' -- for cost centres
@@ -93,7 +96,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
                       , density      = mkDensity tickish dflags
                       , this_mod     = mod
                       , tickishType  = tickish
-                      }
+}
                 (binds',_,st') = unTM (addTickLHsBinds binds) env st
             in (binds', st')
 
@@ -113,9 +116,9 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
          log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
              (pprLHsBinds binds1)
 
-     return (binds1, HpcInfo tickCount hashNo, modBreaks)
+     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
 
-  | otherwise = return (binds, emptyHpcInfo False, emptyModBreaks)
+  | otherwise = return (binds, emptyHpcInfo False, Nothing)
 
 guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
 guessSourceFile binds orig_file =
@@ -131,12 +134,13 @@ guessSourceFile binds orig_file =
 
 
 mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+#ifndef GHCI
+mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks
+#else
 mkModBreaks hsc_env mod count entries
   | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
-    breakArray <- newBreakArray (length entries)
-#ifdef GHCI
+    breakArray <- GHCi.newBreakArray hsc_env (length entries)
     ccs <- mkCCSArray hsc_env mod count entries
-#endif
     let
            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
            varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
@@ -146,31 +150,30 @@ mkModBreaks hsc_env mod count entries
                        , modBreaks_locs  = locsTicks
                        , modBreaks_vars  = varsTicks
                        , modBreaks_decls = declsTicks
-#ifdef GHCI
                        , modBreaks_ccs   = ccs
-#endif
                        }
   | otherwise = return emptyModBreaks
 
-#ifdef GHCI
 mkCCSArray
   :: HscEnv -> Module -> Int -> [MixEntry_]
-  -> IO (Array BreakIndex RemotePtr {- CCostCentre -})
+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
 mkCCSArray hsc_env modul count entries = do
   if interpreterProfiled (hsc_dflags hsc_env)
     then do
       let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
-      c_module <- GHCi.mallocData hsc_env module_bs
-      costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries
+      c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0)
+        -- NB. null-terminate the string
+      costcentres <-
+        mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries
       return (listArray (0,count-1) costcentres)
     else do
       return (listArray (0,-1) [])
  where
     mkCostCentre
      :: HscEnv
-     -> RemotePtr {- CChar -}
+     -> RemotePtr CChar
      -> MixEntry_
-     -> IO (RemotePtr {- CCostCentre -})
+     -> IO (RemotePtr GHC.Stack.CCS.CostCentre)
     mkCostCentre hsc_env@HscEnv{..}  c_module (srcspan, decl_path, _, _) = do
       let name = concat (intersperse "." decl_path)
           src = showSDoc hsc_dflags (ppr srcspan)
@@ -1010,9 +1013,7 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
 
 coveragePasses :: DynFlags -> [TickishType]
 coveragePasses dflags =
-    ifa (hscTarget dflags == HscInterpreted &&
-         not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $
-         -- TODO: breakpoints don't work with -fexternal-interpreter yet
+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
     ifa (gopt Opt_Hpc dflags)                HpcTicks $
     ifa (gopt Opt_SccProfilingOn dflags &&
          profAuto dflags /= NoProfAuto)      ProfNotes $
index d7fff69..da6085d 100644 (file)
@@ -302,7 +302,7 @@ deSugar hsc_env
                          <- if not (isHsBootOrSig hsc_src)
                               then addTicksToBinds hsc_env mod mod_loc
                                        export_set (typeEnvTyCons type_env) binds
-                              else return (binds, hpcInfo, emptyModBreaks)
+                              else return (binds, hpcInfo, Nothing)
 
         ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
                        do { ds_ev_binds <- dsEvBinds ev_binds
index 4264b66..d0e74b0 100644 (file)
@@ -306,7 +306,6 @@ Library
         TcIface
         FlagChecker
         Annotations
-        BreakArray
         CmdLineParser
         CodeOutput
         Config
index e4d9ee4..c11a36c 100644 (file)
@@ -454,7 +454,6 @@ compiler_stage2_dll0_MODULES = \
        BasicTypes \
        Binary \
        BooleanFormula \
-       BreakArray \
        BufWrite \
        Class \
        CmdLineParser \
index 4145053..6974620 100644 (file)
@@ -32,6 +32,7 @@ import DynFlags
 import Outputable
 import Platform
 import Util
+import Unique
 
 -- From iserv
 import SizedSeq
@@ -86,11 +87,18 @@ bcoFreeNames bco
 -- bytecode address in this BCO.
 
 -- Top level assembler fn.
-assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs hsc_env proto_bcos tycons = do
+assembleBCOs
+  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks
+  -> IO CompiledByteCode
+assembleBCOs hsc_env proto_bcos tycons modbreaks = do
   itblenv <- mkITbls hsc_env tycons
   bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
-  return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
+  return CompiledByteCode
+    { bc_bcos = bcos
+    , bc_itbls =  itblenv
+    , bc_ffis = concat (map protoBCOFFIs proto_bcos)
+    , bc_breaks = modbreaks
+    }
 
 assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
 assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
@@ -356,11 +364,11 @@ assembleI dflags i = case i of
   RETURN_UBX rep           -> emit (return_ubx rep) []
   CCALL off m_addr i       -> do np <- addr m_addr
                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]
-  BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array)
-                                    p2 <- ptr (BCOPtrBreakInfo info)
-                                    np <- addr cc
-                                    emit bci_BRK_FUN [Op p1, SmallOp index,
-                                                      Op p2, Op np]
+  BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray
+                                 q <- int (getKey uniq)
+                                 np <- addr cc
+                                 emit bci_BRK_FUN [Op p1, SmallOp index,
+                                                   Op q, Op np]
 
   where
     literal (MachLabel fs (Just sz) _)
@@ -474,14 +482,7 @@ mkLitI64 dflags ii
    | otherwise
    = panic "mkLitI64: Bad wORD_SIZE"
 
-mkLitI i
-   = runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 i
-        i_arr <- castSTUArray arr
-        w0 <- readArray i_arr 0
-        return [w0 :: Word]
-     )
+mkLitI i = [fromIntegral i :: Word]
 
 iNTERP_STACK_CHECK_THRESH :: Int
 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
index 4311fcd..4c9e0b4 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -44,6 +44,7 @@ import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
 import SMRep
 import Bitmap
 import OrdList
+import Maybes
 
 import Data.List
 import Foreign
@@ -51,16 +52,17 @@ import Control.Monad
 import Data.Char
 
 import UniqSupply
-import BreakArray
-import Data.Maybe
 import Module
 import Control.Arrow ( second )
 
 import Data.Array
 import Data.Map (Map)
+import Data.IntMap (IntMap)
 import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
 import qualified FiniteMap as Map
 import Data.Ord
+import GHC.Stack.CCS
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module
@@ -69,9 +71,9 @@ byteCodeGen :: HscEnv
             -> Module
             -> CoreProgram
             -> [TyCon]
-            -> ModBreaks
+            -> Maybe ModBreaks
             -> IO CompiledByteCode
-byteCodeGen hsc_env this_mod binds tycs modBreaks
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
    = do let dflags = hsc_dflags hsc_env
         showPass dflags "ByteCodeGen"
 
@@ -79,8 +81,9 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks
                         | (bndr, rhs) <- flattenBinds binds]
 
         us <- mkSplitUniqSupply 'y'
-        (BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos)
-           <- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds)
+        (BcM_State{..}, proto_bcos) <-
+           runBc hsc_env us this_mod mb_modBreaks $
+             mapM schemeTopBind flatBinds
 
         when (notNull ffis)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -89,12 +92,14 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks
            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
         assembleBCOs hsc_env proto_bcos tycs
+          (case modBreaks of
+             Nothing -> Nothing
+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for an expression
 
--- Returns: (the root BCO for this expression,
---           a list of auxilary BCOs resulting from compiling closures)
+-- Returns: the root BCO for this expression
 coreExprToBCOs :: HscEnv
                -> Module
                -> CoreExpr
@@ -111,8 +116,8 @@ coreExprToBCOs hsc_env this_mod expr
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
-         <- runBc hsc_env us this_mod emptyModBreaks $
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
+         <- runBc hsc_env us this_mod Nothing $
               schemeTopBind (invented_id, simpleFreeVars expr)
 
       when (notNull mallocd)
@@ -331,22 +336,18 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
   = do  code <- schemeE (fromIntegral d) 0 p newRhs
-        flag_arr <- getBreakArray
         cc_arr <- getCCArray
-        this_mod <- getCurrentModule
+        this_mod <- moduleName <$> getCurrentModule
         let idOffSets = getVarOffSets d p fvs
-        let breakInfo = BreakInfo
-                        { breakInfo_module = this_mod
-                        , breakInfo_number = tick_no
-                        , breakInfo_vars = idOffSets
-                        , breakInfo_resty = exprType (deAnnotate' newRhs)
+        let breakInfo = CgBreakInfo
+                        { cgb_vars = idOffSets
+                        , cgb_resty = exprType (deAnnotate' newRhs)
                         }
+        newBreakInfo tick_no breakInfo
         dflags <- getDynFlags
         let cc | interpreterProfiled dflags = cc_arr ! tick_no
                | otherwise = toRemotePtr nullPtr
-        let breakInstr = case flag_arr of
-                         BA arr# ->
-                             BRK_FUN arr# (fromIntegral tick_no) breakInfo cc
+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
         return $ breakInstr `consOL` code
    | otherwise = schemeE (fromIntegral d) 0 p rhs
 
@@ -1642,7 +1643,8 @@ data BcM_State
         , nextlabel   :: Word16          -- for generating local labels
         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
-        , modBreaks :: ModBreaks         -- info about breakpoints
+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
+        , breakInfo   :: IntMap CgBreakInfo
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1652,10 +1654,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
       -> IO (BcM_State, r)
 runBc hsc_env us this_mod modBreaks (BcM m)
-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks)
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -1695,7 +1697,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
 
-recordFFIBc :: RemotePtr -> BcM ()
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
 recordFFIBc a
   = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
 
@@ -1711,11 +1713,15 @@ getLabelsBc n
   = BcM $ \st -> let ctr = nextlabel st
                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
 
-getBreakArray :: BcM BreakArray
-getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st))
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+  return (st, modBreaks_ccs breaks)
 
-getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -})
-getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st))
+
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
 
 newUnique :: BcM Unique
 newUnique = BcM $
index 74c4f96..985bec4 100644 (file)
@@ -14,11 +14,13 @@ module ByteCodeInstr (
 
 import ByteCodeTypes
 import GHCi.RemoteTypes
+import GHCi.FFI (C_ffi_cif)
 import StgCmmLayout     ( ArgRep(..) )
 import PprCore
 import Outputable
 import FastString
 import Name
+import Unique
 import Id
 import CoreSyn
 import Literal
@@ -27,8 +29,8 @@ import VarSet
 import PrimOp
 import SMRep
 
-import GHC.Exts
 import Data.Word
+import GHC.Stack.CCS (CostCentre)
 
 -- ----------------------------------------------------------------------------
 -- Bytecode instructions
@@ -125,7 +127,7 @@ data BCInstr
 
    -- For doing calls to C (via glue code generated by libffi)
    | CCALL            Word16    -- stack frame size
-                      RemotePtr -- addr of the glue code
+                      (RemotePtr C_ffi_cif) -- addr of the glue code
                       Word16    -- whether or not the call is interruptible
                                 -- (XXX: inefficient, but I don't know
                                 -- what the alignment constraints are.)
@@ -140,7 +142,7 @@ data BCInstr
    | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
 
    -- Breakpoints
-   | BRK_FUN          (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr
+   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)
 
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions
@@ -240,7 +242,7 @@ instance Outputable BCInstr where
    ppr ENTER                 = text "ENTER"
    ppr RETURN                = text "RETURN"
    ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
-   ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>"
+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
 
 -- -----------------------------------------------------------------------------
 -- The stack use, in words, of each bytecode insn.  These _must_ be
index 5a3e6d3..4e1c828 100644 (file)
@@ -11,7 +11,6 @@ module ByteCodeItbls ( mkITbls ) where
 
 import ByteCodeTypes
 import GHCi
-import GHCi.RemoteTypes
 import DynFlags
 import HscTypes
 import Name             ( Name, getName )
@@ -70,4 +69,4 @@ make_constr_itbls hsc_env cons =
          descr = dataConIdentity dcon
 
      r <- iservCmd hsc_env (MkConInfoTable  ptrs' nptrs_really conNo descr)
-     return (getName dcon, ItblPtr (fromRemotePtr r))
+     return (getName dcon, ItblPtr r)
index aa92ecc..74f490b 100644 (file)
@@ -22,6 +22,7 @@ module ByteCodeLink (
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
 import GHCi.InfoTable
+import GHCi.BreakArray
 import SizedSeq
 
 import GHCi
@@ -60,15 +61,16 @@ extendClosureEnv cl_env pairs
 -}
 
 linkBCO
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> UnlinkedBCO
   -> IO ResolvedBCO
-linkBCO hsc_env ie ce bco_ix
+linkBCO hsc_env ie ce bco_ix breakarray
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)
-  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0)
+  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
   return (ResolvedBCO arity insns bitmap
-            (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
-            (addListToSS emptySS ptrs))
+              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+              (addListToSS emptySS ptrs))
 
 lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
 lookupLiteral _ _ (BCONPtrWord lit) = return lit
@@ -79,7 +81,7 @@ lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do
   Ptr a# <- lookupIE hsc_env ie nm
   return (W# (int2Word# (addr2Int# a#)))
 lookupLiteral hsc_env _ (BCONPtrStr bs) = do
-  fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs
+  fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs
 
 lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
 lookupStaticPtr hsc_env addr_of_label_string = do
@@ -89,26 +91,26 @@ lookupStaticPtr hsc_env addr_of_label_string = do
     Nothing  -> linkFail "ByteCodeLink: can't find label"
                   (unpackFS addr_of_label_string)
 
-lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a)
+lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
 lookupIE hsc_env ie con_nm =
   case lookupNameEnv ie con_nm of
-    Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a))
+    Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
     Nothing -> do -- try looking up in the object files.
        let sym_to_find1 = nameToCLabel con_nm "con_info"
        m <- lookupSymbol hsc_env sym_to_find1
        case m of
-          Just addr -> return (castPtr addr)
+          Just addr -> return addr
           Nothing
              -> do -- perhaps a nullary constructor?
                    let sym_to_find2 = nameToCLabel con_nm "static_info"
                    n <- lookupSymbol hsc_env sym_to_find2
                    case n of
-                      Just addr -> return (castPtr addr)
+                      Just addr -> return addr
                       Nothing   -> linkFail "ByteCodeLink.lookupIE"
                                       (unpackFS sym_to_find1 ++ " or " ++
                                        unpackFS sym_to_find2)
 
-lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr
+lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
 lookupPrimOp hsc_env primop = do
   let sym_to_find = primopToCLabel primop "closure"
   m <- lookupSymbol hsc_env (mkFastString sym_to_find)
@@ -117,13 +119,14 @@ lookupPrimOp hsc_env primop = do
     Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 
 resolvePtr
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> BCOPtr
   -> IO ResolvedBCOPtr
-resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
+resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
   | Just ix <- lookupNameEnv bco_ix nm =
     return (ResolvedBCORef ix) -- ref to another BCO in this group
   | Just (_, rhv) <- lookupNameEnv ce nm =
-    return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv))
+    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
   | otherwise =
     ASSERT2(isExternalName nm, ppr nm)
     do let sym_to_find = nameToCLabel nm "closure"
@@ -131,14 +134,12 @@ resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
        case m of
          Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
          Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
-resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
+resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
   ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
-resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) =
-  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco
-resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) =
-  return (ResolvedBCOPtrLocal (unsafeCoerce# break_info))
-resolvePtr _ _ _ _ (BCOPtrArray break_array) =
-  return (ResolvedBCOPtrLocal (unsafeCoerce# break_array))
+resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
+  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
+resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
+  return (ResolvedBCOPtrBreakArray breakarray)
 
 linkFail :: String -> String -> IO a
 linkFail who what
index 500fd77..944000a 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MagicHash, RecordWildCards #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -8,43 +8,55 @@ module ByteCodeTypes
   ( CompiledByteCode(..), FFIInfo(..)
   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
   , ItblEnv, ItblPtr(..)
-  , BreakInfo(..)
+  , CgBreakInfo(..)
+  , ModBreaks (..), BreakIndex, emptyModBreaks
+  , CCostCentre
   ) where
 
 import FastString
 import Id
-import Module
 import Name
 import NameEnv
 import Outputable
 import PrimOp
 import SizedSeq
 import Type
+import SrcLoc
+import GHCi.BreakArray
 import GHCi.RemoteTypes
+import GHCi.FFI
+import GHCi.InfoTable
 
 import Foreign
+import Data.Array
 import Data.Array.Base  ( UArray(..) )
 import Data.ByteString (ByteString)
-import GHC.Exts
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import GHC.Stack.CCS
 
+-- -----------------------------------------------------------------------------
+-- Compiled Byte Code
 
-data CompiledByteCode
-  = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
-             ItblEnv       -- A mapping from DataCons to their itbls
-             [FFIInfo]     -- ffi blocks we allocated
+data CompiledByteCode = CompiledByteCode
+  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
+  , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
+  , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
+  , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
+                                 -- creating breakpoints, for some reason)
+  }
                 -- ToDo: we're not tracking strings that we malloc'd
-
-newtype FFIInfo = FFIInfo RemotePtr
+newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
   deriving Show
 
 instance Outputable CompiledByteCode where
-  ppr (ByteCode bcos _ _) = ppr bcos
+  ppr CompiledByteCode{..} = ppr bc_bcos
 
 type ItblEnv = NameEnv (Name, ItblPtr)
         -- We need the Name in the range so we know which
         -- elements to filter out when unloading a module
 
-newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
+newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) deriving Show
 
 data UnlinkedBCO
    = UnlinkedBCO {
@@ -60,8 +72,7 @@ data BCOPtr
   = BCOPtrName   Name
   | BCOPtrPrimOp PrimOp
   | BCOPtrBCO    UnlinkedBCO
-  | BCOPtrBreakInfo  BreakInfo
-  | BCOPtrArray (MutableByteArray# RealWorld)
+  | BCOPtrBreakArray  -- a pointer to this module's BreakArray
 
 data BCONPtr
   = BCONPtrWord  Word
@@ -69,12 +80,11 @@ data BCONPtr
   | BCONPtrItbl  Name
   | BCONPtrStr   ByteString
 
-data BreakInfo
-   = BreakInfo
-   { breakInfo_module :: Module
-   , breakInfo_number :: {-# UNPACK #-} !Int
-   , breakInfo_vars   :: [(Id,Word16)]
-   , breakInfo_resty  :: Type
+-- | Information about a breakpoint that we know at code-generation time
+data CgBreakInfo
+   = CgBreakInfo
+   { cgb_vars   :: [(Id,Word16)]
+   , cgb_resty  :: Type
    }
 
 instance Outputable UnlinkedBCO where
@@ -83,9 +93,46 @@ instance Outputable UnlinkedBCO where
              ppr (sizeSS lits), text "lits",
              ppr (sizeSS ptrs), text "ptrs" ]
 
-instance Outputable BreakInfo where
-   ppr info = text "BreakInfo" <+>
-              parens (ppr (breakInfo_module info) <+>
-                      ppr (breakInfo_number info) <+>
-                      ppr (breakInfo_vars info) <+>
-                      ppr (breakInfo_resty info))
+instance Outputable CgBreakInfo where
+   ppr info = text "CgBreakInfo" <+>
+              parens (ppr (cgb_vars info) <+>
+                      ppr (cgb_resty info))
+
+-- -----------------------------------------------------------------------------
+-- Breakpoints
+
+-- | Breakpoint index
+type BreakIndex = Int
+
+-- | C CostCentre type
+data CCostCentre
+
+-- | All the information about the breakpoints for a module
+data ModBreaks
+   = ModBreaks
+   { modBreaks_flags :: ForeignRef BreakArray
+        -- ^ The array of flags, one per breakpoint,
+        -- indicating which breakpoints are enabled.
+   , modBreaks_locs :: !(Array BreakIndex SrcSpan)
+        -- ^ An array giving the source span of each breakpoint.
+   , modBreaks_vars :: !(Array BreakIndex [OccName])
+        -- ^ An array giving the names of the free variables at each breakpoint.
+   , modBreaks_decls :: !(Array BreakIndex [String])
+        -- ^ An array giving the names of the declarations enclosing each breakpoint.
+   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))
+        -- ^ Array pointing to cost centre for each breakpoint
+   , modBreaks_breakInfo :: IntMap CgBreakInfo
+        -- ^ info about each breakpoint from the bytecode generator
+   }
+
+-- | Construct an empty ModBreaks
+emptyModBreaks :: ModBreaks
+emptyModBreaks = ModBreaks
+   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
+         -- ToDo: can we avoid this?
+   , modBreaks_locs  = array (0,-1) []
+   , modBreaks_vars  = array (0,-1) []
+   , modBreaks_decls = array (0,-1) []
+   , modBreaks_ccs = array (0,-1) []
+   , modBreaks_breakInfo = IntMap.empty
+   }
index 5c6a02d..81aab36 100644 (file)
@@ -119,7 +119,7 @@ bindSuspensions t = do
       let ids = [ mkVanillaGlobal name ty
                 | (name,ty) <- zip names tys]
           new_ic = extendInteractiveContextWithIds ictxt ids
-      fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) hvals
+      fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
       liftIO $ extendLinkEnv (zip names fhvs)
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
       return t'
@@ -173,7 +173,7 @@ showTerm term = do
            let noop_log _ _ _ _ _ = return ()
                expr = "show " ++ showPpr dflags bname
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
-           fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkHValueRef val
+           fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
            txt_ <- withExtendedLinkEnv [(bname, fhv)]
                                        (GHC.compileExpr expr)
            let myprec = 10 -- application precedence. TODO Infix constructors
index b7e0eb3..2b4abdd 100644 (file)
@@ -6,7 +6,7 @@
 --
 module GHCi
   ( -- * High-level interface to the interpreter
-    evalStmt, EvalStatus(..), EvalResult(..), EvalExpr(..)
+    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
   , resumeStmt
   , abandonStmt
   , evalIO
@@ -15,6 +15,9 @@ module GHCi
   , mallocData
   , mkCostCentre
   , costCentreStackInfo
+  , newBreakArray
+  , enableBreakpoint
+  , breakpointStatus
 
   -- * The object-code linker
   , initObjLinker
@@ -43,6 +46,7 @@ module GHCi
 import GHCi.Message
 import GHCi.Run
 import GHCi.RemoteTypes
+import GHCi.BreakArray (BreakArray)
 import HscTypes
 import UniqFM
 import Panic
@@ -62,6 +66,8 @@ import Data.Binary
 import Data.ByteString (ByteString)
 import Data.IORef
 import Foreign
+import Foreign.C
+import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Exit
 #ifndef mingw32_HOST_OS
 import Data.Maybe
@@ -178,7 +184,8 @@ withIServ HscEnv{..} action =
 -- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
 -- each of the results.
 evalStmt
-  :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus [ForeignHValue])
+  :: HscEnv -> Bool -> EvalExpr ForeignHValue
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 evalStmt hsc_env step foreign_expr = do
   let dflags = hsc_dflags hsc_env
   status <- withExpr foreign_expr $ \expr ->
@@ -187,29 +194,32 @@ evalStmt hsc_env step foreign_expr = do
  where
   withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
   withExpr (EvalThis fhv) cont =
-    withForeignHValue fhv $ \hvref -> cont (EvalThis hvref)
+    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
   withExpr (EvalApp fl fr) cont =
     withExpr fl $ \fl' ->
     withExpr fr $ \fr' ->
     cont (EvalApp fl' fr')
 
-resumeStmt :: HscEnv -> Bool -> ForeignHValue -> IO (EvalStatus [ForeignHValue])
+resumeStmt
+  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 resumeStmt hsc_env step resume_ctxt = do
   let dflags = hsc_dflags hsc_env
-  status <- withForeignHValue resume_ctxt $ \rhv ->
+  status <- withForeignRef resume_ctxt $ \rhv ->
     iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
   handleEvalStatus hsc_env status
 
-abandonStmt :: HscEnv -> ForeignHValue -> IO ()
+abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
 abandonStmt hsc_env resume_ctxt = do
-  withForeignHValue resume_ctxt $ \rhv ->
+  withForeignRef resume_ctxt $ \rhv ->
     iservCmd hsc_env (AbandonStmt rhv)
 
 handleEvalStatus
-  :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue])
+  :: HscEnv -> EvalStatus [HValueRef]
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 handleEvalStatus hsc_env status =
   case status of
-    EvalBreak a b c d e -> return (EvalBreak a b c d e)
+    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
     EvalComplete alloc res ->
       EvalComplete alloc <$> addFinalizer res
  where
@@ -220,38 +230,53 @@ handleEvalStatus hsc_env status =
 -- | Execute an action of type @IO ()@
 evalIO :: HscEnv -> ForeignHValue -> IO ()
 evalIO hsc_env fhv = do
-  liftIO $ withForeignHValue fhv $ \fhv ->
+  liftIO $ withForeignRef fhv $ \fhv ->
     iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
 
 -- | Execute an action of type @IO String@
 evalString :: HscEnv -> ForeignHValue -> IO String
 evalString hsc_env fhv = do
-  liftIO $ withForeignHValue fhv $ \fhv ->
+  liftIO $ withForeignRef fhv $ \fhv ->
     iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
 
 -- | Execute an action of type @String -> IO String@
 evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
 evalStringToIOString hsc_env fhv str = do
-  liftIO $ withForeignHValue fhv $ \fhv ->
+  liftIO $ withForeignRef fhv $ \fhv ->
     iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
 
 
 -- | Allocate and store the given bytes in memory, returning a pointer
 -- to the memory in the remote process.
-mallocData :: HscEnv -> ByteString -> IO (Ptr ())
-mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs)
+mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
+mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
 
 mkCostCentre
-  :: HscEnv -> RemotePtr {- CChar -} -> String -> String
-  -> IO RemotePtr {- CCostCentre -}
+  :: HscEnv -> RemotePtr CChar -> String -> String -> IO (RemotePtr CostCentre)
 mkCostCentre hsc_env c_module name src =
   iservCmd hsc_env (MkCostCentre c_module name src)
 
 
-costCentreStackInfo :: HscEnv -> RemotePtr {- CCostCentreStack -} -> IO [String]
+costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
 costCentreStackInfo hsc_env ccs =
   iservCmd hsc_env (CostCentreStackInfo ccs)
 
+newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
+newBreakArray hsc_env size = do
+  breakArray <- iservCmd hsc_env (NewBreakArray size)
+  mkFinalizedHValue hsc_env breakArray
+
+enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
+enableBreakpoint hsc_env ref ix b = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (EnableBreakpoint breakarray ix b)
+
+breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
+breakpointStatus hsc_env ref ix = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (BreakpointStatus breakarray ix)
+
+
 -- -----------------------------------------------------------------------------
 -- Interface to the object-code linker
 
@@ -459,14 +484,15 @@ principle it would probably be ok, but it seems less hairy this way.
 
 -- | Creates a 'ForeignHValue' that will automatically release the
 -- 'HValueRef' when it is no longer referenced.
-mkFinalizedHValue :: HscEnv -> HValueRef -> IO ForeignHValue
-mkFinalizedHValue HscEnv{..} hvref = mkForeignHValue hvref free
+mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
+mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
  where
   !external = gopt Opt_ExternalInterpreter hsc_dflags
+  hvref = toHValueRef rref
 
   free :: IO ()
   free
-    | not external = freeHValueRef hvref
+    | not external = freeRemoteRef hvref
     | otherwise =
       modifyMVar_ hsc_iserv $ \mb_iserv ->
         case mb_iserv of
@@ -481,19 +507,19 @@ freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
 -- | Convert a 'ForeignHValue' to an 'HValue' directly.  This only works
 -- when the interpreter is running in the same process as the compiler,
 -- so it fails when @-fexternal-interpreter@ is on.
-wormhole :: DynFlags -> ForeignHValue -> IO HValue
-wormhole dflags r = wormholeRef dflags (unsafeForeignHValueToHValueRef r)
+wormhole :: DynFlags -> ForeignRef a -> IO a
+wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
 
 -- | Convert an 'HValueRef' to an 'HValue' directly.  This only works
 -- when the interpreter is running in the same process as the compiler,
 -- so it fails when @-fexternal-interpreter@ is on.
-wormholeRef :: DynFlags -> HValueRef -> IO HValue
+wormholeRef :: DynFlags -> RemoteRef a -> IO a
 wormholeRef dflags r
   | gopt Opt_ExternalInterpreter dflags
   = throwIO (InstallationError
       "this operation requires -fno-external-interpreter")
   | otherwise
-  = localHValueRef r
+  = localRef r
 
 -- -----------------------------------------------------------------------------
 -- Misc utils
index 7e86e11..8f1107f 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
 {-# OPTIONS_GHC -fno-cse #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -496,7 +496,10 @@ linkExpr hsc_env span root_ul_bco
 
      -- Link the necessary packages and linkables
 
-   ; [(_,root_hvref)] <- linkSomeBCOs hsc_env ie ce [root_ul_bco]
+   ; let nobreakarray = error "no break array"
+         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
+   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
+   ; [root_hvref] <- iservCmd hsc_env (CreateBCOs [resolved])
    ; fhv <- mkFinalizedHValue hsc_env root_hvref
    ; return (pls, fhv)
    }}}
@@ -703,7 +706,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
   ********************************************************************* -}
 
 linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
-linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do
+linkDecls hsc_env span cbc@CompiledByteCode{..} = do
     -- Initialise the linker (if it's not been done already)
     initDynLinker hsc_env
 
@@ -717,17 +720,17 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do
       else do
 
     -- Link the expression itself
-    let ie = plusNameEnv (itbl_env pls) itblEnv
+    let ie = plusNameEnv (itbl_env pls) bc_itbls
         ce = closure_env pls
 
     -- Link the necessary packages and linkables
-    new_bindings <- linkSomeBCOs hsc_env ie ce unlinkedBCOs
+    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
     nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
     let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                    , itbl_env    = ie }
     return (pls2, ())
   where
-    free_names =  concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs
+    free_names =  concatMap (nameSetElems . bcoFreeNames) bc_bcos
 
     needed_mods :: [Module]
     needed_mods = [ nameModule n | n <- free_names,
@@ -914,12 +917,11 @@ dynLinkBCOs hsc_env pls bcos = do
             cbcs      = map byteCodeOfObject unlinkeds
 
 
-            ul_bcos    = [b | ByteCode bs _ _  <- cbcs, b <- bs]
-            ies        = [ie | ByteCode _ ie _ <- cbcs]
+            ies        = map bc_itbls cbcs
             gce       = closure_env pls
             final_ie  = foldr plusNameEnv (itbl_env pls) ies
 
-        names_and_refs <- linkSomeBCOs hsc_env final_ie gce ul_bcos
+        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs
 
         -- We only want to add the external ones to the ClosureEnv
         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -929,28 +931,36 @@ dynLinkBCOs hsc_env pls bcos = do
         -- Wrap finalizers on the ones we want to keep
         new_binds <- makeForeignNamedHValueRefs hsc_env to_add
 
-        let pls2 = pls1 { closure_env = extendClosureEnv gce new_binds,
-                          itbl_env    = final_ie }
-
-        return pls2
+        return pls1 { closure_env = extendClosureEnv gce new_binds,
+                      itbl_env    = final_ie }
 
 -- Link a bunch of BCOs and return references to their values
 linkSomeBCOs :: HscEnv
              -> ItblEnv
              -> ClosureEnv
-             -> [UnlinkedBCO]
+             -> [CompiledByteCode]
              -> IO [(Name,HValueRef)]
                         -- The returned HValueRefs are associated 1-1 with
                         -- the incoming unlinked BCOs.  Each gives the
                         -- value of the corresponding unlinked BCO
 
-linkSomeBCOs _ _ _ [] = return []
-linkSomeBCOs hsc_env ie ce ul_bcos = do
-  let names = map unlinkedBCOName ul_bcos
-      bco_ix = mkNameEnv (zip names [0..])
-  resolved <- mapM (linkBCO hsc_env ie ce bco_ix) ul_bcos
-  hvrefs <- iservCmd hsc_env (CreateBCOs resolved)
-  return (zip names hvrefs)
+linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
+ where
+  fun CompiledByteCode{..} inner accum =
+    case bc_breaks of
+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
+                   inner ((breakarray, bc_bcos) : accum)
+
+  do_link [] = return []
+  do_link mods = do
+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
+        names = map (unlinkedBCOName . snd) flat
+        bco_ix = mkNameEnv (zip names [0..])
+    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
+                         | (breakarray, bco) <- flat ]
+    hvrefs <- iservCmd hsc_env (CreateBCOs resolved)
+    return (zip names hvrefs)
 
 -- | Useful to apply to the result of 'linkSomeBCOs'
 makeForeignNamedHValueRefs
index 17a7214..047e12e 100644 (file)
@@ -177,7 +177,7 @@ compileOne' m_tc_result mHscMessage
             let linkable = LM o_time this_mod [DotO object_filename]
             return hmi0 { hm_linkable = Just linkable }
         (HscRecomp cgguts summary, HscInterpreted) -> do
-            (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary
+            (hasStub, comp_bc) <- hscInteractive hsc_env cgguts summary
 
             stub_o <- case hasStub of
                       Nothing -> return []
@@ -185,7 +185,7 @@ compileOne' m_tc_result mHscMessage
                           stub_o <- compileStub hsc_env stub_c
                           return [DotO stub_o]
 
-            let hs_unlinked = [BCOs comp_bc modBreaks]
+            let hs_unlinked = [BCOs comp_bc]
                 unlinked_time = ms_hs_date summary
               -- Why do we use the timestamp of the source file here,
               -- rather than the current time?  This works better in
index 957f48c..31f809c 100644 (file)
@@ -145,7 +145,6 @@ module GHC (
         modInfoModBreaks,
         ModBreaks(..), BreakIndex,
         BreakInfo(breakInfo_number, breakInfo_module),
-        BreakArray, setBreakOn, setBreakOff, getBreak,
         InteractiveEval.back,
         InteractiveEval.forward,
 
@@ -290,8 +289,8 @@ module GHC (
 
 #ifdef GHCI
 import ByteCodeTypes
-import BreakArray
 import InteractiveEval
+import InteractiveEvalTypes
 import TcRnDriver       ( runTcInteractive )
 import GHCi
 import GHCi.RemoteTypes
index 558341a..7807f65 100644 (file)
@@ -1284,7 +1284,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
 hscInteractive :: HscEnv
                -> CgGuts
                -> ModSummary
-               -> IO (Maybe FilePath, CompiledByteCode, ModBreaks)
+               -> IO (Maybe FilePath, CompiledByteCode)
 #ifdef GHCI
 hscInteractive hsc_env cgguts mod_summary = do
     let dflags = hsc_dflags hsc_env
@@ -1311,7 +1311,7 @@ hscInteractive hsc_env cgguts mod_summary = do
     ------------------ Create f-x-dynamic C-side stuff ---
     (_istub_h_exists, istub_c_exists)
         <- outputForeignStubs dflags this_mod location foreign_stubs
-    return (istub_c_exists, comp_bc, mod_breaks)
+    return (istub_c_exists, comp_bc)
 #else
 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 #endif
@@ -1705,7 +1705,7 @@ mkModGuts mod safe binds =
         mg_warns        = NoWarnings,
         mg_anns         = [],
         mg_hpc_info     = emptyHpcInfo False,
-        mg_modBreaks    = emptyModBreaks,
+        mg_modBreaks    = Nothing,
         mg_vect_info    = noVectInfo,
         mg_inst_env     = emptyInstEnv,
         mg_fam_inst_env = emptyFamInstEnv,
index 0a76821..9e04920 100644 (file)
@@ -111,8 +111,7 @@ module HscTypes (
         HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
 
         -- * Breakpoints
-        ModBreaks (..), BreakIndex, emptyModBreaks,
-        CCostCentre,
+        ModBreaks (..), emptyModBreaks,
 
         -- * Vectorisation information
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
@@ -134,7 +133,7 @@ module HscTypes (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import ByteCodeTypes        ( CompiledByteCode )
+import ByteCodeTypes
 import InteractiveEvalTypes ( Resume )
 import GHCi.Message         ( Pipe )
 import GHCi.RemoteTypes
@@ -176,7 +175,6 @@ import IfaceSyn
 import CoreSyn          ( CoreRule, CoreVect )
 import Maybes
 import Outputable
-import BreakArray
 import SrcLoc
 -- import Unique
 import UniqFM
@@ -195,7 +193,6 @@ import GHC.Serialized   ( Serialized )
 import Foreign
 import Control.Monad    ( guard, liftM, when, ap )
 import Control.Concurrent
-import Data.Array       ( Array, array )
 import Data.IORef
 import Data.Time
 import Data.Typeable    ( Typeable )
@@ -1099,7 +1096,7 @@ data ModGuts
         mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
         mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module
-        mg_modBreaks :: !ModBreaks,      -- ^ Breakpoints for the module
+        mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
         mg_vect_decls:: ![CoreVect],     -- ^ Vectorisation declarations in this module
                                          --   (produced by desugarer & consumed by vectoriser)
         mg_vect_info :: !VectInfo,       -- ^ Pool of vectorised declarations in the module
@@ -1157,7 +1154,7 @@ data CgGuts
         cg_dep_pkgs  :: ![UnitId],    -- ^ Dependent packages, used to
                                          -- generate #includes for C code gen
         cg_hpc_info  :: !HpcInfo,        -- ^ Program coverage tick box information
-        cg_modBreaks :: !ModBreaks       -- ^ Module breakpoints
+        cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints
     }
 
 -----------------------------------
@@ -2819,12 +2816,16 @@ data Unlinked
    = DotO FilePath      -- ^ An object file (.o)
    | DotA FilePath      -- ^ Static archive file (.a)
    | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)
-   | BCOs CompiledByteCode ModBreaks    -- ^ A byte-code object, lives only in memory
+   | BCOs CompiledByteCode    -- ^ A byte-code object, lives only in memory
 
 #ifndef GHCI
 data CompiledByteCode = CompiledByteCodeUndefined
-_unused :: CompiledByteCode
-_unused = CompiledByteCodeUndefined
+_unusedCompiledByteCode :: CompiledByteCode
+_unusedCompiledByteCode = CompiledByteCodeUndefined
+
+data ModBreaks = ModBreaksUndefined
+emptyModBreaks :: ModBreaks
+emptyModBreaks = ModBreaksUndefined
 #endif
 
 instance Outputable Unlinked where
@@ -2832,9 +2833,9 @@ instance Outputable Unlinked where
    ppr (DotA path)   = text "DotA" <+> text path
    ppr (DotDLL path) = text "DotDLL" <+> text path
 #ifdef GHCI
-   ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos
+   ppr (BCOs bcos) = text "BCOs" <+> ppr bcos
 #else
-   ppr (BCOs _ _)    = text "No byte code"
+   ppr (BCOs _)    = text "No byte code"
 #endif
 
 -- | Is this an actual file on disk we can link in somehow?
@@ -2857,50 +2858,6 @@ nameOfObject other       = pprPanic "nameOfObject" (ppr other)
 
 -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
 byteCodeOfObject :: Unlinked -> CompiledByteCode
-byteCodeOfObject (BCOs bc _) = bc
-byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Breakpoint Support}
-*                                                                      *
-************************************************************************
--}
+byteCodeOfObject (BCOs bc) = bc
+byteCodeOfObject other     = pprPanic "byteCodeOfObject" (ppr other)
 
--- | Breakpoint index
-type BreakIndex = Int
-
--- | C CostCentre type
-data CCostCentre
-
--- | All the information about the breakpoints for a given module
-data ModBreaks
-   = ModBreaks
-   { modBreaks_flags :: BreakArray
-        -- ^ The array of flags, one per breakpoint,
-        -- indicating which breakpoints are enabled.
-   , modBreaks_locs :: !(Array BreakIndex SrcSpan)
-        -- ^ An array giving the source span of each breakpoint.
-   , modBreaks_vars :: !(Array BreakIndex [OccName])
-        -- ^ An array giving the names of the free variables at each breakpoint.
-   , modBreaks_decls :: !(Array BreakIndex [String])
-        -- ^ An array giving the names of the declarations enclosing each breakpoint.
-#ifdef GHCI
-   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr {- CCostCentre -}))
-        -- ^ Array pointing to cost centre for each breakpoint
-#endif
-   }
-
--- | Construct an empty ModBreaks
-emptyModBreaks :: ModBreaks
-emptyModBreaks = ModBreaks
-   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-         -- ToDo: can we avoid this?
-   , modBreaks_locs  = array (0,-1) []
-   , modBreaks_vars  = array (0,-1) []
-   , modBreaks_decls = array (0,-1) []
-#ifdef GHCI
-   , modBreaks_ccs = array (0,-1) []
-#endif
-   }
index 7839f1b..e1f2cfc 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
-    RecordWildCards #-}
+    RecordWildCards, BangPatterns #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -84,7 +84,6 @@ import UniqFM
 import Maybes
 import ErrUtils
 import SrcLoc
-import BreakArray
 import RtClosureInspect
 import Outputable
 import FastString
@@ -95,6 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration)
 import System.Directory
 import Data.Dynamic
 import Data.Either
+import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
 import StringBuffer (stringToStringBuffer)
 import Control.Monad
@@ -110,27 +110,23 @@ getResumeContext :: GhcMonad m => m [Resume]
 getResumeContext = withSession (return . ic_resume . hsc_IC)
 
 mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
-mkHistory hsc_env hval bi = let
-    decls = findEnclosingDecls hsc_env bi
-    in History hval bi decls
-
+mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
 
 getHistoryModule :: History -> Module
 getHistoryModule = breakInfo_module . historyBreakInfo
 
 getHistorySpan :: HscEnv -> History -> SrcSpan
-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 (getModBreaks hmi) ! num
-       _ -> panic "getHistorySpan"
+getHistorySpan hsc_env History{..} =
+  let BreakInfo{..} = historyBreakInfo in
+  case lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module) of
+    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
+    _ -> panic "getHistorySpan"
 
 getModBreaks :: HomeModInfo -> ModBreaks
 getModBreaks hmi
   | Just linkable <- hm_linkable hmi,
-    [BCOs _ modBreaks] <- linkableUnlinked linkable
-  = modBreaks
+    [BCOs cbc] <- linkableUnlinked linkable
+  = fromMaybe emptyModBreaks (bc_breaks cbc)
   | otherwise
   = emptyModBreaks -- probably object code
 
@@ -139,11 +135,11 @@ getModBreaks hmi
 -- by the coverage pass, which gives the list of lexically-enclosing bindings
 -- for each tick.
 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
-findEnclosingDecls hsc_env inf =
+findEnclosingDecls hsc_env (BreakInfo modl ix) =
    let hmi = expectJust "findEnclosingDecls" $
-             lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
+             lookupUFM (hsc_HPT hsc_env) (moduleName modl)
        mb = getModBreaks hmi
-   in modBreaks_decls mb ! breakInfo_number inf
+   in modBreaks_decls mb ! ix
 
 -- | Update fixity environment in the current interactive context.
 updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
@@ -286,7 +282,8 @@ emptyHistory size = nilBL size
 
 handleRunStatus :: GhcMonad m
                 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
-                -> EvalStatus [ForeignHValue] -> BoundedList History
+                -> EvalStatus_ [ForeignHValue] [HValueRef]
+                -> BoundedList History
                 -> m ExecResult
 
 handleRunStatus step expr bindings final_ids status history
@@ -294,24 +291,26 @@ handleRunStatus step expr bindings final_ids status history
   | otherwise              = not_tracing
  where
   tracing
-    | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
     , not is_exception
     = do
        hsc_env <- getSession
-       let dflags = hsc_dflags hsc_env
-       info_hv <- liftIO $ wormholeRef dflags info_ref
-       let info = unsafeCoerce# info_hv :: BreakInfo
-       b <- liftIO $ isBreakEnabled hsc_env info
+       let hmi = expectJust "handleRunStatus" $
+                   lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
+           modl = mi_module (hm_iface hmi)
+           breaks = getModBreaks hmi
+
+       b <- liftIO $
+              breakpointStatus hsc_env (modBreaks_flags breaks) ix
        if b
          then not_tracing
            -- This breakpoint is explicitly enabled; we want to stop
            -- instead of just logging it.
          else do
            apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
-           let history' = mkHistory hsc_env apStack_fhv info `consBL` history
-                 -- probably better make history strict here, otherwise
-                 -- our BoundedList will be pointless.
-           _ <- liftIO $ evaluate history'
+           let bi = BreakInfo modl ix
+               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
+                 -- history is strict, otherwise our BoundedList is pointless.
            fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
            status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
            handleRunStatus RunAndLogSteps expr bindings final_ids
@@ -321,23 +320,24 @@ handleRunStatus step expr bindings final_ids status history
 
   not_tracing
     -- Hit a breakpoint
-    | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
     = do
          hsc_env <- getSession
-         let dflags = hsc_dflags hsc_env
-         info_hv <- liftIO $ wormholeRef dflags info_ref
-         let info = unsafeCoerce# info_hv :: BreakInfo
          resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
          apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
-         let mb_info | is_exception = Nothing
-                     | otherwise    = Just info
+         let hmi = expectJust "handleRunStatus" $
+                     lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
+             modl = mi_module (hm_iface hmi)
+             bp | is_exception = Nothing
+                | otherwise = Just (BreakInfo modl ix)
          (hsc_env1, names, span, decl) <- liftIO $
-           bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info
+           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
          let
            resume = Resume
              { resumeStmt = expr, resumeContext = resume_ctxt_fhv
              , resumeBindings = bindings, resumeFinalIds = final_ids
-             , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info
+             , resumeApStack = apStack_fhv
+             , resumeBreakInfo = bp
              , resumeSpan = span, resumeHistory = toListBL history
              , resumeDecl = decl
              , resumeCCS = ccs
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history
            hsc_env2 = pushResume hsc_env1 resume
 
          modifySession (\_ -> hsc_env2)
-         return (ExecBreak names mb_info)
+         return (ExecBreak names bp)
 
     -- Completed successfully
     | EvalComplete allocs (EvalSuccess hvals) <- status
@@ -364,16 +364,6 @@ handleRunStatus step expr bindings final_ids status history
     | otherwise
     = panic "not_tracing" -- actually exhaustive, but GHC can't tell
 
-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 (getModBreaks hmi))
-                       (breakInfo_number inf)
-         case w of Just n -> return (n /= 0); _other -> return False
-       _ ->
-         return False
-
 
 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
 resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step
@@ -407,17 +397,17 @@ resumeExec canLogSpan step
         case r of
           Resume { resumeStmt = expr, resumeContext = fhv
                  , resumeBindings = bindings, resumeFinalIds = final_ids
-                 , resumeApStack = apStack, resumeBreakInfo = info
+                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
                  , resumeSpan = span
                  , resumeHistory = hist } -> do
                withVirtualCWD $ do
                 status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
                 let prevHistoryLst = fromListBL 50 hist
-                    hist' = case info of
+                    hist' = case mb_brkpt of
                        Nothing -> prevHistoryLst
-                       Just i
+                       Just bi
                          | not $canLogSpan span -> prevHistoryLst
-                         | otherwise -> mkHistory hsc_env apStack i `consBL`
+                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
                                                         fromListBL 50 hist
                 handleRunStatus step expr bindings final_ids status hist'
 
@@ -461,14 +451,16 @@ moveHist fn = do
         if new_ix == 0
            then case r of
                    Resume { resumeApStack = apStack,
-                            resumeBreakInfo = mb_info } ->
-                          update_ic apStack mb_info
+                            resumeBreakInfo = mb_brkpt } ->
+                          update_ic apStack mb_brkpt
            else case history !! (new_ix - 1) of
-                   History apStack info _ ->
-                          update_ic apStack (Just info)
+                   History{..} ->
+                     update_ic historyApStack (Just historyBreakInfo)
+
 
 -- -----------------------------------------------------------------------------
 -- After stopping at a breakpoint, add free variables to the environment
+
 result_fs :: FastString
 result_fs = fsLit "_result"
 
@@ -494,25 +486,24 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 
        ictxt0 = hsc_IC hsc_env
        ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
-
    --
    Linker.extendLinkEnv [(exn_name, apStack)]
    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
 
 -- Just case: we stopped at a breakpoint, we have information about the location
 -- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
    let
-       mod_name  = moduleName (breakInfo_module info)
        hmi       = expectJust "bindLocalsAtBreakpoint" $
-                        lookupUFM (hsc_HPT hsc_env) mod_name
+                     lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module)
        breaks    = getModBreaks hmi
-       index     = breakInfo_number info
-       vars      = breakInfo_vars info
-       result_ty = breakInfo_resty info
-       occs      = modBreaks_vars breaks ! index
-       span      = modBreaks_locs breaks ! index
-       decl      = intercalate "." $ modBreaks_decls breaks ! index
+       info      = expectJust "bindLocalsAtBreakpoint2" $
+                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
+       vars      = cgb_vars info
+       result_ty = cgb_resty info
+       occs      = modBreaks_vars breaks ! breakInfo_number
+       span      = modBreaks_locs breaks ! breakInfo_number
+       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
 
            -- Filter out any unboxed ids;
            -- we can't bind these at the prompt
@@ -554,7 +545,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
        names  = map idName new_ids
 
-   fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkHValueRef)
+   fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef)
              (catMaybes mb_hValues)
    Linker.extendLinkEnv (zip names fhvs)
    when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
index 4372891..34ae2cc 100644 (file)
 module InteractiveEvalTypes (
 #ifdef GHCI
         Resume(..), History(..), ExecResult(..),
-        SingleStep(..), isStep, ExecOptions(..)
+        SingleStep(..), isStep, ExecOptions(..),
+        BreakInfo(..)
 #endif
         ) where
 
 #ifdef GHCI
 
 import GHCi.RemoteTypes
-import GHCi.Message (EvalExpr)
+import GHCi.Message (EvalExpr, ResumeContext)
 import Id
 import Name
+import Module
 import RdrName
 import Type
-import ByteCodeTypes
 import SrcLoc
 import Exception
 
 import Data.Word
+import GHC.Stack.CCS
 
 data ExecOptions
  = ExecOptions
@@ -56,27 +58,32 @@ data ExecResult
        , breakInfo :: Maybe BreakInfo
        }
 
-data Resume
-   = Resume {
-       resumeStmt      :: String,       -- the original statement
-       resumeContext   :: ForeignHValue, -- thread running the computation
-       resumeBindings  :: ([TyThing], GlobalRdrEnv),
-       resumeFinalIds  :: [Id],         -- [Id] to bind on completion
-       resumeApStack   :: ForeignHValue, -- The object from which we can get
+data BreakInfo = BreakInfo
+  { breakInfo_module :: Module
+  , breakInfo_number :: Int
+  }
+
+data Resume = Resume
+       { resumeStmt      :: String       -- the original statement
+       , resumeContext   :: ForeignRef (ResumeContext [HValueRef])
+       , resumeBindings  :: ([TyThing], GlobalRdrEnv)
+       , resumeFinalIds  :: [Id]         -- [Id] to bind on completion
+       , resumeApStack   :: ForeignHValue -- The object from which we can get
                                         -- value of the free variables.
-       resumeBreakInfo :: Maybe BreakInfo,
+       , resumeBreakInfo :: Maybe BreakInfo
                                         -- the breakpoint we stopped at
+                                        -- (module, index)
                                         -- (Nothing <=> exception)
-       resumeSpan      :: SrcSpan,      -- just a copy of the SrcSpan
+       , resumeSpan      :: SrcSpan      -- just a copy of the SrcSpan
                                         -- from the ModBreaks,
                                         -- otherwise it's a pain to
                                         -- fetch the ModDetails &
                                         -- ModBreaks to get this.
-       resumeDecl      :: String,       -- ditto
-       resumeCCS       :: RemotePtr {- CostCentreStack -},
-       resumeHistory   :: [History],
-       resumeHistoryIx :: Int           -- 0 <==> at the top of the history
-   }
+       , resumeDecl      :: String       -- ditto
+       , resumeCCS       :: RemotePtr CostCentreStack
+       , resumeHistory   :: [History]
+       resumeHistoryIx :: Int           -- 0 <==> at the top of the history
+       }
 
 data History
    = History {
index bc2870b..6beff7f 100644 (file)
@@ -177,6 +177,7 @@ import qualified Control.Monad.Fail as MonadFail
 import Data.Map      ( Map )
 import Data.Dynamic  ( Dynamic )
 import Data.Typeable ( TypeRep )
+import GHCi.Message
 import GHCi.RemoteTypes
 
 import qualified Language.Haskell.TH as TH
@@ -496,7 +497,7 @@ data TcGblEnv
         -- ^ Template Haskell module finalizers
 
         tcg_th_state :: TcRef (Map TypeRep Dynamic),
-        tcg_th_remote_state :: TcRef (Maybe ForeignHValue),
+        tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
         -- ^ Template Haskell state
 #endif /* GHCI */
 
index 63a3371..cdb4790 100644 (file)
@@ -913,7 +913,7 @@ finishTH = do
       case th_state of
         Nothing -> return () -- TH was not started, nothing to do
         Just fhv -> do
-          liftIO $ withForeignHValue fhv $ \rhv ->
+          liftIO $ withForeignRef fhv $ \rhv ->
             writeIServ i (putMessage (FinishTH rhv))
           () <- runRemoteTH i
           writeTcRef (tcg_th_remote_state tcg) Nothing
@@ -946,8 +946,8 @@ runTH ty fhv = do
         rstate <- getTHState i
         loc <- TH.qLocation
         liftIO $
-          withForeignHValue rstate $ \state_hv ->
-          withForeignHValue fhv $ \q_hv ->
+          withForeignRef rstate $ \state_hv ->
+          withForeignRef fhv $ \q_hv ->
             writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
         bs <- runRemoteTH i
         return $! runGet get (LB.fromStrict bs)
@@ -966,7 +966,7 @@ runRemoteTH iserv = do
       liftIO $ writeIServ iserv (put r)
       runRemoteTH iserv
 
-getTHState :: IServ -> TcM ForeignHValue
+getTHState :: IServ -> TcM (ForeignRef (IORef QState))
 getTHState i = do
   tcg <- getGblEnv
   th_state <- readTcRef (tcg_th_remote_state tcg)
diff --git a/ghc.mk b/ghc.mk
index 3ccc496..878ddc8 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -563,7 +563,10 @@ BOOT_PKG_CONSTRAINTS := \
             --constraint "$p == $(shell grep -i "^Version:" libraries/$d/$p.cabal | sed "s/[^0-9.]//g")"))
 
 # The actual .a and .so/.dll files: needed for dependencies.
-ALL_STAGE1_LIBS  = $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_v_LIB))
+$(foreach way,$(GhcLibWays),$(eval ALL_STAGE1_$(way)_LIBS = $$(foreach lib,$$(PACKAGES_STAGE1),$$(libraries/$$(lib)_dist-install_$(way)_LIB))))
+
+ALL_STAGE1_LIBS = $(ALL_STAGE1_v_LIBS)
+
 ifeq "$(BuildSharedLibs)" "YES"
 ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_dyn_LIB))
 endif
index 4fcbe6d..7bd9bbe 100644 (file)
@@ -39,6 +39,8 @@ import Debugger
 
 -- The GHC interface
 import GHCi
+import GHCi.RemoteTypes
+import GHCi.BreakArray
 import DynFlags
 import ErrUtils
 import GhcMonad ( modifySession )
@@ -58,7 +60,6 @@ import PrelNames
 import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
 import SrcLoc
 import qualified Lexer
-import ByteCodeTypes (BreakInfo(..))
 
 import StringBuffer
 import Outputable hiding ( printForUser, printForUserPartWay, bold )
@@ -2651,7 +2652,7 @@ pprStopped res =
          <> text (GHC.resumeDecl res))
     <> char ',' <+> ppr (GHC.resumeSpan res)
  where
-  mb_mod_name = moduleName <$> breakInfo_module <$> GHC.resumeBreakInfo res
+  mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
 
 showPackages :: GHCi ()
 showPackages = do
@@ -3094,24 +3095,19 @@ findBreakAndSet md lookupTickTree = do
       some -> mapM_ (breakAt breakArray) some
  where
    breakAt breakArray (tick, pan) = do
-         success <- liftIO $ setBreakFlag True breakArray tick
-         if success
-            then do
-               (alreadySet, nm) <-
-                     recordBreak $ BreakLocation
-                             { breakModule = md
-                             , breakLoc = RealSrcSpan pan
-                             , breakTick = tick
-                             , onBreakCmd = ""
-                             }
-               printForUser $
-                  text "Breakpoint " <> ppr nm <>
-                  if alreadySet
-                     then text " was already set at " <> ppr pan
-                     else text " activated at " <> ppr pan
-            else do
-            printForUser $ text "Breakpoint could not be activated at"
-                                 <+> ppr pan
+         setBreakFlag True breakArray tick
+         (alreadySet, nm) <-
+               recordBreak $ BreakLocation
+                       { breakModule = md
+                       , breakLoc = RealSrcSpan pan
+                       , breakTick = tick
+                       , onBreakCmd = ""
+                       }
+         printForUser $
+            text "Breakpoint " <> ppr nm <>
+            if alreadySet
+               then text " was already set at " <> ppr pan
+               else text " activated at " <> ppr pan
 
 -- When a line number is specified, the current policy for choosing
 -- the best breakpoint is this:
@@ -3390,12 +3386,13 @@ deleteBreak identity = do
            mapM_ (turnOffBreak.snd) this
            setGHCiState $ st { breaks = rest }
 
-turnOffBreak :: BreakLocation -> GHCi Bool
+turnOffBreak :: BreakLocation -> GHCi ()
 turnOffBreak loc = do
   (arr, _) <- getModBreak (breakModule loc)
-  liftIO $ setBreakFlag False arr (breakTick loc)
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
 
-getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
+getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
 getModBreak m = do
    Just mod_info <- GHC.getModuleInfo m
    let modBreaks  = GHC.modInfoModBreaks mod_info
@@ -3403,11 +3400,10 @@ getModBreak m = do
    let ticks      = GHC.modBreaks_locs  modBreaks
    return (arr, ticks)
 
-setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
-setBreakFlag toggle arr i
-   | toggle    = GHC.setBreakOn  arr i
-   | otherwise = GHC.setBreakOff arr i
-
+setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()
+setBreakFlag toggle arr i = do
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr i toggle
 
 -- ---------------------------------------------------------------------------
 -- User code exception handling
index 2a2372d..87b6d27 100644 (file)
@@ -118,7 +118,7 @@ data GHCiState = GHCiState
         noBuffering :: ForeignHValue
      }
 
-type TickArray = Array Int [(BreakIndex,RealSrcSpan)]
+type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
 
 -- | A GHCi command
 data Command
similarity index 88%
rename from compiler/main/BreakArray.hs
rename to libraries/ghci/GHCi/BreakArray.hs
index 4474902..311bbd6 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
 
 -------------------------------------------------------------------------------
 --
 -------------------------------------------------------------------------------
 
-module BreakArray
+module GHCi.BreakArray
     (
       BreakArray
-#ifdef GHCI
           (BA) -- constructor is exported only for ByteCodeGen
-#endif
     , newBreakArray
-#ifdef GHCI
     , getBreak
     , setBreakOn
     , setBreakOff
     , showBreakArray
-#endif
     ) where
 
-#ifdef GHCI
 import Control.Monad
 import Data.Word
 import GHC.Word
@@ -116,17 +112,3 @@ readBA# array i = IO $ \s ->
 
 readBreakArray :: BreakArray -> Int -> IO Word8
 readBreakArray (BA array) (I# i) = readBA# array i
-
-#else /* !GHCI */
-
--- stub implementation to make main/, etc., code happier.
--- IOArray and IOUArray are increasingly non-portable,
--- still don't have quite the same interface, and (for GHCI)
--- presumably have a different representation.
-data BreakArray = Unspecified
-
-newBreakArray :: Int -> IO BreakArray
-newBreakArray _ = return Unspecified
-
-#endif /* GHCI */
-
index 6a9b79a..9501b5f 100644 (file)
@@ -14,6 +14,7 @@ module GHCi.CreateBCO (createBCOs) where
 
 import GHCi.ResolvedBCO
 import GHCi.RemoteTypes
+import GHCi.BreakArray
 import SizedSeq
 
 import System.IO (fixIO)
@@ -31,7 +32,7 @@ createBCOs bcos = do
   hvals <- fixIO $ \hvs -> do
      let arr = listArray (0, n_bcos-1) hvs
      mapM (createBCO arr) bcos
-  mapM mkHValueRef hvals
+  mapM mkRemoteRef hvals
 
 createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
 createBCO arr bco
@@ -85,15 +86,16 @@ mkPtrsArray arr n_ptrs ptrs = do
     fill (ResolvedBCORef n) i =
       writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
     fill (ResolvedBCOPtr r) i = do
-      hv <- localHValueRef r
+      hv <- localRef r
       writePtrsArrayHValue i hv marr
     fill (ResolvedBCOStaticPtr r) i = do
       writePtrsArrayPtr i (fromRemotePtr r)  marr
     fill (ResolvedBCOPtrBCO bco) i = do
       BCO bco# <- linkBCO' arr bco
       writePtrsArrayBCO i bco# marr
-    fill (ResolvedBCOPtrLocal hv) i = do
-      writePtrsArrayHValue i hv marr
+    fill (ResolvedBCOPtrBreakArray r) i = do
+      BA mba <- localRef r
+      writePtrsArrayMBA i mba marr
   zipWithM_ fill ptrs [0..]
   return marr
 
@@ -123,6 +125,10 @@ writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
 
 data BCO = BCO BCO#
 
+writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
+writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
+  case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
+
 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
 newBCO instrs lits ptrs arity bitmap = IO $ \s ->
   case newBCO# instrs lits ptrs arity bitmap s of
index 36619ae..7fd75bb 100644 (file)
@@ -12,6 +12,7 @@
 module GHCi.FFI
   ( FFIType(..)
   , FFIConv(..)
+  , C_ffi_cif
   , prepForeignCall
   , freeForeignCallInfo
   ) where
@@ -47,7 +48,7 @@ prepForeignCall
     :: FFIConv
     -> [FFIType]          -- arg types
     -> FFIType            -- result type
-    -> IO (Ptr ())        -- token for making calls (must be freed by caller)
+    -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller)
 
 prepForeignCall cconv arg_types result_type = do
   let n_args = length arg_types
@@ -60,7 +61,7 @@ prepForeignCall cconv arg_types result_type = do
      then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r))
      else return (castPtr cif)
 
-freeForeignCallInfo :: Ptr () -> IO ()
+freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()
 freeForeignCallInfo p = do
   free ((#ptr ffi_cif, arg_types) p)
   free p
index 0244990..cc57aff 100644 (file)
@@ -25,7 +25,7 @@ mkConInfoTable
    -> Int     -- non-ptr words
    -> Int     -- constr tag
    -> [Word8]  -- con desc
-   -> IO (Ptr ())
+   -> IO (Ptr StgInfoTable)
       -- resulting info table is allocated with allocateExec(), and
       -- should be freed with freeExec().
 
index 37c9f0c..59d6483 100644 (file)
@@ -4,19 +4,24 @@
 
 module GHCi.Message
   ( Message(..), Msg(..)
-  , EvalStatus(..), EvalResult(..), EvalOpts(..), EvalExpr(..)
+  , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
   , SerializableException(..)
   , THResult(..), THResultType(..)
+  , ResumeContext(..)
+  , QState(..)
   , getMessage, putMessage
   , Pipe(..), remoteCall, readPipe, writePipe
   ) where
 
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
+import GHCi.InfoTable (StgInfoTable)
 import GHCi.FFI
 import GHCi.TH.Binary ()
+import GHCi.BreakArray
 
 import GHC.LanguageExtensions
+import Control.Concurrent
 import Control.Exception
 import Data.Binary
 import Data.Binary.Get
@@ -24,9 +29,12 @@ import Data.Binary.Put
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
+import Data.Dynamic
 import Data.IORef
-import Data.Typeable
+import Data.Map (Map)
+import Foreign.C
 import GHC.Generics
+import GHC.Stack.CCS
 import qualified Language.Haskell.TH        as TH
 import qualified Language.Haskell.TH.Syntax as TH
 import System.Exit
@@ -45,14 +53,14 @@ data Message a where
 
   -- These all invoke the corresponding functions in the RTS Linker API.
   InitLinker :: Message ()
-  LookupSymbol :: String -> Message (Maybe RemotePtr)
+  LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
   LookupClosure :: String -> Message (Maybe HValueRef)
   LoadDLL :: String -> Message (Maybe String)
   LoadArchive :: String -> Message () -- error?
   LoadObj :: String -> Message () -- error?
   UnloadObj :: String -> Message () -- error?
-  AddLibrarySearchPath :: String -> Message RemotePtr
-  RemoveLibrarySearchPath :: RemotePtr -> Message Bool
+  AddLibrarySearchPath :: String -> Message (RemotePtr ())
+  RemoveLibrarySearchPath :: RemotePtr () -> Message Bool
   ResolveObjs :: Message Bool
   FindSystemLibrary :: String -> Message (Maybe String)
 
@@ -65,13 +73,13 @@ data Message a where
   FreeHValueRefs :: [HValueRef] -> Message ()
 
   -- | Malloc some data and return a 'RemotePtr' to it
-  MallocData :: ByteString -> Message RemotePtr
+  MallocData :: ByteString -> Message (RemotePtr ())
 
   -- | Calls 'GHCi.FFI.prepareForeignCall'
-  PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message RemotePtr
+  PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
 
   -- | Free data previously created by 'PrepFFI'
-  FreeFFI :: RemotePtr -> Message ()
+  FreeFFI :: RemotePtr C_ffi_cif -> Message ()
 
   -- | Create an info table for a constructor
   MkConInfoTable
@@ -79,7 +87,7 @@ data Message a where
    -> Int     -- non-ptr words
    -> Int     -- constr tag
    -> [Word8] -- constructor desccription
-   -> Message RemotePtr
+   -> Message (RemotePtr StgInfoTable)
 
   -- | Evaluate a statement
   EvalStmt
@@ -90,12 +98,12 @@ data Message a where
   -- | Resume evaluation of a statement after a breakpoint
   ResumeStmt
    :: EvalOpts
-   -> HValueRef {- ResumeContext -}
+   -> RemoteRef (ResumeContext [HValueRef])
    -> Message (EvalStatus [HValueRef])
 
   -- | Abandon evaluation of a statement after a breakpoint
   AbandonStmt
-   :: HValueRef {- ResumeContext -}
+   :: RemoteRef (ResumeContext [HValueRef])
    -> Message ()
 
   -- | Evaluate something of type @IO String@
@@ -116,23 +124,41 @@ data Message a where
 
   -- | Create a CostCentre
   MkCostCentre
-   :: RemotePtr    -- module, RemotePtr so it can be shared
+   :: RemotePtr CChar    -- module, RemotePtr so it can be shared
    -> String       -- name
    -> String       -- SrcSpan
-   -> Message RemotePtr
+   -> Message (RemotePtr CostCentre)
 
   -- | Show a 'CostCentreStack' as a @[String]@
   CostCentreStackInfo
-   :: RemotePtr {- from EvalBreak -}
+   :: RemotePtr CostCentreStack
    -> Message [String]
 
+  -- | Create a new array of breakpoint flags
+  NewBreakArray
+   :: Int                               -- size
+   -> Message (RemoteRef BreakArray)
+
+  -- | Enable a breakpoint
+  EnableBreakpoint
+   :: RemoteRef BreakArray
+   -> Int                               -- index
+   -> Bool                              -- on or off
+   -> Message ()
+
+  -- | Query the status of a breakpoint (True <=> enabled)
+  BreakpointStatus
+   :: RemoteRef BreakArray
+   -> Int                               -- index
+   -> Message Bool                      -- True <=> enabled
+
   -- Template Haskell -------------------------------------------
 
   -- | Start a new TH module, return a state token that should be
-  StartTH :: Message HValueRef {- GHCiQState -}
+  StartTH :: Message (RemoteRef (IORef QState))
 
   -- | Run TH module finalizers, and free the HValueRef
-  FinishTH :: HValueRef {- GHCiQState -} -> Message ()
+  FinishTH :: RemoteRef (IORef QState) -> Message ()
 
   -- | Evaluate a TH computation.
   --
@@ -142,7 +168,7 @@ data Message a where
   -- they did, we have to serialize the value anyway, so we might
   -- as well serialize it to force it.
   RunTH
-   :: HValueRef {- GHCiQState -}
+   :: RemoteRef (IORef QState)
    -> HValueRef {- e.g. TH.Q TH.Exp -}
    -> THResultType
    -> Maybe TH.Loc
@@ -186,6 +212,12 @@ data EvalOpts = EvalOpts
 
 instance Binary EvalOpts
 
+data ResumeContext a = ResumeContext
+  { resumeBreakMVar :: MVar ()
+  , resumeStatusMVar :: MVar (EvalStatus a)
+  , resumeThreadId :: ThreadId
+  }
+
 -- | We can pass simple expressions to EvalStmt, consisting of values
 -- and application.  This allows us to wrap the statement to be
 -- executed in another function, which is used by GHCi to implement
@@ -198,16 +230,19 @@ data EvalExpr a
 
 instance Binary a => Binary (EvalExpr a)
 
-data EvalStatus a
+type EvalStatus a = EvalStatus_ a a
+
+data EvalStatus_ a b
   = EvalComplete Word64 (EvalResult a)
   | EvalBreak Bool
        HValueRef{- AP_STACK -}
-       HValueRef{- BreakInfo -}
-       HValueRef{- ResumeContext -}
-       RemotePtr -- Cost centre stack
+       Int {- break index -}
+       Int {- uniq of ModuleName -}
+       (RemoteRef (ResumeContext b))
+       (RemotePtr CostCentreStack) -- Cost centre stack
   deriving (Generic, Show)
 
-instance Binary a => Binary (EvalStatus a)
+instance Binary a => Binary (EvalStatus_ a b)
 
 data EvalResult a
   = EvalException SerializableException
@@ -248,6 +283,18 @@ data THResultType = THExp | THPat | THType | THDec | THAnnWrapper
 
 instance Binary THResultType
 
+data QState = QState
+  { qsMap        :: Map TypeRep Dynamic
+       -- ^ persistent data between splices in a module
+  , qsFinalizers :: [TH.Q ()]
+       -- ^ registered finalizers (in reverse order)
+  , qsLocation   :: Maybe TH.Loc
+       -- ^ location for current splice, if any
+  , qsPipe :: Pipe
+       -- ^ pipe to communicate with GHC
+  }
+instance Show QState where show _ = "<QState>"
+
 data Msg = forall a . (Binary a, Show a) => Msg (Message a)
 
 getMessage :: Get Msg
@@ -280,25 +327,28 @@ getMessage = do
       23 -> Msg <$> (EvalIO <$> get)
       24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get)
       25 -> Msg <$> (CostCentreStackInfo <$> get)
-      26 -> Msg <$> return StartTH
-      27 -> Msg <$> FinishTH <$> get
-      28 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
-      29 -> Msg <$> NewName <$> get
-      30 -> Msg <$> (Report <$> get <*> get)
-      31 -> Msg <$> (LookupName <$> get <*> get)
-      32 -> Msg <$> Reify <$> get
-      33 -> Msg <$> ReifyFixity <$> get
-      34 -> Msg <$> (ReifyInstances <$> get <*> get)
-      35 -> Msg <$> ReifyRoles <$> get
-      36 -> Msg <$> (ReifyAnnotations <$> get <*> get)
-      37 -> Msg <$> ReifyModule <$> get
-      38 -> Msg <$> ReifyConStrictness <$> get
-      39 -> Msg <$> AddDependentFile <$> get
-      40 -> Msg <$> AddTopDecls <$> get
-      41 -> Msg <$> (IsExtEnabled <$> get)
-      42 -> Msg <$> return ExtsEnabled
-      43 -> Msg <$> return QDone
-      44 -> Msg <$> QException <$> get
+      26 -> Msg <$> (NewBreakArray <$> get)
+      27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
+      28 -> Msg <$> (BreakpointStatus <$> get <*> get)
+      29 -> Msg <$> return StartTH
+      30 -> Msg <$> FinishTH <$> get
+      31 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+      32 -> Msg <$> NewName <$> get
+      33 -> Msg <$> (Report <$> get <*> get)
+      34 -> Msg <$> (LookupName <$> get <*> get)
+      35 -> Msg <$> Reify <$> get
+      36 -> Msg <$> ReifyFixity <$> get
+      37 -> Msg <$> (ReifyInstances <$> get <*> get)
+      38 -> Msg <$> ReifyRoles <$> get
+      39 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+      40 -> Msg <$> ReifyModule <$> get
+      41 -> Msg <$> ReifyConStrictness <$> get
+      42 -> Msg <$> AddDependentFile <$> get
+      43 -> Msg <$> AddTopDecls <$> get
+      44 -> Msg <$> (IsExtEnabled <$> get)
+      45 -> Msg <$> return ExtsEnabled
+      46 -> Msg <$> return QDone
+      47 -> Msg <$> QException <$> get
       _  -> Msg <$> QFail <$> get
 
 putMessage :: Message a -> Put
@@ -327,28 +377,31 @@ putMessage m = case m of
   EvalString val              -> putWord8 21 >> put val
   EvalStringToString str val  -> putWord8 22 >> put str >> put val
   EvalIO val                  -> putWord8 23 >> put val
-  MkCostCentre name mod src   -> putWord8 24 >> put name >> put mod >> put src
+  MkCostCentre mod name src   -> putWord8 24 >> put mod >> put name >> put src
   CostCentreStackInfo ptr     -> putWord8 25 >> put ptr
-  StartTH                     -> putWord8 26
-  FinishTH val                -> putWord8 27 >> put val
-  RunTH st q loc ty           -> putWord8 28 >> put st >> put q >> put loc >> put ty
-  NewName a                   -> putWord8 29 >> put a
-  Report a b                  -> putWord8 30 >> put a >> put b
-  LookupName a b              -> putWord8 31 >> put a >> put b
-  Reify a                     -> putWord8 32 >> put a
-  ReifyFixity a               -> putWord8 33 >> put a
-  ReifyInstances a b          -> putWord8 34 >> put a >> put b
-  ReifyRoles a                -> putWord8 35 >> put a
-  ReifyAnnotations a b        -> putWord8 36 >> put a >> put b
-  ReifyModule a               -> putWord8 37 >> put a
-  ReifyConStrictness a        -> putWord8 38 >> put a
-  AddDependentFile a          -> putWord8 39 >> put a
-  AddTopDecls a               -> putWord8 40 >> put a
-  IsExtEnabled a              -> putWord8 41 >> put a
-  ExtsEnabled                 -> putWord8 42
-  QDone                       -> putWord8 43
-  QException a                -> putWord8 44 >> put a
-  QFail a                     -> putWord8 45 >> put a
+  NewBreakArray sz            -> putWord8 26 >> put sz
+  EnableBreakpoint arr ix b   -> putWord8 27 >> put arr >> put ix >> put b
+  BreakpointStatus arr ix     -> putWord8 28 >> put arr >> put ix
+  StartTH                     -> putWord8 29
+  FinishTH val                -> putWord8 30 >> put val
+  RunTH st q loc ty           -> putWord8 31 >> put st >> put q >> put loc >> put ty
+  NewName a                   -> putWord8 32 >> put a
+  Report a b                  -> putWord8 33 >> put a >> put b
+  LookupName a b              -> putWord8 34 >> put a >> put b
+  Reify a                     -> putWord8 35 >> put a
+  ReifyFixity a               -> putWord8 36 >> put a
+  ReifyInstances a b          -> putWord8 37 >> put a >> put b
+  ReifyRoles a                -> putWord8 38 >> put a
+  ReifyAnnotations a b        -> putWord8 39 >> put a >> put b
+  ReifyModule a               -> putWord8 40 >> put a
+  ReifyConStrictness a        -> putWord8 41 >> put a
+  AddDependentFile a          -> putWord8 42 >> put a
+  AddTopDecls a               -> putWord8 43 >> put a
+  IsExtEnabled a              -> putWord8 44 >> put a
+  ExtsEnabled                 -> putWord8 45
+  QDone                       -> putWord8 46
+  QException a                -> putWord8 47 >> put a
+  QFail a                     -> putWord8 48 >> put a
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
index 710cffd..d422813 100644 (file)
@@ -52,7 +52,7 @@ lookupClosure str = do
   case m of
     Nothing -> return Nothing
     Just (Ptr addr) -> case addrToAny# addr of
-      (# a #) -> Just <$> mkHValueRef (HValue a)
+      (# a #) -> Just <$> mkRemoteRef (HValue a)
 
 prefixUnderscore :: String -> String
 prefixUnderscore
index 920ce93..ea91f19 100644 (file)
@@ -1,16 +1,19 @@
 {-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
 module GHCi.RemoteTypes
-  ( RemotePtr(..), toRemotePtr, fromRemotePtr
+  ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr
   , HValue(..)
-  , HValueRef, mkHValueRef, localHValueRef, freeHValueRef
-  , ForeignHValue, mkForeignHValue, withForeignHValue
-  , unsafeForeignHValueToHValueRef, finalizeForeignHValue
+  , RemoteRef, mkRemoteRef, localRef, freeRemoteRef
+  , HValueRef, toHValueRef
+  , ForeignRef, mkForeignRef, withForeignRef
+  , ForeignHValue
+  , unsafeForeignRefToRemoteRef, finalizeForeignRef
   ) where
 
 import Data.Word
 import Foreign hiding (newForeignPtr)
 import Foreign.Concurrent
 import Data.Binary
+import Unsafe.Coerce
 import GHC.Exts
 import GHC.ForeignPtr
 
@@ -22,19 +25,22 @@ import GHC.ForeignPtr
 
 #include "MachDeps.h"
 #if SIZEOF_HSINT == 4
-newtype RemotePtr = RemotePtr Word32
+newtype RemotePtr = RemotePtr Word32
 #elif SIZEOF_HSINT == 8
-newtype RemotePtr = RemotePtr Word64
+newtype RemotePtr = RemotePtr Word64
 #endif
 
-toRemotePtr :: Ptr a -> RemotePtr
+toRemotePtr :: Ptr a -> RemotePtr a
 toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p))
 
-fromRemotePtr :: RemotePtr -> Ptr a
+fromRemotePtr :: RemotePtr -> Ptr a
 fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p)
 
-deriving instance Show RemotePtr
-deriving instance Binary RemotePtr
+castRemotePtr :: RemotePtr a -> RemotePtr b
+castRemotePtr (RemotePtr a) = RemotePtr a
+
+deriving instance Show (RemotePtr a)
+deriving instance Binary (RemotePtr a)
 
 -- -----------------------------------------------------------------------------
 -- HValueRef
@@ -44,48 +50,57 @@ newtype HValue = HValue Any
 instance Show HValue where
   show _ = "<HValue>"
 
-newtype HValueRef = HValueRef RemotePtr
+-- | A reference to a remote value.  These are allocated and freed explicitly.
+newtype RemoteRef a = RemoteRef (RemotePtr ())
   deriving (Show, Binary)
 
--- | Make a reference to a local HValue that we can send remotely.
+-- We can discard type information if we want
+toHValueRef :: RemoteRef a -> RemoteRef HValue
+toHValueRef = unsafeCoerce
+
+-- For convenience
+type HValueRef = RemoteRef HValue
+
+-- | Make a reference to a local value that we can send remotely.
 -- This reference will keep the value that it refers to alive until
--- 'freeHValueRef' is called.
-mkHValueRef :: HValue -> IO HValueRef
-mkHValueRef (HValue hv) = do
-  sp <- newStablePtr hv
-  return $! HValueRef (toRemotePtr (castStablePtrToPtr sp))
+-- 'freeRemoteRef' is called.
+mkRemoteRef :: a -> IO (RemoteRef a)
+mkRemoteRef a = do
+  sp <- newStablePtr a
+  return $! RemoteRef (toRemotePtr (castStablePtrToPtr sp))
 
 -- | Convert an HValueRef to an HValue.  Should only be used if the HValue
 -- originated in this process.
-localHValueRef :: HValueRef -> IO HValue
-localHValueRef (HValueRef w) = do
-  p <- deRefStablePtr (castPtrToStablePtr (fromRemotePtr w))
-  return (HValue p)
+localRef :: RemoteRef a -> IO a
+localRef (RemoteRef w) =
+  deRefStablePtr (castPtrToStablePtr (fromRemotePtr w))
 
 -- | Release an HValueRef that originated in this process
-freeHValueRef :: HValueRef -> IO ()
-freeHValueRef (HValueRef w) =
+freeRemoteRef :: RemoteRef a -> IO ()
+freeRemoteRef (RemoteRef w) =
   freeStablePtr (castPtrToStablePtr (fromRemotePtr w))
 
 -- | An HValueRef with a finalizer
-newtype ForeignHValue = ForeignHValue (ForeignPtr ())
+newtype ForeignRef a = ForeignRef (ForeignPtr ())
+
+type ForeignHValue = ForeignRef HValue
 
--- | Create a 'ForeignHValue' from an 'HValueRef'.  The finalizer
+-- | Create a 'ForeignRef' from a 'RemoteRef'.  The finalizer
 -- should arrange to call 'freeHValueRef' on the 'HValueRef'.  (since
 -- this function needs to be called in the process that created the
 -- 'HValueRef', it cannot be called directly from the finalizer).
-mkForeignHValue :: HValueRef -> IO () -> IO ForeignHValue
-mkForeignHValue (HValueRef hvref) finalizer =
-  ForeignHValue <$> newForeignPtr (fromRemotePtr hvref) finalizer
+mkForeignRef :: RemoteRef a -> IO () -> IO (ForeignRef a)
+mkForeignRef (RemoteRef hvref) finalizer =
+  ForeignRef <$> newForeignPtr (fromRemotePtr hvref) finalizer
 
 -- | Use a 'ForeignHValue'
-withForeignHValue :: ForeignHValue -> (HValueRef -> IO a) -> IO a
-withForeignHValue (ForeignHValue fp) f =
-   withForeignPtr fp (f . HValueRef . toRemotePtr)
+withForeignRef :: ForeignRef a -> (RemoteRef a -> IO b) -> IO b
+withForeignRef (ForeignRef fp) f =
+   withForeignPtr fp (f . RemoteRef . toRemotePtr)
 
-unsafeForeignHValueToHValueRef :: ForeignHValue -> HValueRef
-unsafeForeignHValueToHValueRef (ForeignHValue fp) =
-  HValueRef (toRemotePtr (unsafeForeignPtrToPtr fp))
+unsafeForeignRefToRemoteRef :: ForeignRef a -> RemoteRef a
+unsafeForeignRefToRemoteRef (ForeignRef fp) =
+  RemoteRef (toRemotePtr (unsafeForeignPtrToPtr fp))
 
-finalizeForeignHValue :: ForeignHValue -> IO ()
-finalizeForeignHValue (ForeignHValue fp) = finalizeForeignPtr fp
+finalizeForeignRef :: ForeignRef a -> IO ()
+finalizeForeignRef (ForeignRef fp) = finalizeForeignPtr fp
index 9234210..a349ded 100644 (file)
@@ -6,6 +6,7 @@ module GHCi.ResolvedBCO
 
 import SizedSeq
 import GHCi.RemoteTypes
+import GHCi.BreakArray
 
 import Data.Array.Unboxed
 import Data.Binary
@@ -32,31 +33,14 @@ instance Binary ResolvedBCO
 data ResolvedBCOPtr
   = ResolvedBCORef Int
       -- ^ reference to the Nth BCO in the current set
-  | ResolvedBCOPtr HValueRef
+  | ResolvedBCOPtr (RemoteRef HValue)
       -- ^ reference to a previously created BCO
-  | ResolvedBCOStaticPtr RemotePtr
+  | ResolvedBCOStaticPtr (RemotePtr ())
       -- ^ reference to a static ptr
   | ResolvedBCOPtrBCO ResolvedBCO
       -- ^ a nested BCO
-  | ResolvedBCOPtrLocal HValue
-      -- ^ something local, cannot be serialized
+  | ResolvedBCOPtrBreakArray (RemoteRef BreakArray)
+      -- ^ Resolves to the MutableArray# inside the BreakArray
   deriving (Generic, Show)
 
--- Manual Binary instance is needed because we cannot serialize
--- ResolvedBCOPtrLocal.  This will go away once we have support for
--- remote breakpoints.
-instance Binary ResolvedBCOPtr where
-  put (ResolvedBCORef a) = putWord8 0 >> put a
-  put (ResolvedBCOPtr a) = putWord8 1 >> put a
-  put (ResolvedBCOStaticPtr a) = putWord8 2 >> put a
-  put (ResolvedBCOPtrBCO a) = putWord8 3 >> put a
-  put (ResolvedBCOPtrLocal _) =
-    error "Cannot serialize a local pointer.  Use -fno-external-interpreter?"
-
-  get = do
-    w <- getWord8
-    case w of
-      0 -> ResolvedBCORef <$> get
-      1 -> ResolvedBCOPtr <$> get
-      2 -> ResolvedBCOStaticPtr <$> get
-      _ -> ResolvedBCOPtrBCO <$> get
+instance Binary ResolvedBCOPtr
index 8934437..865072e 100644 (file)
@@ -16,6 +16,7 @@ import GHCi.Message
 import GHCi.ObjLink
 import GHCi.RemoteTypes
 import GHCi.TH
+import GHCi.BreakArray
 
 import Control.Concurrent
 import Control.DeepSeq
@@ -50,16 +51,26 @@ run m = case m of
   ResolveObjs -> resolveObjs
   FindSystemLibrary str -> findSystemLibrary str
   CreateBCOs bco -> createBCOs bco
-  FreeHValueRefs rs -> mapM_ freeHValueRef rs
+  FreeHValueRefs rs -> mapM_ freeRemoteRef rs
   EvalStmt opts r -> evalStmt opts r
   ResumeStmt opts r -> resumeStmt opts r
   AbandonStmt r -> abandonStmt r
   EvalString r -> evalString r
   EvalStringToString r s -> evalStringToString r s
   EvalIO r -> evalIO r
-  MkCostCentre name mod src ->
-    toRemotePtr <$> mkCostCentre (fromRemotePtr name) mod src
+  MkCostCentre mod name src ->
+    toRemotePtr <$> mkCostCentre (fromRemotePtr mod) name src
   CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
+  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
+  EnableBreakpoint ref ix b -> do
+    arr <- localRef ref
+    _ <- if b then setBreakOn arr ix else setBreakOff arr ix
+    return ()
+  BreakpointStatus ref ix -> do
+    arr <- localRef ref; r <- getBreak arr ix
+    case r of
+      Nothing -> return False
+      Just w -> return (w /= 0)
   MallocData bs -> mkString bs
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
@@ -73,9 +84,9 @@ evalStmt opts expr = do
   io <- mkIO expr
   sandboxIO opts $ do
     rs <- unsafeCoerce io :: IO [HValue]
-    mapM mkHValueRef rs
+    mapM mkRemoteRef rs
  where
-  mkIO (EvalThis href) = localHValueRef href
+  mkIO (EvalThis href) = localRef href
   mkIO (EvalApp l r) = do
     l' <- mkIO l
     r' <- mkIO r
@@ -83,19 +94,19 @@ evalStmt opts expr = do
 
 evalIO :: HValueRef -> IO (EvalResult ())
 evalIO r = do
-  io <- localHValueRef r
+  io <- localRef r
   tryEval (unsafeCoerce io :: IO ())
 
 evalString :: HValueRef -> IO (EvalResult String)
 evalString r = do
-  io <- localHValueRef r
+  io <- localRef r
   tryEval $ do
     r <- unsafeCoerce io :: IO String
     evaluate (force r)
 
 evalStringToString :: HValueRef -> String -> IO (EvalResult String)
 evalStringToString r str = do
-  io <- localHValueRef r
+  io <- localRef r
   tryEval $ do
     r <- (unsafeCoerce io :: String -> IO String) str
     evaluate (force r)
@@ -232,17 +243,17 @@ withBreakAction opts breakMVar statusMVar act
         -- might be a bit surprising.  The exception flag is turned off
         -- as soon as it is hit, or in resetBreakAction below.
 
-   onBreak is_exception info apStack = do
+   onBreak :: BreakpointCallback
+   onBreak ix# uniq# is_exception apStack = do
      tid <- myThreadId
      let resume = ResumeContext
            { resumeBreakMVar = breakMVar
            , resumeStatusMVar = statusMVar
            , resumeThreadId = tid }
-     resume_r <- mkHValueRef (unsafeCoerce resume)
-     apStack_r <- mkHValueRef apStack
-     info_r <- mkHValueRef info
+     resume_r <- mkRemoteRef resume
+     apStack_r <- mkRemoteRef apStack
      ccs <- toRemotePtr <$> getCCSOf apStack
-     putMVar statusMVar $ EvalBreak is_exception apStack_r info_r resume_r ccs
+     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
      takeMVar breakMVar
 
    resetBreakAction stablePtr = do
@@ -251,15 +262,11 @@ withBreakAction opts breakMVar statusMVar act
      resetStepFlag
      freeStablePtr stablePtr
 
-data ResumeContext a = ResumeContext
-  { resumeBreakMVar :: MVar ()
-  , resumeStatusMVar :: MVar (EvalStatus a)
-  , resumeThreadId :: ThreadId
-  }
-
-resumeStmt :: EvalOpts -> HValueRef -> IO (EvalStatus [HValueRef])
+resumeStmt
+  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])
+  -> IO (EvalStatus [HValueRef])
 resumeStmt opts hvref = do
-  ResumeContext{..} <- unsafeCoerce (localHValueRef hvref)
+  ResumeContext{..} <- localRef hvref
   withBreakAction opts resumeBreakMVar resumeStatusMVar $
     mask_ $ do
       putMVar resumeBreakMVar () -- this awakens the stopped thread...
@@ -277,9 +284,9 @@ resumeStmt opts hvref = do
 --          step is necessary to prevent race conditions with
 --          -fbreak-on-exception (see #5975).
 --  See test break010.
-abandonStmt :: HValueRef -> IO ()
+abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()
 abandonStmt hvref = do
-  ResumeContext{..} <- unsafeCoerce (localHValueRef hvref)
+  ResumeContext{..} <- localRef hvref
   killThread resumeThreadId
   putMVar resumeBreakMVar ()
   _ <- takeMVar resumeStatusMVar
@@ -293,35 +300,35 @@ setStepFlag = poke stepFlag 1
 resetStepFlag :: IO ()
 resetStepFlag = poke stepFlag 0
 
+type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO ()
+
 foreign import ccall "&rts_breakpoint_io_action"
-   breakPointIOAction :: Ptr (StablePtr (Bool -> HValue -> HValue -> IO ()))
+   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)
 
-noBreakStablePtr :: StablePtr (Bool -> HValue -> HValue -> IO ())
+noBreakStablePtr :: StablePtr BreakpointCallback
 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 
-noBreakAction :: Bool -> HValue -> HValue -> IO ()
-noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction True  _ _ = return () -- exception: just continue
+noBreakAction :: BreakpointCallback
+noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ True  _ = return () -- exception: just continue
 
 -- Malloc and copy the bytes.  We don't have any way to monitor the
 -- lifetime of this memory, so it just leaks.
-mkString :: ByteString -> IO RemotePtr
+mkString :: ByteString -> IO (RemotePtr ())
 mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
   ptr <- mallocBytes len
   copyBytes ptr cstr len
-  return (toRemotePtr ptr)
-
-data CCostCentre
+  return (castRemotePtr (toRemotePtr ptr))
 
-mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CCostCentre)
+mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CostCentre)
 #if defined(PROFILING)
-mkCostCentre c_module srcspan decl_path = do
+mkCostCentre c_module decl_path srcspan = do
   c_name <- newCString decl_path
   c_srcspan <- newCString srcspan
   c_mkCostCentre c_name c_module c_srcspan
 
 foreign import ccall unsafe "mkCostCentre"
-  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CCostCentre)
+  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
 #else
 mkCostCentre _ _ _ = return nullPtr
 #endif
index 717192e..799bd62 100644 (file)
@@ -28,18 +28,6 @@ import qualified Language.Haskell.TH        as TH
 import qualified Language.Haskell.TH.Syntax as TH
 import Unsafe.Coerce
 
-data QState = QState
-  { qsMap        :: Map TypeRep Dynamic
-       -- ^ persistent data between splices in a module
-  , qsFinalizers :: [TH.Q ()]
-       -- ^ registered finalizers (in reverse order)
-  , qsLocation   :: Maybe TH.Loc
-       -- ^ location for current splice, if any
-  , qsPipe :: Pipe
-       -- ^ pipe to communicate with GHC
-  }
-instance Show QState where show _ = "<QState>"
-
 initQState :: Pipe -> QState
 initQState p = QState M.empty [] Nothing p
 
@@ -133,41 +121,41 @@ instance TH.Quasi GHCiQ where
   qIsExtEnabled x = ghcCmd (IsExtEnabled x)
   qExtsEnabled = ghcCmd ExtsEnabled
 
-startTH :: IO HValueRef
+startTH :: IO (RemoteRef (IORef QState))
 startTH = do
   r <- newIORef (initQState (error "startTH: no pipe"))
-  mkHValueRef (unsafeCoerce r)
+  mkRemoteRef r
 
-finishTH :: Pipe -> HValueRef -> IO ()
+finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()
 finishTH pipe rstate = do
-  qstateref <- unsafeCoerce <$> localHValueRef rstate
+  qstateref <- localRef rstate
   qstate <- readIORef qstateref
   _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
-  freeHValueRef rstate
+  freeRemoteRef rstate
   return ()
 
 runTH
-  :: Pipe -> HValueRef -> HValueRef
+  :: Pipe -> RemoteRef (IORef QState) -> HValueRef
   -> THResultType
   -> Maybe TH.Loc
   -> IO ByteString
 runTH pipe rstate rhv ty mb_loc = do
-  hv <- localHValueRef rhv
+  hv <- localRef rhv
   case ty of
     THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
     THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
     THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
     THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
     THAnnWrapper -> do
-      hv <- unsafeCoerce <$> localHValueRef rhv
+      hv <- unsafeCoerce <$> localRef rhv
       case hv :: AnnotationWrapper of
         AnnotationWrapper thing ->
           return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
 
-runTHQ :: Binary a => Pipe -> HValueRef -> Maybe TH.Loc -> TH.Q a
+runTHQ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
        -> IO ByteString
 runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
-  qstateref <- unsafeCoerce <$> localHValueRef rstate
+  qstateref <- localRef rstate
   qstate <- readIORef qstateref
   let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
   (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
index 85698c0..547374a 100644 (file)
@@ -42,6 +42,7 @@ library
         UnboxedTuples
 
     exposed-modules:
+        GHCi.BreakArray
         GHCi.Message
         GHCi.ResolvedBCO
         GHCi.RemoteTypes
index 8d19c14..a89bd19 100644 (file)
@@ -524,14 +524,17 @@ retry_pop_stack:
             // be per-thread.
             CInt[rts_stop_on_exception] = 0;
             ("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
-            Sp = Sp - WDS(6);
-            Sp(5) = exception;
-            Sp(4) = stg_raise_ret_info;
-            Sp(3) = exception;             // the AP_STACK
-            Sp(2) = ghczmprim_GHCziTypes_True_closure; // dummy breakpoint info
-            Sp(1) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint
+            Sp = Sp - WDS(9);
+            Sp(8) = exception;
+            Sp(7) = stg_raise_ret_info;
+            Sp(6) = exception;
+            Sp(5) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint
+            Sp(4) = stg_ap_ppv_info;
+            Sp(3) = 0;
+            Sp(2) = stg_ap_n_info;
+            Sp(1) = 0;
             R1 = ioAction;
-            jump RET_LBL(stg_ap_pppv) [R1];
+            jump RET_LBL(stg_ap_n) [R1];
         }
     }
 
index 37fef9c..21d7527 100644 (file)
@@ -928,7 +928,7 @@ run_BCO:
         /* check for a breakpoint on the beginning of a let binding */
         case bci_BRK_FUN:
         {
-            int arg1_brk_array, arg2_array_index, arg3_freeVars;
+            int arg1_brk_array, arg2_array_index, arg3_module_uniq;
 #ifdef PROFILING
             int arg4_cc;
 #endif
@@ -946,7 +946,7 @@ run_BCO:
 
             arg1_brk_array      = BCO_GET_LARGE_ARG;
             arg2_array_index    = BCO_NEXT;
-            arg3_freeVars       = BCO_GET_LARGE_ARG;
+            arg3_module_uniq    = BCO_GET_LARGE_ARG;
 #ifdef PROFILING
             arg4_cc             = BCO_GET_LARGE_ARG;
 #else
@@ -1002,20 +1002,31 @@ run_BCO:
                      new_aps->payload[i] = (StgClosure *)Sp[i-2];
                   }
 
-                  // prepare the stack so that we can call the
-                  // rts_breakpoint_io_action and ensure that the stack is
-                  // in a reasonable state for the GC and so that
-                  // execution of this BCO can continue when we resume
-                  ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
-                  Sp -= 8;
-                  Sp[7] = (W_)obj;
-                  Sp[6] = (W_)&stg_apply_interp_info;
-                  Sp[5] = (W_)new_aps;                 // the AP_STACK
-                  Sp[4] = (W_)BCO_PTR(arg3_freeVars);  // the info about local vars of the breakpoint
-                  Sp[3] = (W_)False_closure;            // True <=> a breakpoint
-                  Sp[2] = (W_)&stg_ap_pppv_info;
-                  Sp[1] = (W_)ioAction;                // apply the IO action to its two arguments above
-                  Sp[0] = (W_)&stg_enter_info;         // get ready to run the IO action
+                  // Arrange the stack to call the breakpoint IO action, and
+                  // continue execution of this BCO when the IO action returns.
+                  //
+                  // ioAction :: Bool        -- exception?
+                  //          -> HValue      -- the AP_STACK, or exception
+                  //          -> Int         -- the breakpoint index (arg2)
+                  //          -> Int         -- the module uniq (arg3)
+                  //          -> IO ()
+                  //
+                  ioAction = (StgClosure *) deRefStablePtr (
+                      rts_breakpoint_io_action);
+
+                  Sp -= 11;
+                  Sp[10] = (W_)obj;
+                  Sp[9]  = (W_)&stg_apply_interp_info;
+                  Sp[8]  = (W_)new_aps;
+                  Sp[7]  = (W_)False_closure;         // True <=> a breakpoint
+                  Sp[6]  = (W_)&stg_ap_ppv_info;
+                  Sp[5]  = (W_)BCO_LIT(arg3_module_uniq);
+                  Sp[4]  = (W_)&stg_ap_n_info;
+                  Sp[3]  = (W_)arg2_array_index;
+                  Sp[2]  = (W_)&stg_ap_n_info;
+                  Sp[1]  = (W_)ioAction;
+                  Sp[0]  = (W_)&stg_enter_info;
+
                   // set the flag in the TSO to say that we are now
                   // stopping at a breakpoint so that when we resume
                   // we don't stop on the same breakpoint that we
index 8352d88..74bcc4a 100644 (file)
@@ -278,10 +278,10 @@ endif # $1_$2_PROG_NEEDS_C_WRAPPER
 ifneq "$$(CLEANING)" "YES"
 ifneq "$3" "0"
 ifneq "$$($1_$2_HS_SRCS)" ""
-ifeq "$$(strip $$(ALL_STAGE1_LIBS))" ""
-$$(error ordering failure in $1 ($2): ALL_STAGE1_LIBS is empty)
+ifeq "$$(strip $$(ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS))" ""
+$$(error ordering failure in $1 ($2): ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS is empty)
 endif
-$1/$2/build/tmp/$$($1_$2_PROG) : $$(ALL_STAGE1_LIBS) $$(ALL_RTS_LIBS) $$(OTHER_LIBS)
+$1/$2/build/tmp/$$($1_$2_PROG) : $$(ALL_STAGE1_$$($1_$2_PROGRAM_WAY)_LIBS) $$(ALL_RTS_LIBS)
 endif
 endif
 endif
index cc680a5..7124178 100644 (file)
@@ -55,7 +55,7 @@ _result :: m () = _
                           ^^^^^^^
 7                         line2 0
 Stopped in Main.line1, break020.hs:3:11-19
-_result :: m () = _
+_result :: IO () = _
 2  
 3  line1 _ = return ()
              ^^^^^^^^^
@@ -67,7 +67,7 @@ _result :: m () = _
                           ^^^^^^^
 8  
 Stopped in Main.line2, break020.hs:4:11-19
-_result :: m () = _
+_result :: IO () = _
 3  line1 _ = return ()
 4  line2 _ = return ()
              ^^^^^^^^^