Re-working of the breakpoint support
authorSimon Marlow <simonmar@microsoft.com>
Tue, 17 Apr 2007 14:24:58 +0000 (14:24 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Tue, 17 Apr 2007 14:24:58 +0000 (14:24 +0000)
This is the result of Bernie Pope's internship work at MSR Cambridge,
with some subsequent improvements by me.  The main plan was to

 (a) Reduce the overhead for breakpoints, so we could enable
     the feature by default without incurrent a significant penalty
 (b) Scatter more breakpoint sites throughout the code

Currently we can set a breakpoint on almost any subexpression, and the
overhead is around 1.5x slower than normal GHCi.  I hope to be able to
get this down further and/or allow breakpoints to be turned off.

This patch also fixes up :print following the recent changes to
constructor info tables.  (most of the :print tests now pass)

We now support single-stepping, which just enables all breakpoints.

  :step <expr>     executes <expr> with single-stepping turned on
  :step            single-steps from the current breakpoint

The mechanism is quite different to the previous implementation.  We
share code with the HPC (haskell program coverage) implementation now.
The coverage pass annotates source code with "tick" locations which
are tracked by the coverage tool.  In GHCi, each "tick" becomes a
potential breakpoint location.

Previously breakpoints were compiled into code that magically invoked
a nested instance of GHCi.  Now, a breakpoint causes the current
thread to block and control is returned to GHCi.

See the wiki page for more details and the current ToDo list:

  http://hackage.haskell.org/trac/ghc/wiki/NewGhciDebugger

47 files changed:
compiler/Makefile
compiler/basicTypes/IdInfo.lhs
compiler/basicTypes/MkId.lhs
compiler/cmm/CmmParse.y
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsBreakpoint.lhs [deleted file]
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsGRHSs.lhs
compiler/deSugar/DsMonad.lhs
compiler/deSugar/DsUtils.lhs
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/ByteCodeInstr.lhs
compiler/ghci/ByteCodeItbls.lhs
compiler/ghci/ByteCodeLink.lhs
compiler/ghci/Debugger.hs
compiler/ghci/Debugger.hs-boot [deleted file]
compiler/ghci/GhciMonad.hs
compiler/ghci/InteractiveUI.hs
compiler/ghci/Linker.lhs
compiler/ghci/RtClosureInspect.hs
compiler/ghci/TickTree.hs [new file with mode: 0644]
compiler/iface/TcIface.lhs
compiler/main/BreakArray.hs [new file with mode: 0644]
compiler/main/Breakpoints.hs [deleted file]
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/package.conf.in
compiler/prelude/primops.txt.pp
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnDriver.lhs-boot
compiler/typecheck/TcSplice.lhs
includes/Bytecodes.h
includes/Constants.h
includes/StgMiscClosures.h
mk/config.mk.in
rts/Disassembler.c
rts/Interpreter.c
rts/Linker.c
rts/PrimOps.cmm
rts/Printer.c
rts/Printer.h

index 1e8322b..e16bf4e 100644 (file)
@@ -415,10 +415,6 @@ ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
 SRC_HC_OPTS += -DGHCI -package template-haskell
 PKG_DEPENDS += template-haskell
 
-# Should the debugger commands be enabled?
-ifeq "$(GhciWithDebugger)" "YES"
-SRC_HC_OPTS += -DDEBUGGER
-endif
 # Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
 # or not?
 ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
index 02ef0db..b59ddf9 100644 (file)
@@ -718,8 +718,8 @@ zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo
 type TickBoxId = Int
 
 data TickBoxOp 
-   = TickBox Module !TickBoxId  -- ^Tick box for Hpc-style coverage,
-                               -- type = State# Void#
+   = TickBox Module {-# UNPACK #-} !TickBoxId
+          -- ^Tick box for Hpc-style coverage
 
 instance Outputable TickBoxOp where
     ppr (TickBox mod n)         = ptext SLIT("tick") <+> ppr (mod,n)
index 741ca58..67cf5e4 100644 (file)
@@ -18,7 +18,7 @@ module MkId (
 
        mkDataConIds,
        mkRecordSelId, 
-       mkPrimOpId, mkFCallId, mkTickBoxOpId, 
+       mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
@@ -905,17 +905,28 @@ mkFCallId uniq fcall ty
     arity       = length arg_tys
     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
 
-mkTickBoxOpId :: Unique 
-             -> Module
-             -> TickBoxId
-             -> Id
-mkTickBoxOpId uniq mod ix =  mkGlobalId (TickBoxOpId tickbox) name ty info    
+-- Tick boxes and breakpoints are both represented as TickBoxOpIds,
+-- except for the type:
+--
+--    a plain HPC tick box has type (State# RealWorld)
+--    a breakpoint Id has type forall a.a
+--
+-- The breakpoint Id will be applied to a list of arbitrary free variables,
+-- which is why it needs a polymorphic type.
+
+mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id
+mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy
+
+mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id
+mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty
+ where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
+
+mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info    
   where
     tickbox = TickBox mod ix
     occ_str = showSDoc (braces (ppr tickbox))
     name    = mkTickBoxOpName uniq occ_str
     info    = noCafIdInfo
-    ty      = realWorldStatePrimTy 
 \end{code}
 
 
index 72a5713..bd35072 100644 (file)
@@ -607,6 +607,7 @@ stmtMacros = listToUFM [
   ( FSLIT("RET_NN"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
   ( FSLIT("RET_NP"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
   ( FSLIT("RET_PPP"),  \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
+  ( FSLIT("RET_NPP"),  \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNP"),  \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
   ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
index 64e65a4..8624780 100644 (file)
@@ -1,5 +1,6 @@
 %
 % (c) Galois, 2006
+% (c) University of Glasgow, 2007
 %
 \section[Coverage]{@coverage@: the main function}
 
@@ -20,7 +21,9 @@ import Bag
 import Var
 import Data.List
 import FastString
+import StaticFlags
 
+import Data.Array
 import System.Time (ClockTime(..))
 import System.Directory (getModificationTime)
 import System.IO   (FilePath)
@@ -29,6 +32,9 @@ import Compat.Directory ( createDirectoryIfMissing )
 #else
 import System.Directory ( createDirectoryIfMissing )
 #endif
+
+import HscTypes 
+import BreakArray 
 \end{code}
 
 %************************************************************************
@@ -38,15 +44,20 @@ import System.Directory ( createDirectoryIfMissing )
 %************************************************************************
 
 \begin{code}
+addCoverageTicksToBinds
+        :: DynFlags
+        -> Module
+        -> ModLocation          -- of the current module
+        -> LHsBinds Id
+        -> IO (LHsBinds Id, Int, ModBreaks)
+
 addCoverageTicksToBinds dflags mod mod_loc binds = do 
   let orig_file = 
              case ml_hs_file mod_loc of
                    Just file -> file
                    Nothing -> panic "can not find the original file during hpc trans"
 
-  if "boot" `isSuffixOf` orig_file then return (binds, 0) else do
-
-  modTime <- getModificationTime' orig_file
+  if "boot" `isSuffixOf` orig_file then return (binds, 0, emptyModBreaks) else do
 
   let mod_name = moduleNameString (moduleName mod)
 
@@ -58,19 +69,32 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
                      , mixEntries   = []
                      }
 
-  let hpc_dir = hpcDir dflags
+  let entries = reverse $ mixEntries st
 
   -- write the mix entries for this module
-  let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
-
-  createDirectoryIfMissing True hpc_dir
-
-  mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
+  when opt_Hpc $ do
+     let hpc_dir = hpcDir dflags
+     let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
+     createDirectoryIfMissing True hpc_dir
+     modTime <- getModificationTime' orig_file
+     mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop entries)
+
+  -- Todo: use proper src span type
+  breakArray <- newBreakArray $ length entries
+  let fn = mkFastString orig_file
+  let locsTicks = listArray (0,tickBoxCount st-1)
+                        [ mkSrcSpan (mkSrcLoc fn r1 c1) (mkSrcLoc fn r2 c2)
+                        | (P r1 c1 r2 c2, _box) <- entries ] 
+
+  let modBreaks = emptyModBreaks 
+                  { modBreaks_array = breakArray 
+                  , modBreaks_ticks = locsTicks 
+                  } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
          printDump (pprLHsBinds binds1)
---       putStrLn (showSDocDebug (pprLHsBinds binds3))
-  return (binds1, tickBoxCount st)
+
+  return (binds1, tickBoxCount st, modBreaks)
 \end{code}
 
 
@@ -87,20 +111,32 @@ addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
 addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
   abs_binds' <- addTickLHsBinds abs_binds
   return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  })))  = do
+
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
 
-  tick_no <- allocATickBox (if null decl_path
-                           then TopLevelBox [name]
-                           else LocalBox (name : decl_path))
-                         pos
-
-  mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)  
+  mg@(MatchGroup matches' ty) <- addPathEntry name  
                                 $ addTickMatchGroup (fun_matches funBind)
-  return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
-                          , fun_tick = tick_no
-                          }
+
+  -- Todo: we don't want redundant ticks on simple pattern bindings
+  if not opt_Hpc && isSimplePatBind funBind
+     then 
+        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
+                                 , fun_tick = Nothing 
+                                 }
+     else do
+        tick_no <- allocATickBox (if null decl_path
+                                     then TopLevelBox [name]
+                                     else LocalBox (name : decl_path)) pos
+
+        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
+                                 , fun_tick = tick_no
+                                 }
+   where
+   -- a binding is a simple pattern binding if it is a funbind with zero patterns
+   isSimplePatBind :: HsBind a -> Bool
+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
 
 -- TODO: Revisit this
 addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
@@ -121,14 +157,47 @@ addTickLHsBind (VarBind var_id var_rhs) = do
 -}
 addTickLHsBind other = return other
 
-addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExpr (L pos e0) = do
+-- add a tick to the expression no matter what it is
+addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprAlways (L pos e0) = do
     e1 <- addTickHsExpr e0
     fn <- allocTickBox ExpBox pos 
     return $ fn $ L pos e1
 
+-- always a breakpoint tick, maybe an HPC tick
+addTickLHsExprBreakAlways :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprBreakAlways e
+    | opt_Hpc   = addTickLHsExpr e
+    | otherwise = addTickLHsExprAlways e
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    if opt_Hpc || isGoodBreakExpr e0
+       then do
+          fn <- allocTickBox ExpBox pos 
+          return $ fn $ L pos e1
+       else
+          return $ L pos e1 
+
+-- general heuristic: expressions which do not denote values are good break points
+isGoodBreakExpr :: HsExpr Id -> Bool
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr (NegApp {})    = True
+isGoodBreakExpr (HsCase {})    = True
+isGoodBreakExpr (HsIf {})      = True
+isGoodBreakExpr (RecordCon {}) = True
+isGoodBreakExpr (RecordUpd {}) = True
+isGoodBreakExpr (ArithSeq {})  = True
+isGoodBreakExpr (PArrSeq {})   = True
+isGoodBreakExpr other          = False 
+
 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprOptAlt oneOfMany (L pos e0) = do
+addTickLHsExprOptAlt oneOfMany (L pos e0)
+  | not opt_Hpc = addTickLHsExpr (L pos e0)
+  | otherwise = do
     e1 <- addTickHsExpr e0
     fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos 
     return $ fn $ L pos e1
@@ -145,7 +214,6 @@ addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addBinTickLHsExpr boxLabel (L pos e0) = do
     e1 <- addTickHsExpr e0
     allocBinTickBox boxLabel $ L pos e1
-    
 
 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
 addTickHsExpr e@(HsVar _) = return e
@@ -162,7 +230,7 @@ addTickHsExpr (OpApp e1 e2 fix e3) =
                (addTickLHsExpr' e2)
                (return fix)
                (addTickLHsExpr e3)
-addTickHsExpr ( NegApp e neg) =
+addTickHsExpr (NegApp e neg) =
        liftM2 NegApp
                (addTickLHsExpr e) 
                (addTickSyntaxExpr hpcSrcSpan neg)
@@ -201,11 +269,11 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
 addTickHsExpr (ExplicitList ty es) = 
        liftM2 ExplicitList 
                (return ty)
-               (mapM addTickLHsExpr es)
+               (mapM (addTickLHsExpr) es)
 addTickHsExpr (ExplicitPArr     {}) = error "addTickHsExpr: ExplicitPArr"
 addTickHsExpr (ExplicitTuple es box) =
        liftM2 ExplicitTuple
-               (mapM addTickLHsExpr es)
+               (mapM (addTickLHsExpr) es)
                (return box)
 addTickHsExpr (RecordCon        id ty rec_binds) = 
        liftM3 RecordCon
@@ -242,7 +310,7 @@ addTickHsExpr e@(HsSpliceE  {}) = return e
 addTickHsExpr (HsProc pat cmdtop) =
        liftM2 HsProc
                (addTickLPat pat)
-               (liftL addTickHsCmdTop cmdtop)
+               (liftL (addTickHsCmdTop) cmdtop)
 addTickHsExpr (HsWrap w e) = 
        liftM2 HsWrap
                (return w)
@@ -258,7 +326,7 @@ addTickHsExpr (HsArrForm e fix cmdtop) =
         liftM3 HsArrForm
               (addTickLHsExpr e)
               (return fix)
-              (mapM (liftL addTickHsCmdTop) cmdtop)
+              (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
 addTickHsExpr e@(HsType ty) = return e
 
@@ -288,15 +356,15 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
 addTickGRHS isOneOfMany (GRHS stmts expr) = do
   stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
-  expr' <- addTickLHsExprOptAlt isOneOfMany expr
+  expr' <- if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
+                      else addTickLHsExprAlways expr 
   return $ GRHS stmts' expr'
 
-
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 addTickStmt isGuard (BindStmt pat e bind fail) =
        liftM4 BindStmt
                (addTickLPat pat)
-               (addTickLHsExpr e)
+               (addTickLHsExprBreakAlways e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
 addTickStmt isGuard (ExprStmt e bind' ty) =
@@ -305,8 +373,8 @@ addTickStmt isGuard (ExprStmt e bind' ty) =
                (addTickSyntaxExpr hpcSrcSpan bind')
                (return ty)
   where
-       addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
-                 | otherwise          = addTickLHsExpr e
+   addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
+             | otherwise          = addTickLHsExprBreakAlways e
 
 addTickStmt isGuard (LetStmt binds) =
        liftM LetStmt
@@ -346,7 +414,7 @@ addTickHsValBinds (ValBindsOut binds sigs) =
 
 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
        liftM2 IPBinds
-               (mapM (liftL addTickIPBind) ipbinds)
+               (mapM (liftL (addTickIPBind)) ipbinds)
                (addTickDictBinds dictbinds)
 
 addTickIPBind :: IPBind Id -> TM (IPBind Id)
@@ -372,7 +440,7 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
                (return ty)
                (return syntaxtable)
 
-addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
+addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
 addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
@@ -461,12 +529,18 @@ allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
       meE = (hpcPos,ExpBox)
       c = tickBoxCount st
       mes = mixEntries st
-  in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-       -- notice that F and T are reversed,
-       -- because we are building the list in
-       -- reverse...
-     , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
-     )
+  in 
+     if opt_Hpc 
+        then ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+           -- notice that F and T are reversed,
+           -- because we are building the list in
+           -- reverse...
+             , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
+             )
+        else
+             ( L pos $ HsTick c $ L pos e
+             , st {tickBoxCount=c+1,mixEntries=meE:mes}
+             )
 
 allocBinTickBox boxLabel e = return e
 
index 9da049d..4b60768 100644 (file)
@@ -45,7 +45,6 @@ import Util
 import Coverage
 import IOEnv
 import Data.IORef
-
 \end{code}
 
 %************************************************************************
@@ -85,28 +84,24 @@ deSugar hsc_env
        -- Desugar the program
         ; let export_set = availsToNameSet exports
        ; let auto_scc = mkAutoScc mod export_set
-        ; let noDbgSites = []
         ; let target = hscTarget dflags
        ; mb_res <- case target of
-                    HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
-                     _        -> do (binds_cvr,ds_hpc_info) 
-                                             <- if opt_Hpc
+                    HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
+                     _        -> do (binds_cvr,ds_hpc_info, modBreaks
+                                             <- if opt_Hpc || target == HscInterpreted
                                                  then addCoverageTicksToBinds dflags mod mod_loc binds
-                                                 else return (binds, noHpcInfo)
+                                                 else return (binds, noHpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
                                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
                                        ; (ds_fords, foreign_prs) <- dsForeigns fords
                                        ; let all_prs = foreign_prs ++ core_prs
                                              local_bndrs = mkVarSet (map fst all_prs)
                                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
-                                       ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
-                                        ; dbgSites_var <- getBkptSitesDs
-                                        ; dbgSites <- ioToIOEnv$ readIORef dbgSites_var
-                                       ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites)
+                                       ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
                                        }
        ; case mb_res of {
           Nothing -> return Nothing ;
-          Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do
+          Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
@@ -177,7 +172,7 @@ deSugar hsc_env
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
-                mg_dbg_sites   = dbgSites }
+                mg_modBreaks    = modBreaks }
         ; return (Just mod_guts)
        }}}
 
index d974c05..51d6daf 100644 (file)
@@ -23,7 +23,6 @@ import {-# SOURCE #-} Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
-import DsBreakpoint
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
@@ -63,23 +62,7 @@ import Data.List
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = do
-  mb_mod_name_ref <- getModNameRefDs
-  debugging <- breakpoints_enabled
-  case mb_mod_name_ref of 
-    Nothing | debugging -> do  -- Inject a CAF with the module name as literal
-      mod <- getModuleDs
-      mod_name_ref <- do
-                 u <- newUnique 
-                 let n = mkSystemName u (mkVarOcc "_module")
-                 return (mkLocalId n stringTy)
-      let mod_name = moduleNameFS$ moduleName mod
-      mod_lit <- dsExpr (HsLit (HsString mod_name))
-      withModNameRefDs mod_name_ref $ do
-                 res <- ds_lhs_binds auto_scc binds
-                 return$ (mod_name_ref, mod_lit) : res
-    _  -> ds_lhs_binds auto_scc binds
-
+dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 dsLHsBinds binds = ds_lhs_binds NoSccs binds
diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
deleted file mode 100644 (file)
index c6a090e..0000000
+++ /dev/null
@@ -1,217 +0,0 @@
------------------------------------------------------------------------------
---
--- Support code for instrumentation and expansion of the breakpoint combinator
---
--- Pepe Iborra (supported by Google SoC) 2006
---
------------------------------------------------------------------------------
-
-\begin{code}
-module DsBreakpoint( debug_enabled
-                   , dsAndThenMaybeInsertBreakpoint
-                   , maybeInsertBreakpoint
-                   , breakpoints_enabled
-                   , mkBreakpointExpr
-                   ) where
-
-import TysPrim
-import TysWiredIn
-import PrelNames        
-import Module
-import SrcLoc
-import TyCon
-import TypeRep
-import DataCon          
-import Type             
-import Id 
-
-import IdInfo
-import BasicTypes
-import OccName
-
-import TcRnMonad
-import HsSyn            
-import HsLit
-import CoreSyn
-import CoreUtils
-import Outputable
-import ErrUtils
-import FastString
-import DynFlags
-import MkId
-import DsMonad 
-import {-#SOURCE#-}DsExpr ( dsLExpr ) 
-import Control.Monad
-import Data.IORef
-import Foreign.StablePtr
-import GHC.Exts
-
-#ifdef GHCI
-mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
-mkBreakpointExpr loc bkptFuncId ty = do
-        scope <- getScope
-        mod   <- getModuleDs
-        u     <- newUnique
-        let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc 
-        when (not instrumenting) $
-              warnDs (text "Extracted ids:" <+> (ppr scope $$ 
-                                                   ppr (map idType scope)))
-        stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
-        site      <- if instrumenting
-                        then recordBkpt (srcSpanStart loc)
-                        else return 0
-        ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
-        jumpFuncId         <- mkJumpFunc bkptFuncId
-        Just mod_name_ref  <- getModNameRefDs 
-        let [opaqueDataCon] = tyConDataCons opaqueTyCon
-            opaqueId = dataConWrapId opaqueDataCon
-            opaqueTy = mkTyConApp opaqueTyCon []
-            wrapInOpaque id = 
-                  l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
-                          (l(HsVar id)))
-           -- Yes, I know... I'm gonna burn in hell.
-            Ptr addr# = castStablePtrToPtr stablePtr
-            locals    = ExplicitList opaqueTy (map wrapInOpaque scope)
-            locInfo = nlTuple [ HsVar mod_name_ref
-                              , HsLit (HsInt (fromIntegral site))]
-            funE  = l$ HsVar jumpFuncId
-            ptrE  = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
-            locE  = locInfo
-            msgE  = srcSpanLit loc
-            argsE = nlTuple [ptrE, locals, msgE]
-            lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
-            argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
-        return $ 
-            l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
-
-    where l = L loc
-          nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
-          srcSpanLit :: SrcSpan -> HsExpr Id
-          srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
-          instrumenting = idName bkptFuncId == breakpointAutoName
-          mkTupleType tys = mkTupleTy Boxed (length tys) tys
-#else
-mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
-#endif
-
-getScope :: DsM [Id]
-getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
-    where isValidType (FunTy a b)  = isValidType a && isValidType b
-          isValidType (NoteTy _ t) = isValidType t
-          isValidType (AppTy a b)  = isValidType a && isValidType b
-          isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && 
-                                          all isValidType ts
---        isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? 
-          isValidType _ = True
-
-dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
-#ifdef DEBUG
-dynBreakpoint loc | not (isGoodSrcSpan loc) = 
-                         pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
-#endif
-dynBreakpoint loc = do 
-    let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName 
-                         breakpointAutoTy vanillaIdInfo
-    dflags <- getDOptsDs 
-    ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
-    return$ L loc (HsVar autoBreakpoint)
-  where breakpointAutoTy = (ForAllTy alphaTyVar
-                                (FunTy (TyVarTy  alphaTyVar)
-                                 (TyVarTy alphaTyVar)))
-
--- Records a breakpoint site and returns the site number
-recordBkpt :: SrcLoc -> DsM (Int)
-recordBkpt loc = do
-    sites_var <- getBkptSitesDs
-    sites     <- ioToIOEnv$ readIORef sites_var
-    let site   = length sites + 1
-    let coords = (srcLocLine loc, srcLocCol loc)
-    ioToIOEnv$ writeIORef sites_var ((site, coords) : sites) 
-    return site
-
-mkJumpFunc :: Id -> DsM Id  
-mkJumpFunc bkptFuncId
-    | idName bkptFuncId == breakpointName 
-    = build breakpointJumpName id
-    | idName bkptFuncId == breakpointCondName 
-    = build breakpointCondJumpName (FunTy boolTy)
-    | idName bkptFuncId == breakpointAutoName 
-    = build breakpointAutoJumpName id
-  where 
-        tyvar = alphaTyVar
-        basicType extra opaqueTy = 
-               (FunTy (mkTupleType [stringTy, intTy])
-                 (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
-                          (ForAllTy tyvar
-                               (extra
-                                (FunTy (TyVarTy tyvar)
-                                 (TyVarTy tyvar))))))
-        build name extra  = do 
-            ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
-            return$ Id.mkGlobalId VanillaGlobal name
-                      (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
-        mkTupleType tys = mkTupleTy Boxed (length tys) tys
-
-debug_enabled, breakpoints_enabled :: DsM Bool
-dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
-maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
-
-#if defined(GHCI) && defined(DEBUGGER)
-debug_enabled = do
-    debugging      <- doptDs Opt_Debugging
-    b_enabled      <- breakpoints_enabled
-    return (debugging && b_enabled)
-
-breakpoints_enabled = do
-    ghcMode            <- getGhcModeDs
-    currentModule      <- getModuleDs
-    dflags             <- getDOptsDs
-    ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
-    return ( not ignore_breakpoints 
-          && hscTarget dflags == HscInterpreted
-          && currentModule /= iNTERACTIVE )
-
-maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
-  instrumenting <- isInstrumentationSpot lhsexpr
-  scope         <- getScope
-  if instrumenting && not(isUnLiftedType ty) && 
-     not(isEnabledNullScopeCoalescing && null scope)
-         then do L _ dynBkpt <- dynBreakpoint loc 
-                 return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
-         else return lhsexpr
-  where l = L loc
-dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
-  coreExpr      <- dsLExpr expr
-  instrumenting <- isInstrumentationSpot expr
-  scope         <- getScope
-  let ty = exprType coreExpr
-  if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
-     not(isEnabledNullScopeCoalescing && null scope)
-         then do L _ dynBkpt<- dynBreakpoint loc
-                 bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
-                 return (bkptCore `App` coreExpr)
-         else return coreExpr
-  where l = L loc
-#else
-maybeInsertBreakpoint expr _ = return expr
-dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
-breakpoints_enabled = return False
-debug_enabled = return False
-#endif
-
-
-isInstrumentationSpot (L loc e) = do
-  ghcmode   <- getGhcModeDs
-  instrumenting <- debug_enabled 
-  return$ instrumenting     
-          && isGoodSrcSpan loc          -- Avoids 'derived' code
-          && (not$ isRedundant e)
-
-isEnabledNullScopeCoalescing = True
-isRedundant HsLet  {} = True
-isRedundant HsDo   {} = True
-isRedundant HsCase {} = False
-isRedundant     _     = False
-
-\end{code}
index 982e315..d09196d 100644 (file)
@@ -22,11 +22,8 @@ import DsMonad
 
 #ifdef GHCI
 import PrelNames
-import DsBreakpoint
        -- Template Haskell stuff iff bootstrapped
 import DsMeta
-#else
-import DsBreakpoint
 #endif
 
 import HsSyn
@@ -52,8 +49,6 @@ import Util
 import Bag
 import Outputable
 import FastString
-
-import Data.Maybe
 \end{code}
 
 
@@ -189,21 +184,6 @@ scrungleMatch var scrut body
 \begin{code}
 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 
-#if defined(GHCI)
-dsLExpr (L loc expr@(HsWrap w (HsVar v)))
-    | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
-    , WpTyApp ty <- simpWrapper w
-    = do areBreakpointsEnabled <- breakpoints_enabled
-         if areBreakpointsEnabled
-           then do
-              L _ breakpointExpr <- mkBreakpointExpr loc v ty
-              dsLExpr (L loc $ HsWrap w breakpointExpr)
-           else putSrcSpanDs loc $ dsExpr expr
-       where simpWrapper (WpCompose w1 WpHole) = w1
-             simpWrapper (WpCompose WpHole w1) = w1
-             simpWrapper w = w
-#endif
-
 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
@@ -300,7 +280,7 @@ dsExpr (HsCase discrim matches)
 --       This is to avoid silliness in breakpoints
 dsExpr (HsLet binds body)
   = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $ 
-     dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
+     dsLExpr body) `thenDs` \ body' ->
     dsLocalBinds binds body'
 
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
@@ -602,10 +582,10 @@ dsDo      :: [LStmt Id]
 dsDo stmts body result_ty
   = go (map unLoc stmts)
   where
-    go [] = dsAndThenMaybeInsertBreakpoint body
+    go [] = dsLExpr body
     
     go (ExprStmt rhs then_expr _ : stmts)
-      = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+      = do { rhs2 <- dsLExpr rhs
           ; then_expr2 <- dsExpr then_expr
           ; rest <- go stmts
           ; returnDs (mkApps then_expr2 [rhs2, rest]) }
@@ -625,7 +605,7 @@ dsDo stmts body result_ty
           ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                  result_ty (cantFailMatchResult body)
           ; match_code <- handle_failure pat match fail_op
-           ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
+           ; rhs'       <- dsLExpr rhs
           ; bind_op'   <- dsExpr bind_op
           ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
     
@@ -675,7 +655,7 @@ dsMDo tbl stmts body result_ty
           ; dsLocalBinds binds rest }
 
     go (ExprStmt rhs _ rhs_ty : stmts)
-      = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+      = do { rhs2 <- dsLExpr rhs
           ; rest <- go stmts
           ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
     
@@ -688,7 +668,7 @@ dsMDo tbl stmts body result_ty
           ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
           ; match_code <- extractMatchResult match fail_expr
 
-          ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
+          ; rhs'       <- dsLExpr rhs
           ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
                                             rhs', Lam var match_code]) }
     
index 8f24239..31d48b6 100644 (file)
@@ -21,7 +21,6 @@ import Type
 
 import DsMonad
 import DsUtils
-import DsBreakpoint
 import Unique
 import PrelInfo
 import TysWiredIn
@@ -73,8 +72,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty =
               patsBinders  = collectPatsBinders (map (L undefined) pats) 
 
 dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
-  = do rhs' <- maybeInsertBreakpoint rhs rhs_ty
-       matchGuards (map unLoc guards) hs_ctx rhs' rhs_ty
+  = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
 \end{code}
 
 
index 9251a81..ac6a0c0 100644 (file)
@@ -23,7 +23,7 @@ module DsMonad (
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-        bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
+        bindLocalsDs, getLocalBindsDs,
        -- Warnings
        DsWarning, warnDs, failWithDs,
 
@@ -57,7 +57,6 @@ import OccName
 import DynFlags
 import ErrUtils
 import Bag
-import Breakpoints
 import OccName
 
 import Data.IORef
@@ -136,17 +135,14 @@ data DsGblEnv = DsGblEnv {
        ds_mod     :: Module,                   -- For SCC profiling
        ds_unqual  :: PrintUnqualified,
        ds_msgs    :: IORef Messages,           -- Warning messages
-       ds_if_env  :: (IfGblEnv, IfLclEnv),     -- Used for looking up global, 
+       ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global, 
                                                -- possibly-imported things
-        ds_bkptSites :: IORef SiteMap  -- Inserted Breakpoints sites
     }
 
 data DsLclEnv = DsLclEnv {
        ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
        ds_loc     :: SrcSpan,          -- to put in pattern-matching error msgs
-        ds_locals  :: OccEnv Id,        -- For locals in breakpoints
-        ds_mod_name_ref :: Maybe Id     -- The Id used to store the Module name 
-                                        --  used by the breakpoint desugaring 
+        ds_locals  :: OccEnv Id         -- For locals in breakpoints
      }
 
 -- Inside [| |] brackets, the desugarer looks 
@@ -209,12 +205,10 @@ mkDsEnvs mod rdr_env type_env msg_var
                gbl_env = DsGblEnv { ds_mod = mod, 
                                    ds_if_env = (if_genv, if_lenv),
                                    ds_unqual = mkPrintUnqualified rdr_env,
-                                   ds_msgs = msg_var,
-                                    ds_bkptSites = sites_var}
+                                   ds_msgs = msg_var}
                lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
                                    ds_loc = noSrcSpan,
-                                    ds_locals = emptyOccEnv,
-                                    ds_mod_name_ref = Nothing }
+                                    ds_locals = emptyOccEnv }
 
        return (gbl_env, lcl_env)
 
@@ -340,21 +334,10 @@ dsExtendMetaEnv menv thing_inside
 getLocalBindsDs :: DsM [Id]
 getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
 
-getModNameRefDs :: DsM (Maybe Id)
-getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) }
-
-withModNameRefDs :: Id -> DsM a -> DsM a
-withModNameRefDs id thing_inside =
-    updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside
-
 bindLocalsDs :: [Id] -> DsM a -> DsM a
 bindLocalsDs new_ids enclosed_scope = 
     updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
              enclosed_scope
   where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ] 
-
-getBkptSitesDs :: DsM (IORef SiteMap)
-getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }
-
 \end{code}
 
index 455db04..3c56567 100644 (file)
@@ -69,6 +69,8 @@ import SrcLoc
 import Util
 import ListSetOps
 import FastString
+import StaticFlags
+
 import Data.Char
 
 infixl 4 `mkDsApp`, `mkDsApps`
@@ -942,15 +944,22 @@ mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
 mkTickBox ix e = do
        uq <- newUnique         
        mod <- getModuleDs
-       let tick = mkTickBoxOpId uq mod ix
+       let tick | opt_Hpc   = mkTickBoxOpId uq mod ix
+                | otherwise = mkBreakPointOpId uq mod ix
        uq2 <- newUnique        
        let occName = mkVarOcc "tick"
        let name = mkInternalName uq2 occName noSrcLoc   -- use mkSysLocal?
        let var  = Id.mkLocalId name realWorldStatePrimTy
-       return $ Case (Var tick) 
-                    var
-                    ty
-                    [(DEFAULT,[],e)]
+       scrut <- 
+          if opt_Hpc 
+            then return (Var tick)
+            else do
+              locals <- getLocalBindsDs
+              let tickVar = Var tick
+              let tickType = mkFunTys (map idType locals) realWorldStatePrimTy 
+              let scrutApTy = App tickVar (Type tickType)
+              return (mkApps scrutApTy (map Var locals) :: Expr Id)
+       return $ Case scrut var ty [(DEFAULT,[],e)]
   where
      ty = exprType e
 
@@ -966,4 +975,4 @@ mkBinaryTickBox ixT ixF e = do
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)
                        ]
-\end{code}
\ No newline at end of file
+\end{code}
index 28263f9..31cbd25 100644 (file)
@@ -46,7 +46,7 @@ import Data.Bits
 import Data.Int                ( Int64 )
 import Data.Char       ( ord )
 
-import GHC.Base                ( ByteArray# )
+import GHC.Base                ( ByteArray#, MutableByteArray#, RealWorld )
 import GHC.IOBase      ( IO(..) )
 import GHC.Ptr         ( Ptr(..) )
 
@@ -71,13 +71,15 @@ data UnlinkedBCO
        unlinkedBCOInstrs :: ByteArray#,                 -- insns
        unlinkedBCOBitmap :: ByteArray#,                 -- bitmap
         unlinkedBCOLits   :: (SizedSeq BCONPtr),        -- non-ptrs
-        unlinkedBCOPtrs   :: (SizedSeq BCOPtr)                 -- ptrs
+        unlinkedBCOPtrs   :: (SizedSeq BCOPtr)         -- ptrs
    }
 
 data BCOPtr
   = BCOPtrName   Name
   | BCOPtrPrimOp PrimOp
   | BCOPtrBCO    UnlinkedBCO
+  | BCOPtrBreakInfo  BreakInfo
+  | BCOPtrArray (MutableByteArray# RealWorld)
 
 data BCONPtr
   = BCONPtrWord  Word
@@ -158,8 +160,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
             bitmap_arr = mkBitmapArray bsize bitmap
              bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
 
-         let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits 
-                                       final_ptrs
+         let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs 
 
          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
          -- objects, since they might get run too early.  Disable this until
@@ -299,6 +300,11 @@ mkBits findLabel st proto_insns
                RETURN_UBX rep     -> instr1 st (return_ubx rep)
                CCALL off m_addr   -> do (np, st2) <- addr st m_addr
                                         instr3 st2 bci_CCALL off np
+               BRK_FUN array index info -> do 
+                  (p1, st2) <- ptr st  (BCOPtrArray array) 
+                  (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
+                  instr4 st3 bci_BRK_FUN p1 index p2
+               PUSH_LLL  o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
 
        i2s :: Int -> Word16
        i2s = fromIntegral
@@ -448,6 +454,7 @@ instrSize16s instr
         RETURN_UBX{}           -> 1
        CCALL{}                 -> 3
         SWIZZLE{}              -> 3
+        BRK_FUN{}               -> 4 
 
 -- Make lists of host-sized words for literals, so that when the
 -- words are placed in memory at increasing addresses, the
index 72586ab..ca66250 100644 (file)
@@ -49,7 +49,7 @@ import Constants
 
 import Data.List       ( intersperse, sortBy, zip4, zip6, partition )
 import Foreign         ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
-                         withForeignPtr, castFunPtrToPtr )
+                         withForeignPtr, castFunPtrToPtr, nullPtr, plusPtr )
 import Foreign.C
 import Control.Exception       ( throwDyn )
 
@@ -58,21 +58,29 @@ import GHC.Exts             ( Int(..), ByteArray# )
 import Control.Monad   ( when )
 import Data.Char       ( ord, chr )
 
+import UniqSupply
+import BreakArray
+import Data.Maybe
+import Module 
+import IdInfo 
+
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
 
 byteCodeGen :: DynFlags
             -> [CoreBind]
            -> [TyCon]
+            -> ModBreaks 
             -> IO CompiledByteCode
-byteCodeGen dflags binds tycs
+byteCodeGen dflags binds tycs modBreaks 
    = do showPass dflags "ByteCodeGen"
 
         let flatBinds = [ (bndr, freeVars rhs) 
                        | (bndr, rhs) <- flattenBinds binds]
 
-        (BcM_State final_ctr mallocd, proto_bcos)
-           <- runBc (mapM schemeTopBind flatBinds)
+        us <- mkSplitUniqSupply 'y'  
+        (BcM_State _us final_ctr mallocd _, proto_bcos) 
+           <- runBc us modBreaks (mapM schemeTopBind flatBinds)  
 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -98,8 +106,11 @@ coreExprToBCOs dflags expr
       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
           invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
          
-      (BcM_State final_ctr mallocd, proto_bco) 
-         <- runBc (schemeTopBind (invented_id, freeVars expr))
+      -- the uniques are needed to generate fresh variables when we introduce new
+      -- let bindings for ticked expressions
+      us <- mkSplitUniqSupply 'y'
+      (BcM_State _us final_ctr mallocd _ , proto_bco)  
+         <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
 
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
@@ -141,8 +152,7 @@ mkProtoBCO
    -> Bool     -- True <=> is a return point, rather than a function
    -> [BcPtr]
    -> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
-  is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks 
    = ProtoBCO {
        protoBCOName = nm,
        protoBCOInstrs = maybe_with_stack_check,
@@ -199,22 +209,24 @@ argBits (rep : args)
 schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
 
 
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs) 
   | Just data_con <- isDataConWorkId_maybe id,
-    isNullaryRepDataCon data_con
-  =    -- Special case for the worker of a nullary data con.
+    isNullaryRepDataCon data_con = do
+       -- Special case for the worker of a nullary data con.
        -- It'll look like this:        Nil = /\a -> Nil a
        -- If we feed it into schemeR, we'll get 
        --      Nil = Nil
        -- because mkConAppCode treats nullary constructor applications
        -- by just re-using the single top-level definition.  So
        -- for the worker itself, we must allocate it directly.
+    -- ioToBc (putStrLn $ "top level BCO")
     emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
-                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) 
 
   | otherwise
   = schemeR [{- No free variables -}] (id, rhs)
 
+
 -- -----------------------------------------------------------------------------
 -- schemeR
 
@@ -232,7 +244,7 @@ schemeR :: [Id]             -- Free vars of the RHS, ordered as they
                                -- top-level things, which have no free vars.
        -> (Id, AnnExpr Id VarSet)
        -> BcM (ProtoBCO Name)
-schemeR fvs (nm, rhs) 
+schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
@@ -245,11 +257,13 @@ schemeR fvs (nm, rhs)
 -}
    = schemeR_wrk fvs nm rhs (collect [] rhs)
 
+collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
 collect xs (_, AnnNote note e) = collect xs e
 collect xs (_, AnnCast e _)    = collect xs e
 collect xs (_, AnnLam x e)     = collect (if isTyVar x then xs else (x:xs)) e
 collect xs (_, not_lambda)     = (reverse xs, not_lambda)
 
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) 
 schemeR_wrk fvs nm original_body (args, body)
    = let 
         all_args  = reverse args ++ fvs
@@ -267,10 +281,36 @@ schemeR_wrk fvs nm original_body (args, body)
         bitmap_size = length bits
         bitmap = mkBitmap bits
      in do
-     body_code <- schemeE szw_args 0 p_init body
+     body_code <- schemeER_wrk szw_args p_init body   
      emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
                arity bitmap_size bitmap False{-not alts-})
 
+-- introduce break instructions for ticked expressions
+schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk d p rhs
+   | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do 
+        code <- schemeE d 0 p newRhs 
+        arr <- getBreakArray 
+        let idOffSets = getVarOffSets d p tickInfo 
+        let tickNumber = tickInfo_number tickInfo
+        let breakInfo = BreakInfo 
+                        { breakInfo_module = tickInfo_module tickInfo
+                        , breakInfo_number = tickNumber 
+                        , breakInfo_vars = idOffSets
+                        }
+        let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo 
+        return $ breakInstr `consOL` code
+   | otherwise = schemeE d 0 p rhs 
+
+getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)]
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals 
+
+getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int)
+getOffSet d env id 
+   = case lookupBCEnv_maybe env id of
+        Nothing     -> Nothing 
+        Just offset -> Just (id, d - offset)
 
 fvsToEnv :: BCEnv -> VarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
@@ -288,6 +328,18 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- -----------------------------------------------------------------------------
 -- schemeE
 
+data TickInfo 
+   = TickInfo   
+     { tickInfo_number :: Int     -- the (module) unique number of the tick
+     , tickInfo_module :: Module  -- the origin of the ticked expression 
+     , tickInfo_locals :: [Id]    -- the local vars in scope at the ticked expression
+     } 
+
+instance Outputable TickInfo where
+   ppr info = text "TickInfo" <+> 
+              parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
+                      ppr (tickInfo_locals info))
+
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
@@ -382,7 +434,18 @@ schemeE d s p (AnnLet binds (_,body))
      thunk_codes <- sequence compile_binds
      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
-
+-- introduce a let binding for a ticked case expression. This rule *should* only fire when the
+-- expression was not already let-bound (the code gen for let bindings should take care of that). 
+-- Todo: we call exprFreeVars on a deAnnotated expression, this may not be the best way
+-- to calculate the free vars but it seemed like the least intrusive thing to do
+schemeE d s p exp@(AnnCase {})
+   | Just (tickInfo, _exp) <- isTickedExp' exp = do 
+        let fvs = exprFreeVars $ deAnnotate' exp
+        let ty = exprType $ deAnnotate' exp
+        id <- newId ty
+        -- Todo: is emptyVarSet correct on the next line?
+        let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
+        schemeE d s p letExp
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
@@ -396,11 +459,11 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
        -- envt (it won't be bound now) because we never look such things up.
 
    = --trace "automagic mashing of case alts (# VoidArg, a #)" $
-     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
 
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
@@ -409,10 +472,10 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
        -- to
        --      case .... of a { DEFAULT -> ... }
    = --trace "automagic mashing of case alts (# a #)"  $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
 
 schemeE d s p (AnnCase scrut bndr _ alts)
-   = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+   = doCase d s p scrut bndr alts False{-not an unboxed tuple-} 
 
 schemeE d s p (AnnNote note (_, body))
    = schemeE d s p body
@@ -424,6 +487,56 @@ schemeE d s p other
    = pprPanic "ByteCodeGen.schemeE: unhandled case" 
                (pprCoreExpr (deAnnotate' other))
 
+{- 
+   Ticked Expressions
+   ------------------
+  
+   A ticked expression looks like this:
+
+      case tick<n> var1 ... varN of DEFAULT -> e
+
+   (*) <n> is the number of the tick, which is unique within a module
+   (*) var1 ... varN are the local variables in scope at the tick site
+
+   If we find a ticked expression we return:
+
+      Just ((n, [var1 ... varN]), e)
+
+  otherwise we return Nothing.
+
+  The idea is that the "case tick<n> ..." is really just an annotation on 
+  the code. When we find such a thing, we pull out the useful information,
+  and then compile the code as if it was just the expression "e".
+
+-}
+
+isTickedExp :: AnnExpr Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp (annot, expr) = isTickedExp' expr 
+
+isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp' (AnnCase scrut _bndr _type alts)
+   | Just tickInfo <- isTickedScrut scrut,
+     [(DEFAULT, _bndr, rhs)] <- alts 
+     = Just (tickInfo, rhs)
+   where
+   isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo 
+   isTickedScrut expr
+      | Var id <- f,
+        Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
+           = Just $ TickInfo { tickInfo_number = tickNumber
+                             , tickInfo_module = modName
+                             , tickInfo_locals = idsOfArgs args
+                             }
+      | otherwise = Nothing
+      where
+      (f, args) = collectArgs $ deAnnotate expr
+      idsOfArgs :: [Expr Id] -> [Id]
+      idsOfArgs = catMaybes . map exprId 
+      exprId :: Expr Id -> Maybe Id
+      exprId (Var id) = Just id
+      exprId other    = Nothing
+
+isTickedExp' other = Nothing
 
 -- Compile code to do a tail call.  Specifically, push the fn,
 -- slide the on-stack app back down to the sequel depth,
@@ -640,8 +753,7 @@ doCase  :: Int -> Sequel -> BCEnv
        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
        -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
        -> BcM BCInstrList
-doCase d s p (_,scrut)
- bndr alts is_unboxed_tuple
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple 
   = let
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
@@ -670,9 +782,10 @@ doCase d s p (_,scrut)
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 
         -- given an alt, return a discr and code for it.
-       codeALt alt@(DEFAULT, _, (_,rhs))
+       codeAlt alt@(DEFAULT, _, (_,rhs))
           = do rhs_code <- schemeE d_alts s p_alts rhs
                return (NoDiscr, rhs_code)
+
         codeAlt alt@(discr, bndrs, (_,rhs))
           -- primitive or nullary constructor alt: no need to UNPACK
           | null real_bndrs = do
@@ -696,7 +809,6 @@ doCase d s p (_,scrut)
           where
             real_bndrs = filter (not.isTyVar) bndrs
 
-
         my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, binds, rhs) 
            | isUnboxedTupleCon dc
@@ -745,6 +857,7 @@ doCase d s p (_,scrut)
      in do
      alt_stuff <- mapM codeAlt alts
      alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
      let 
          alt_bco_name = getName bndr
          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
@@ -1315,9 +1428,12 @@ type BcPtr = Either ItblPtr (Ptr ())
 
 data BcM_State 
    = BcM_State { 
+        uniqSupply :: UniqSupply,       -- for generating fresh variable names
        nextlabel :: Int,               -- for generating local labels
-       malloced  :: [BcPtr] }          -- thunks malloced for current BCO
+       malloced  :: [BcPtr]          -- thunks malloced for current BCO
                                        -- Should be free()d when it is GCd
+        breakArray :: BreakArray        -- array of breakpoint flags 
+        }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
 
@@ -1326,8 +1442,11 @@ ioToBc io = BcM $ \st -> do
   x <- io 
   return (st, x)
 
-runBc :: BcM r -> IO (BcM_State, r)
-runBc (BcM m) = m (BcM_State 0 []) 
+runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
+runBc us modBreaks (BcM m) 
+   = m (BcM_State us 0 [] breakArray)   
+   where
+   breakArray = modBreaks_array modBreaks
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -1370,4 +1489,18 @@ getLabelsBc :: Int -> BcM [Int]
 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, breakArray st)
+
+newUnique :: BcM Unique
+newUnique = BcM $
+   \st -> case splitUniqSupply (uniqSupply st) of
+             (us1, us2) -> let newState = st { uniqSupply = us2 } 
+                           in  return (newState, uniqFromSupply us1) 
+
+newId :: Type -> BcM Id
+newId ty = do 
+    uniq <- newUnique
+    return $ mkSysLocal FSLIT("ticked") uniq ty
 \end{code}
index 5239139..3f57d18 100644 (file)
@@ -5,7 +5,7 @@ ByteCodeInstrs: Bytecode instruction definitions
 
 \begin{code}
 module ByteCodeInstr ( 
-       BCInstr(..), ProtoBCO(..), bciStackUse
+       BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) 
   ) where
 
 #include "HsVersions.h"
@@ -26,6 +26,10 @@ import SMRep
 
 import GHC.Ptr
 
+import Module (Module)
+import GHC.Prim
+
+
 -- ----------------------------------------------------------------------------
 -- Bytecode instructions
 
@@ -129,6 +133,22 @@ data BCInstr
    | RETURN            -- return a lifted value
    | RETURN_UBX CgRep -- return an unlifted value, here's its rep
 
+   -- Breakpoints 
+   | BRK_FUN          (MutableByteArray# RealWorld) Int BreakInfo
+
+data BreakInfo 
+   = BreakInfo
+   { breakInfo_module :: Module
+   , breakInfo_number :: Int
+   , breakInfo_vars   :: [(Id,Int)]
+   }
+
+instance Outputable BreakInfo where
+   ppr info = text "BreakInfo" <+>
+              parens (ppr (breakInfo_module info) <+>
+                      ppr (breakInfo_number info) <+>
+                      ppr (breakInfo_vars info))
+
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions
 
@@ -196,6 +216,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) = text "BRK_FUN" <+> text "<array>" <+> int index <+> ppr info 
 
 -- -----------------------------------------------------------------------------
 -- The stack use, in words, of each bytecode insn.  These _must_ be
@@ -251,6 +272,7 @@ bciStackUse RETURN{}                  = 0
 bciStackUse RETURN_UBX{}         = 1
 bciStackUse CCALL{}              = 0
 bciStackUse SWIZZLE{}            = 0
+bciStackUse BRK_FUN{}            = 0
 
 -- These insns actually reduce stack use, but we need the high-tide level,
 -- so can't use this info.  Not that it matters much.
index 2973c03..9b2dac0 100644 (file)
@@ -22,6 +22,7 @@ import Constants      ( mIN_PAYLOAD_SIZE, wORD_SIZE )
 import CgHeapery       ( mkVirtHeapOffsets )
 import FastString      ( FastString(..) )
 import Util             ( lengthIs, listLengthCmp )
+import Outputable
 
 import Foreign
 import Foreign.C
@@ -32,7 +33,8 @@ import GHC.Exts               ( Int(I#), addr2Int# )
 import GHC.Ptr         ( Ptr(..) )
 import GHC.Prim
 
-import Outputable
+import Debug.Trace
+import Text.Printf
 \end{code}
 
 %************************************************************************
@@ -48,9 +50,12 @@ itblCode :: ItblPtr -> Ptr ()
 itblCode (ItblPtr ptr)
    = (castPtr ptr)
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-                 `plusPtr` (3 * wORD_SIZE)
+                 `plusPtr` conInfoTableSizeB
 #endif
 
+-- XXX bogus
+conInfoTableSizeB = 3 * wORD_SIZE
+
 type ItblEnv = NameEnv (Name, ItblPtr)
        -- We need the Name in the range so we know which
        -- elements to filter out when unloading a module
@@ -290,7 +295,7 @@ instance Storable StgConInfoTable where
               StgConInfoTable 
               { 
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-                conDesc   = castPtr $ ptr `plusPtr` wORD_SIZE `plusPtr` desc
+                conDesc   = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
 #else
                 conDesc   = desc
 #endif
@@ -299,7 +304,7 @@ instance Storable StgConInfoTable where
    poke ptr itbl 
       = runState (castPtr ptr) $ do
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-           store (conDesc itbl `minusPtr` (ptr `plusPtr` wORD_SIZE))
+           store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB))
 #endif
            store (infoTable itbl)
 #ifndef GHCI_TABLES_NEXT_TO_CODE
index 9988325..7304d02 100644 (file)
@@ -27,7 +27,6 @@ import Module
 import PackageConfig
 import FastString
 import Panic
-import Breakpoints
 
 #ifdef DEBUG
 import Outputable
@@ -47,7 +46,7 @@ import GHC.Exts
 import GHC.Arr         ( Array(..) )
 import GHC.IOBase      ( IO(..) )
 import GHC.Ptr         ( Ptr(..), castPtr )
-import GHC.Base                ( writeArray#, RealWorld, Int(..) )
+import GHC.Base                ( writeArray#, RealWorld, Int(..), Word# )  
 \end{code}
 
 
@@ -143,6 +142,10 @@ mkPtrsArray ie ce n_ptrs ptrs = do
     fill (BCOPtrBCO ul_bco) i = do
        BCO bco# <- linkBCO' ie ce ul_bco
        writeArrayBCO marr i bco#
+    fill (BCOPtrBreakInfo brkInfo) i =                    
+        unsafeWrite marr i (unsafeCoerce# brkInfo)
+    fill (BCOPtrArray brkArray) i =                    
+        unsafeWrite marr i (unsafeCoerce# brkArray)
   zipWithM fill ptrs [0..]
   unsafeFreeze marr
 
@@ -163,10 +166,16 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
   (# s#, () #) }
 
+{-
+writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
+writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
+  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+  (# s#, () #) }
+-}
+
 data BCO = BCO BCO#
 
-newBCO :: ByteArray# -> ByteArray# -> Array# a
-        -> Int# -> ByteArray# -> IO BCO
+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 
                  (# s1, bco #) -> (# s1, BCO bco #)
@@ -201,8 +210,6 @@ lookupName :: ClosureEnv -> Name -> IO HValue
 lookupName ce nm
    = case lookupNameEnv ce nm of
         Just (_,aa) -> return aa
-        Nothing | Just bk <- lookupBogusBreakpointVal nm
-           -> return bk
         Nothing 
            -> ASSERT2(isExternalName nm, ppr nm)
              do let sym_to_find = nameToCLabel nm "closure"
index a43d4fd..f0f8973 100644 (file)
@@ -6,10 +6,9 @@
 --
 -----------------------------------------------------------------------------
 
-module Debugger where
+module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
 
 import Linker
-import Breakpoints
 import RtClosureInspect
 
 import PrelNames
@@ -22,8 +21,6 @@ import VarEnv
 import Name 
 import NameEnv
 import RdrName
-import Module
-import Finder
 import UniqSupply
 import Type
 import TyCon
@@ -31,23 +28,15 @@ import DataCon
 import TcGadt
 import GHC
 import GhciMonad
-import PackageConfig
 
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
-import ErrUtils
 import FastString
 import SrcLoc
-import Util
-import Maybes
 
 import Control.Exception
 import Control.Monad
-import qualified Data.Map as Map
-import Data.Array.Unboxed
-import Data.Array.Base
 import Data.List
-import Data.Typeable             ( Typeable )
 import Data.Maybe
 import Data.IORef
 
@@ -300,288 +289,3 @@ stripUnknowns names id = setIdType id . fst . go names . idType
            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
            kind2 = mkArrowKind kind1 liftedTypeKind
            kind3 = mkArrowKind kind2 liftedTypeKind
-
------------------------------
--- | The :breakpoint command
------------------------------
-bkptOptions :: String -> GHCi Bool
-bkptOptions "continue" = -- We want to quit if in an inferior session
-                         liftM not isTopLevel 
-bkptOptions "stop" = do
-  inside_break <- liftM not isTopLevel
-  when inside_break $ throwDyn StopChildSession 
-  return False
-
-bkptOptions cmd = do 
-  dflags <- getDynFlags
-  bt     <- getBkptTable
-  sess   <- getSession
-  bkptOptions' sess (words cmd) bt
-  return False
-   where
-    bkptOptions' _ ["list"] bt = do 
-      let msgs = [ ppr mod <+> colon <+> ppr coords 
-                   | (mod,site) <- btList bt
-                   , let coords = getSiteCoords bt mod site]
-          num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
-      msg <- showForUser$ if null num_msgs 
-                            then text "There are no enabled breakpoints"
-                            else vcat num_msgs
-      io$ putStrLn msg
-
-    bkptOptions' s ("add":cmds) bt 
-      | [line]         <- cmds
-      , [(lineNum,[])] <- reads line
-      = do (toplevel,_) <- io$ GHC.getContext s
-           case toplevel of
-             (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
-             [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"
-
-      | [mod_name,line]<- cmds
-      , [(lineNum,[])] <- reads line
-      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
-         handleAdd (\mod->addBkptByLine mod lineNum)
-
-      | [mod_name,line,col] <- cmds
-      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
-         handleAdd (\mod->addBkptByCoord mod (read line, read col))
-
-      | otherwise = throwDyn $ CmdLineError $ 
-                       "syntax: :breakpoint add Module line [col]"
-       where 
-         handleAdd f mod = 
-           either 
-             (handleBkptEx s mod)
-             (\(newTable, site) -> do
-               setBkptTable newTable
-               let (x,y) = getSiteCoords newTable mod site
-               io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod) 
-                    ++ ':' : show x  ++ ':' : show y)))
-             (f mod bt) 
-
-    bkptOptions' s ("del":cmds) bt 
-      | [i']     <- cmds 
-      , [(i,[])] <- reads i'
-      , bkpts    <- btList bt
-      = if i > length bkpts
-           then throwDyn $ CmdLineError 
-              "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
-           else 
-             let (mod, site) = bkpts !! (i-1)
-             in handleDel mod $ delBkptBySite mod site
-
-      | [fn,line]      <- cmds 
-      , [(lineNum,[])] <- reads line
-      , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
-      = handleDel mod $  delBkptByLine mod lineNum
-
-      | [fn,line,col]  <- cmds 
-      , [(lineNum,[])] <- reads line
-      , [(colNum,[])]  <- reads col
-      , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
-      = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
-        
-      | otherwise = throwDyn $ CmdLineError $ 
-             "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
-
-       where delMsg = "Breakpoint deleted"
-             handleDel mod f = either (handleBkptEx s mod)
-                                      (\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
-                                      (f bt)
-                                      
-    bkptOptions' _ _ _ = throwDyn $ CmdLineError $ 
-                         "syntax: :breakpoint (list|continue|stop|add|del)"
-
--- Error messages
---    handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
-    handleBkptEx s m NotHandled  = io$ do
-       isInterpreted <- findModSummary m >>= isModuleInterpreted s
-       if isInterpreted
-        then error$ "Module " ++ showSDoc (ppr m) ++  " was not loaded under debugging mode.\n" 
-                 ++ "Enable debugging mode with -fdebugging (and reload your module)"
-        else error$ "Module " ++ showSDoc (ppr m) ++  " was loaded in compiled (.o) mode.\n" 
-                 ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
-         where findModSummary m = do 
-                 mod_graph <- getModuleGraph s 
-                 return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
-    handleBkptEx _ _ e = error (show e)
-
--------------------------
--- Breakpoint Tables
--------------------------
-
-data BkptTable a  = BkptTable { 
-                           -- | An array of breaks, indexed by site number
-     breakpoints :: Map.Map a (UArray Int Bool)  
-                           -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
-   , sites       :: Map.Map a [[(SiteNumber, Int)]] 
-   }
-                  deriving Show
-
-sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]] 
-sitesOf bt fn = Map.lookup fn (sites bt)
-bkptsOf bt fn = Map.lookup fn (breakpoints bt)
-
-
-data BkptError =
-                    NotHandled  -- Trying to manipulate a element not handled by this BkptTable 
-                  | NoBkptFound
-                  | NotNeeded   -- Used when a breakpoint was already enabled
-  deriving Typeable
-
-instance Show BkptError where
-  show NoBkptFound = "No suitable breakpoint site found"
-  show NotNeeded  = "Nothing to do"
-  show NotHandled  = "BkptTable: Element not controlled by this table"
-
-emptyBkptTable :: Ord a => BkptTable a
-addModule      :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
--- | Lines start at index 1
-addBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
-addBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
-delBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> Either BkptError (BkptTable a)
-delBkptBySite  :: Ord a => a -> SiteNumber -> BkptTable a -> Either BkptError (BkptTable a)
-delBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> Either BkptError (BkptTable a)
-
-isBkptEnabled  :: Ord a => BkptTable a -> BkptLocation a -> Bool
-btElems        :: Ord a => BkptTable a -> [(a, [SiteNumber])]
-btList         :: Ord a => BkptTable a -> [BkptLocation a]
-sitesList      :: Ord a => BkptTable a -> [(a, [Coord])]
-getSiteCoords  :: Ord a => BkptTable a -> a -> SiteNumber -> Coord
-
-emptyBkptTable = BkptTable Map.empty Map.empty
-
-addBkptByLine a i bt
-   | Just lines    <- sitesOf bt a
-   , Just bkptsArr <- bkptsOf bt a
-   , i < length lines
-   = case [line | line <- drop i lines, not (null line)] of 
-       ((x:_):_) -> let (siteNum,col) = x
-                        wasAlreadyOn  = bkptsArr ! siteNum
-                        newArr        = bkptsArr // [(siteNum, True)]
-                        newTable      = Map.insert a newArr (breakpoints bt)
-        in if wasAlreadyOn 
-            then Left NotNeeded
-            else Right (bt{breakpoints=newTable}, siteNum)
-       otherwise -> Left NoBkptFound
-
-   | Just sites    <- sitesOf bt a
-   = Left NoBkptFound
-   | otherwise     = Left NotHandled  
-
-addBkptByCoord a (r,c) bt 
-   | Just lines    <- sitesOf bt a
-   , Just bkptsArr <- bkptsOf bt a
-   , r < length lines
-       = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of 
-       []    -> Left NoBkptFound
-       (x:_) -> let (siteNum, col) = x
-                    wasAlreadyOn  = bkptsArr ! siteNum
-                    newArr        = bkptsArr // [(siteNum, True)]
-                    newTable      = Map.insert a newArr (breakpoints bt)
-        in if wasAlreadyOn 
-           then Left NotNeeded
-           else Right (bt{breakpoints=newTable}, siteNum)
-
-   | Just sites    <- sitesOf bt a
-   = Left NoBkptFound
-   | otherwise     = Left NotHandled  
-
-delBkptBySite a i bt 
-   | Just bkptsArr <- bkptsOf bt a
-   , not (inRange (bounds bkptsArr) i)
-   = Left NoBkptFound
-
-   | Just bkptsArr <- bkptsOf bt a
-   , bkptsArr ! i     -- Check that there was a enabled bkpt here 
-   , newArr        <- bkptsArr // [(i,False)] 
-   , newTable      <- Map.insert a newArr (breakpoints bt)
-   = Right bt {breakpoints=newTable}
-
-   | Just sites    <- sitesOf bt a
-   = Left NotNeeded
-
-   | otherwise = Left NotHandled
-
-delBkptByLine a l bt 
-   | Just sites    <- sitesOf bt a
-   , (site:_)      <- [s | (s,c') <- sites !! l]
-   = delBkptBySite a site bt
-
-   | Just sites    <- sitesOf bt a
-   = Left NoBkptFound
-
-   | otherwise = Left NotHandled
-
-delBkptByCoord a (r,c) bt 
-   | Just sites    <- sitesOf bt a
-   , (site:_)      <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
-   = delBkptBySite a site bt
-
-   | Just sites    <- sitesOf bt a
-   = Left NoBkptFound
-
-   | otherwise = Left NotHandled
-
-btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
-             | (a, siteArr) <- Map.assocs (breakpoints bt) ]
-
-btList bt =  [(a,site) | (a, sites) <- btElems bt, site <- sites] 
-
-sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
-    where sitesCoords sitesCols = 
-              [ (row,col) 
-                | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ] 
-
-getSiteCoords bt a site 
-   | Just rows <- sitesOf bt a
-   = head [ (r,c) | (r,row) <- zip [0..] rows
-                  , (s,c)   <- row
-                  , s == site ]
-
--- addModule is dumb and inefficient, but it does the job
-addModule a [] bt = bt {sites = Map.insert a [] (sites bt)}
-addModule a siteCoords bt 
-   | nrows        <- maximum$ [i | (_,(i,j)) <- siteCoords ]
-   , sitesByRow   <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] 
-                       | i <- [0..nrows] ]
-   , nsites       <- length siteCoords
-   , initialBkpts <- listArray (0, nsites+1) (repeat False) 
-   = bt{ sites       = Map.insert a sitesByRow (sites bt) 
-       , breakpoints = Map.insert a initialBkpts (breakpoints bt) }
-
--- This MUST be fast
-isBkptEnabled bt site | bt `seq` site `seq` False = undefined
-isBkptEnabled bt (a,site) 
-   | Just bkpts <- bkptsOf bt a 
-   = ASSERT (inRange (bounds bkpts) site) 
-     unsafeAt bkpts site
-
------------------
--- Other stuff
------------------
-refreshBkptTable :: Session -> BkptTable Module -> [ModSummary] -> IO (BkptTable Module)
-refreshBkptTable sess = foldM updIfDebugging
-  where 
-   updIfDebugging bt ms = do
-      isDebugging <- isDebuggingM ms
-      if isDebugging 
-           then addModuleGHC sess bt (GHC.ms_mod ms)
-           else return bt
-   addModuleGHC sess bt mod = do
-      Just mod_info <- GHC.getModuleInfo sess mod
-      dflags <- GHC.getSessionDynFlags sess
-      let sites = GHC.modInfoBkptSites mod_info
-      debugTraceMsg dflags 2 
-                (ppr mod <> text ": inserted " <> int (length sites) <>
-                 text " breakpoints")
-      return$ addModule mod sites bt
-#if defined(GHCI) && defined(DEBUGGER)
-   isDebuggingM ms = isModuleInterpreted sess ms >>= \isInterpreted -> 
-                     return (Opt_Debugging `elem` dflags && 
-                             target == HscInterpreted && isInterpreted)
-       where dflags = flags     (GHC.ms_hspp_opts ms)
-             target = hscTarget (GHC.ms_hspp_opts ms)
-#else
-   isDebuggingM _ = return False
-#endif
diff --git a/compiler/ghci/Debugger.hs-boot b/compiler/ghci/Debugger.hs-boot
deleted file mode 100644 (file)
index d310308..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-module Debugger where
-import Breakpoints
-import qualified Data.Map as Map
-import Data.Array.Unboxed
-
-
-data BkptTable a  = BkptTable { 
-                           -- | An array of breaks, indexed by site number
-     breakpoints :: Map.Map a (UArray Int Bool)  
-                           -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
-   , sites       :: Map.Map a [[(SiteNumber, Int)]] 
-   }
index eaea844..3cab56b 100644 (file)
@@ -11,12 +11,12 @@ module GhciMonad where
 #include "HsVersions.h"
 
 import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
 import Outputable
 import Panic hiding (showException)
 import Util
 import DynFlags
+import HscTypes
+import SrcLoc
 
 import Numeric
 import Control.Exception as Exception
@@ -43,8 +43,9 @@ data GHCiState = GHCiState
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: GHC.Module,
-        bkptTable      :: IORef (BkptTable GHC.Module),
-       topLevel       :: Bool
+       topLevel       :: Bool,
+        resume         :: [IO GHC.RunResult],
+        breaks         :: !ActiveBreakPoints
      }
 
 data GHCiOption 
@@ -53,6 +54,73 @@ data GHCiOption
        | RevertCAFs            -- revert CAFs after every evaluation
        deriving Eq
 
+data ActiveBreakPoints
+   = ActiveBreakPoints
+   { breakCounter   :: !Int
+   , breakLocations :: ![(Int, BreakLocation)]  -- break location uniquely numbered 
+   }
+
+instance Outputable ActiveBreakPoints where
+   ppr activeBrks = prettyLocations $ breakLocations activeBrks 
+
+emptyActiveBreakPoints :: ActiveBreakPoints
+emptyActiveBreakPoints 
+   = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
+
+data BreakLocation
+   = BreakLocation
+   { breakModule :: !GHC.Module
+   , breakLoc    :: !SrcSpan
+   , breakTick   :: {-# UNPACK #-} !Int
+   } 
+   deriving Eq
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations []   = text "No active breakpoints." 
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+
+getActiveBreakPoints :: GHCi ActiveBreakPoints
+getActiveBreakPoints = liftM breaks getGHCiState 
+
+-- don't reset the counter back to zero?
+clearActiveBreakPoints :: GHCi ()
+clearActiveBreakPoints = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       newActiveBreaks = oldActiveBreaks { breakLocations = [] } 
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       oldLocations    = breakLocations oldActiveBreaks
+       newLocations    = filter (\loc -> fst loc /= identity) oldLocations
+       newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }   
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st 
+   let oldLocations    = breakLocations oldActiveBreaks
+   -- don't store the same break point twice
+   case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+     (nm:_) -> return (True, nm)
+     [] -> do
+      let oldCounter = breakCounter oldActiveBreaks 
+          newCounter = oldCounter + 1
+          newActiveBreaks = 
+             oldActiveBreaks 
+             { breakCounter   = newCounter 
+             , breakLocations = (oldCounter, brkLoc) : oldLocations 
+             }
+      setGHCiState $ st { breaks = newActiveBreaks }
+      return (False, oldCounter)
+
 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 
 startGHCi :: GHCi a -> GHCiState -> IO a
@@ -107,20 +175,25 @@ io m = GHCi { unGHCi = \s -> m >>= return }
 isTopLevel :: GHCi Bool
 isTopLevel = getGHCiState >>= return . topLevel
 
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
-                  io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do 
-    table_ref <- getGHCiState >>= return . bkptTable
-    io$ writeIORef table_ref new_table
-                  
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do 
-    bt <- getBkptTable
-    new_bt <- io . evaluate$ f bt 
-    setBkptTable new_bt
+getResume :: GHCi (Maybe (IO GHC.RunResult))
+getResume = do
+   st <- getGHCiState
+   case (resume st) of
+      []    -> return Nothing
+      (x:_) -> return $ Just x
+
+popResume :: GHCi ()
+popResume = do
+   st <- getGHCiState 
+   case (resume st) of
+      []     -> return () 
+      (_:xs) -> setGHCiState $ st { resume = xs } 
+         
+pushResume :: IO GHC.RunResult -> GHCi ()
+pushResume resumeAction = do
+   st <- getGHCiState
+   let oldResume = resume st
+   setGHCiState $ st { resume = resumeAction : oldResume }
 
 showForUser :: SDoc -> GHCi String
 showForUser doc = do
@@ -129,17 +202,6 @@ showForUser doc = do
   return $! showSDocForUser unqual doc
 
 -- --------------------------------------------------------------------------
--- Inferior Sessions Exceptions (used by the debugger)
-
-data InfSessionException = 
-             StopChildSession -- A child session requests to be stopped
-           | StopParentSession -- A child session requests to be stopped 
-                               -- AND that the parent session quits after that
-           | ChildSessionStopped String  -- A child session has stopped
-  deriving Typeable
-
-
--- --------------------------------------------------------------------------
 -- timing & statistics
 
 timeIt :: GHCi a -> GHCi a
index cea3b29..b794436 100644 (file)
@@ -41,8 +41,7 @@ import Linker
 import Util
 
 -- The debugger
-import Breakpoints
-import Debugger hiding  ( addModule )
+import Debugger 
 import HscTypes
 import Id
 import Var       ( globaliseId )
@@ -74,9 +73,7 @@ import System.Console.Readline as Readline
 import Control.Exception as Exception
 -- import Control.Concurrent
 
-import Numeric
 import Data.List
-import Data.Int                ( Int64 )
 import Data.Maybe      ( isJust, isNothing, fromMaybe, catMaybes )
 import System.Cmd
 import System.Environment
@@ -86,16 +83,23 @@ import System.IO
 import System.IO.Error as IO
 import Data.Char
 import Data.Dynamic
+import Data.Array
 import Control.Monad as Monad
-import Foreign.StablePtr       ( newStablePtr )
+import Foreign.StablePtr       ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )
 
 import GHC.Exts                ( unsafeCoerce# )
-import GHC.IOBase      ( IOErrorType(InvalidArgument) )
+import GHC.IOBase      ( IOErrorType(InvalidArgument), IO(IO) )
 
-import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef      ( IORef, readIORef, writeIORef )
 
 import System.Posix.Internals ( setNonBlockingFD )
 
+-- these are needed by the new ghci debugger
+import ByteCodeLink (HValue)
+import ByteCodeInstr (BreakInfo (..))
+import BreakArray
+import TickTree 
+
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg =
@@ -112,41 +116,37 @@ GLOBAL_VAR(commands, builtin_commands, [Command])
 
 builtin_commands :: [Command]
 builtin_commands = [
+       -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+  ("?",                keepGoing help,                 False, completeNone),
   ("add",      tlC$ keepGoingPaths addModule,  False, completeFilename),
+  ("break",     breakCmd, False, completeNone),   
   ("browse",    keepGoing browseCmd,           False, completeModule),
-#ifdef DEBUGGER
-        -- I think that :c should mean :continue rather than :cd, makes more sense
-        --  (pepe 01.11.07)
-  ("continue",  const(bkptOptions "continue"),  False, completeNone),
-#endif
   ("cd",       tlC$ keepGoing changeDirectory, False, completeFilename),
+  ("check",    keepGoing checkModule,          False, completeHomeModule),
+  ("continue",  continueCmd, False, completeNone),
+  ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("def",      keepGoing defineMacro,          False, completeIdentifier),
+  ("delete",    deleteCmd, False, completeNone),   
   ("e",        keepGoing editFile,             False, completeFilename),
-       -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("edit",     keepGoing editFile,             False, completeFilename),
+  ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
+  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
   ("help",     keepGoing help,                 False, completeNone),
-  ("?",                keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
+  ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("load",     tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     tlC$ keepGoing runMain,         False, completeIdentifier),
+  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("quit",     quit,                           False, completeNone),
   ("reload",   tlC$ keepGoing reloadModule,    False, completeNone),
-  ("check",    keepGoing checkModule,          False, completeHomeModule),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
-  ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
-  ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
-  ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
-#if defined(DEBUGGER)
-  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
-  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
-  ("breakpoint",bkptOptions,                    False, completeBkpt),
-#endif
-  ("kind",     keepGoing kindOfType,           False, completeIdentifier),
-  ("unset",    keepGoing unsetOptions,         True,  completeSetOptions),
+  ("step",      stepCmd, False, completeNone), 
+  ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
-  ("quit",     quit,                           False, completeNone)
+  ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ]
 
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
@@ -171,10 +171,8 @@ helpText =
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
- "   :breakpoint <option>        commands for the GHCi debugger\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
- "   :continue                   equivalent to ':breakpoint continue'\n"  ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
@@ -212,14 +210,8 @@ helpText =
  "    +t            print type after evaluation\n" ++
  "    -<flags>      most GHC command line flags can also be set here\n" ++
  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
- "\n" ++
- " Options for ':breakpoint':\n" ++
- "   list                                     list the current breakpoints\n" ++
- "   add [Module] line [col]                    add a new breakpoint\n" ++
- "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
- "   continue                                 continue execution\n"  ++
- "   stop                   Stop a computation and return to the top level\n" ++
- "   step [count]           Step by step execution (DISABLED)\n"
+ "\n" 
+-- Todo: add help for breakpoint commands here
 
 findEditor = do
   getEnv "EDITOR" 
@@ -277,8 +269,6 @@ interactiveUI session srcs maybe_expr = do
    Readline.setCompleterWordBreakCharacters word_break_chars
 #endif
 
-   bkptTable <- newIORef emptyBkptTable
-   GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
    default_editor <- findEditor
 
    startGHCi (runGHCi srcs maybe_expr)
@@ -289,8 +279,9 @@ interactiveUI session srcs maybe_expr = do
                   session = session,
                   options = [],
                    prelude = prel_mod,
-                   bkptTable = bkptTable,
-                  topLevel  = True
+                  topLevel = True,
+                   resume = [],
+                   breaks = emptyActiveBreakPoints
                  }
 
 #ifdef USE_READLINE
@@ -530,10 +521,84 @@ runStmt stmt
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
                     GHC.runStmt session stmt
-      case result of
-       GHC.RunFailed      -> return Nothing
-       GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
-       GHC.RunOk names    -> return (Just names)
+      switchOnRunResult result
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just names
+switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do  -- Todo: we don't use threadID, perhaps delete?
+   session <- getSession
+   Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) 
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let ticks      = modBreaks_ticks modBreaks
+   io $ displayBreakInfo session ticks info
+   io $ extendEnvironment session apStack (breakInfo_vars info) 
+   pushResume resume
+   return Nothing
+
+displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
+displayBreakInfo session ticks info = do
+   unqual <- GHC.getPrintUnqual session
+   let location = ticks ! breakInfo_number info
+   printForUser stdout unqual $
+      ptext SLIT("Stopped at") <+> ppr location $$ localsMsg 
+   where
+   vars = map fst $ breakInfo_vars info 
+   localsMsg = if null vars
+                  then text "No locals in scope."
+                  else text "Locals:" <+> (pprWithCommas showId vars)
+   showId id = ppr (idName id) <+> dcolon <+> ppr (idType id) 
+
+-- Todo: turn this into a primop, and provide special version(s) for unboxed things
+foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+   -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+   apSptr <- newStablePtr apStack
+   resultSptr <- getApStackVal apSptr (stackDepth - 1)
+   result <- deRefStablePtr resultSptr
+   freeStablePtr apSptr
+   freeStablePtr resultSptr 
+   return (identifier, unsafeCoerce# result)
+
+extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
+extendEnvironment s@(Session ref) apStack idsOffsets = do
+   idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
+   let (ids, hValues) = unzip idsVals 
+   let names = map idName ids
+   let global_ids = map globaliseAndTidy ids
+   typed_ids  <- mapM instantiateIdType global_ids
+   hsc_env <- readIORef ref
+   let ictxt = hsc_IC hsc_env
+       rn_env   = ic_rn_local_env ictxt
+       type_env = ic_type_env ictxt
+       bound_names = map idName typed_ids
+       new_rn_env  = extendLocalRdrEnv rn_env bound_names
+       -- Remove any shadowed bindings from the type_env;
+       -- they are inaccessible but might, I suppose, cause 
+       -- a space leak if we leave them there
+       shadowed = [ n | name <- bound_names,
+                    let rdr_name = mkRdrUnqual (nameOccName name),
+                    Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+       filtered_type_env = delListFromNameEnv type_env shadowed
+       new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
+       new_ic = ictxt { ic_rn_local_env = new_rn_env, 
+                       ic_type_env     = new_type_env }
+   writeIORef ref (hsc_env { hsc_IC = new_ic })
+   extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
+   where
+   globaliseAndTidy :: Id -> Id
+   globaliseAndTidy id
+      = let tidied_type = tidyTopType$ idType id
+        in setIdType (globaliseId VanillaGlobal id) tidied_type
+
+   -- | Instantiate the tyVars with GHC.Base.Unknown
+   instantiateIdType :: Id -> IO Id
+   instantiateIdType id = do
+      instantiatedType <- instantiateTyVarsToUnknown s (idType id)
+      return$ setIdType id instantiatedType
 
 -- possibly print the type and revert CAFs after evaluating an expression
 finishEvalExpr mb_names
@@ -779,10 +844,6 @@ afterLoad ok session = do
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
-  do 
-     bt  <- getBkptTable
-     bt' <- io$ refreshBkptTable session bt graph'
-     setBkptTable bt'
   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do
@@ -851,13 +912,9 @@ kindOfType str
          Nothing    -> return ()
          Just ty    -> do tystr <- showForUser (ppr ty)
                           io (putStrLn (str ++ " :: " ++ tystr))
-
-quit :: String -> GHCi Bool
-quit _ =  do in_inferior_session <- liftM not isTopLevel 
-             if in_inferior_session 
-               then throwDyn StopParentSession
-               else return True
           
+quit :: String -> GHCi Bool
+quit _ = return True
 
 shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)
@@ -1219,7 +1276,7 @@ showCmd str =
        ["modules" ] -> showModules
        ["bindings"] -> showBindings
        ["linker"]   -> io showLinkerState
-        ["breakpoints"] -> showBkptTable
+        ["breaks"] -> showBkptTable
        _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 
 showModules = do
@@ -1252,12 +1309,10 @@ cleanType ty = do
 
 showBkptTable :: GHCi ()
 showBkptTable = do
-  bt     <- getBkptTable
-  msg <- showForUser . vcat $ 
-             [ ppr mod <> colon <+> fcat 
-                       [ parens(int row <> comma <> int col) | (row,col) <- sites]
-               | (mod, sites) <-  sitesList bt ]
-  io (putStrLn msg)
+   activeBreaks <- getActiveBreakPoints 
+   str <- showForUser $ ppr activeBreaks 
+   io $ putStrLn str
+
 -- -----------------------------------------------------------------------------
 -- Completion
 
@@ -1329,12 +1384,6 @@ completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
     where options = "args":"prog":allFlags
 
-completeBkpt = unionComplete completeModule completeBkptCmds
-
-completeBkptCmds w = do
-  return (filter (w `isPrefixOf`) options)
-    where options = ["add","del","list","stop"]
-
 completeFilename = Readline.filenameCompletionFunction
 
 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
@@ -1395,18 +1444,6 @@ completeBkpt       = completeNone
 -- handler arond the flushing operation, so if stderr is closed
 -- GHCi will just die gracefully rather than going into an infinite loop.
 handler :: Exception -> GHCi Bool
-handler (DynException dyn) 
-  | Just StopChildSession <- fromDynamic dyn 
-     -- propagate to the parent session
-  = do ASSERTM (liftM not isTopLevel) 
-       throwDyn StopChildSession
-
-  | Just StopParentSession <- fromDynamic dyn 
-  = do at_topLevel <-  isTopLevel
-       if at_topLevel then return True else throwDyn StopParentSession
-  
-  | Just (ChildSessionStopped msg) <- fromDynamic dyn     
-  = io(putStrLn msg) >> return False
 
 handler exception = do
   flushInterpBuffers
@@ -1476,84 +1513,163 @@ setUpConsole = do
 #endif
        return ()
 
+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag 
+stepCmd expression = do
+   io $ setStepFlag
+   runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return () 
+continueCmd other = do
+   io $ putStrLn "The continue command accepts no arguments."
+   return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do 
+   resumeAction <- getResume
+   popResume
+   case resumeAction of
+      Nothing -> do 
+         io $ putStrLn "There is no computation running."
+         return False
+      Just action -> do
+         io $ actionBeforeCont
+         runResult <- io action
+         names <- switchOnRunResult runResult
+         finishEvalExpr names
+         return False 
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+   deleteSwitch $ words argLine
+   return False
+   where
+   deleteSwitch :: [String] -> GHCi ()
+   deleteSwitch [] = 
+      io $ putStrLn "The delete command requires at least one argument."
+   -- delete all break points
+   deleteSwitch ("*":_rest) = clearActiveBreakPoints
+   deleteSwitch idents = do
+      mapM_ deleteOneBreak idents 
+      where
+      deleteOneBreak :: String -> GHCi ()
+      deleteOneBreak str
+         | all isDigit str = deleteBreak (read str)
+         | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+   session <- getSession
+   breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch _session [] = do
+   io $ putStrLn "The break command requires at least one argument."
+   return False
+breakSwitch session args@(arg1:rest) 
+   | looksLikeModule arg1 = do
+        mod     <- lookupModule session arg1 
+        breakByModule mod rest
+        return False
+   | otherwise = do
+        (toplevel, _) <- io $ GHC.getContext session 
+        case toplevel of
+           (mod : _) -> breakByModule mod args 
+           [] -> do 
+              io $ putStrLn "Cannot find default module for breakpoint." 
+              io $ putStrLn "Perhaps no modules are loaded for debugging?"
+        return False
+   where
+   -- Todo there may be a nicer way to test this
+   looksLikeModule :: String -> Bool
+   looksLikeModule []    = False
+   looksLikeModule (x:_) = isUpper x
+
+breakByModule :: Module -> [String] -> GHCi () 
+breakByModule mod args@(arg1:rest)
+   | all isDigit arg1 = do  -- looks like a line number
+        breakByModuleLine mod (read arg1) rest
+   | looksLikeVar arg1 = do
+        -- break by a function definition
+        io $ putStrLn "Break by function definition not implemented."
+   | otherwise = io $ putStrLn "Invalid arguments to break command."
+   where
+   -- Todo there may be a nicer way to test this
+   looksLikeVar :: String -> Bool
+   looksLikeVar [] = False
+   looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+   | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+   | [col] <- args, all isDigit col =
+        findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
+   | otherwise = io $ putStrLn "Invalid arguments to break command."
+        
+findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do 
+   (breakArray, ticks) <- getModBreak mod 
+   let tickTree   = tickTreeFromList (assocs ticks)
+   case lookupTickTree tickTree of 
+      Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
+      Just (tick, span) -> do
+         success <- io $ setBreakFlag True breakArray tick 
+         session <- getSession
+         unqual  <- io $ GHC.getPrintUnqual session
+         if success 
+            then do
+               (alreadySet, nm) <- 
+                     recordBreak $ BreakLocation
+                             { breakModule = mod
+                             , breakLoc = span
+                             , breakTick = tick
+                             }
+               io $ printForUser stdout unqual $
+                  text "Breakpoint " <> ppr nm <>
+                  if alreadySet 
+                     then text " was already set at " <> ppr span
+                     else text " activated at " <> ppr span
+            else do
+            str <- showForUser $ text "Breakpoint could not be activated at" 
+                                 <+> ppr span
+            io $ putStrLn str
+
+getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+   session <- getSession
+   Just mod_info <- io $ GHC.getModuleInfo session mod
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let array      = modBreaks_array modBreaks
+   let ticks      = modBreaks_ticks modBreaks
+   return (array, ticks)
 
-instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
-instrumentationBkptHandler ref_bkptTable = BkptHandler {
-    isAutoBkptEnabled = \sess bkptLoc -> do 
-      bktpTable <- readIORef ref_bkptTable
-      return$ isBkptEnabled bktpTable bkptLoc
-
-  , handleBreakpoint = doBreakpoint ref_bkptTable 
-  }
-
-doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
-doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
-         let (ids, hValues) = unzip values
-             names = map idName ids
-         ASSERT (length names == length hValues) return ()
-         let global_ids = map globaliseAndTidy ids
-         printScopeMsg locMsg global_ids
-         typed_ids  <- mapM instantiateIdType global_ids
-         hsc_env <- readIORef ref
-         let ictxt = hsc_IC hsc_env
-             rn_env   = ic_rn_local_env ictxt
-             type_env = ic_type_env ictxt
-             bound_names = map idName typed_ids
-             new_rn_env  = extendLocalRdrEnv rn_env bound_names
-               -- Remove any shadowed bindings from the type_env;
-               -- they are inaccessible but might, I suppose, cause 
-               -- a space leak if we leave them there
-             shadowed = [ n | name <- bound_names,
-                          let rdr_name = mkRdrUnqual (nameOccName name),
-                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
-             filtered_type_env = delListFromNameEnv type_env shadowed
-             new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
-             new_ic = ictxt { ic_rn_local_env = new_rn_env, 
-                             ic_type_env     = new_type_env }
-         writeIORef ref (hsc_env { hsc_IC = new_ic })
-         is_tty <- hIsTerminalDevice stdin
-         prel_mod <- GHC.findModule s prel_name Nothing
-         withExtendedLinkEnv (zip names hValues) $ 
-           startGHCi (interactiveLoop is_tty True) GHCiState{ 
-                              progname = "<interactive>",
-                              args     = [],
-                              prompt   = locMsg ++ "> ",
-                              session  = s,
-                              options  = [],
-                              bkptTable= ref_bkptTable,
-                              prelude  = prel_mod,
-                             topLevel = False }
-             `catchDyn` (\e -> case e of 
-                           StopChildSession -> evaluate$
-                                               throwDyn (ChildSessionStopped "")
-                           StopParentSession -> throwDyn StopParentSession
-           ) `finally` do
-             writeIORef ref hsc_env
-             putStrLn $ "Returning to normal execution..."
-         return b
-  where 
-     printScopeMsg :: String -> [Id] -> IO ()
-     printScopeMsg location ids = do
-       unqual  <- GHC.getPrintUnqual s
-       printForUser stdout unqual $
-         text "Stopped at a breakpoint in " <> text (stripColumn location) <>
-         char '.' <+> text "Local bindings in scope:" $$
-         nest 2 (pprWithCommas showId ids)
-      where 
-           showId id = 
-                ppr (idName id) <+> dcolon <+> ppr (idType id) 
-           stripColumn = reverse . tail . dropWhile (/= ':') . reverse
-
--- | Give the Id a Global Name, and tidy its type
-     globaliseAndTidy :: Id -> Id
-     globaliseAndTidy id
-      = let tidied_type = tidyTopType$ idType id
-        in setIdType (globaliseId VanillaGlobal id) tidied_type
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+   = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool 
+setBreakFlag toggle array index
+   | toggle    = setBreakOn array index 
+   | otherwise = setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint  :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
 
--- | Instantiate the tyVars with GHC.Base.Unknown
-     instantiateIdType :: Id -> IO Id
-     instantiateIdType id = do
-       instantiatedType <- instantiateTyVarsToUnknown s (idType id)
-       return$ setIdType id instantiatedType
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
 
+enableSingleStep  :: Session -> IO ()
+enableSingleStep session = return ()
 
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()
index 2c1b668..38d584a 100644 (file)
@@ -18,7 +18,7 @@ module Linker ( HValue, getHValue, showLinkerState,
                linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
                 extendLoadedPkgs,
                linkPackages,initDynLinker,
-                recoverDataCon
+                dataConInfoPtrToName
        ) where
 
 #include "HsVersions.h"
@@ -28,8 +28,9 @@ import ByteCodeLink
 import ByteCodeItbls
 import ByteCodeAsm
 import RtClosureInspect
+import CgInfoTbls
+import SMRep
 import IfaceEnv
-import OccName
 import TcRnMonad
 import Packages
 import DriverPhases
@@ -38,6 +39,7 @@ import HscTypes
 import Name
 import NameEnv
 import NameSet
+import qualified OccName
 import UniqFM
 import Module
 import ListSetOps
@@ -52,6 +54,7 @@ import ErrUtils
 import DriverPhases
 import SrcLoc
 import UniqSet
+import Constants
 
 -- Standard libraries
 import Control.Monad
@@ -151,12 +154,13 @@ extendLinkEnv new_bindings
 --   We use this string to lookup the interpreter's internal representation of the name
 --   using the lookupOrig.    
 
-recoverDataCon :: a -> TcM Name
-recoverDataCon x = do 
+dataConInfoPtrToName :: Ptr () -> TcM Name
+dataConInfoPtrToName x = do 
    theString <- ioToTcRn $ do
-      let ptr = getInfoTablePtr x 
+      let ptr = castPtr x :: Ptr StgInfoTable
       conDescAddress <- getConDescAddress ptr 
-      peekCString conDescAddress  
+      str <- peekCString conDescAddress  
+      return str
    let (pkg, mod, occ) = parse theString 
        occName = mkOccName OccName.dataName occ
        modName = mkModule (stringToPackageId pkg) (mkModuleName mod) 
@@ -207,18 +211,10 @@ recoverDataCon x = do
    getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
    getConDescAddress ptr = do
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-       offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
-       return $ ptr `plusPtr` offsetToString
-       where
-       -- subtract a word number of bytes 
-       offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
-        peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
-      where 
-      -- add the standard info table size in bytes 
-      infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
-      offset = infoTableSizeBytes 
+       offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+       return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+#else
+       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
 #endif
 
    -- parsing names is a little bit fiddly because we have a string in the form: 
index 26816a0..b12d296 100644 (file)
@@ -12,11 +12,9 @@ module RtClosureInspect(
 
      ClosureType(..), 
      getClosureData,     -- :: a -> IO Closure
-     Closure ( tipe, infoTable, ptrs, nonPtrs ), 
-     getClosureType,     -- :: a -> IO ClosureType
+     Closure ( tipe, infoPtr, ptrs, nonPtrs ), 
      isConstr,           -- :: ClosureType -> Bool
      isIndirection,      -- :: ClosureType -> Bool
-     getInfoTablePtr,    -- :: a -> Ptr StgInfoTable
 
      Term(..), 
      printTerm, 
@@ -77,6 +75,8 @@ import Data.Array.Base
 import Data.List        ( partition )
 import Foreign.Storable
 
+import IO
+
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -139,6 +139,7 @@ data ClosureType = Constr
  deriving (Show, Eq)
 
 data Closure = Closure { tipe         :: ClosureType 
+                       , infoPtr      :: Ptr ()
                        , infoTable    :: StgInfoTable
                        , ptrs         :: Array Int HValue
                         -- What would be the type here? HValue is ok? Should I build a Ptr?
@@ -148,14 +149,6 @@ data Closure = Closure { tipe         :: ClosureType
 instance Outputable ClosureType where
   ppr = text . show 
 
-getInfoTablePtr :: a -> Ptr StgInfoTable
-getInfoTablePtr x = 
-    case infoPtr# x of
-      itbl_ptr -> castPtr ( Ptr itbl_ptr )
-
-getClosureType :: a -> IO ClosureType
-getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
-
 #include "../includes/ClosureTypes.h"
 
 aP_CODE = AP
@@ -164,14 +157,14 @@ pAP_CODE = PAP
 #undef PAP
 
 getClosureData :: a -> IO Closure
-getClosureData a = do
-   itbl <- peek (getInfoTablePtr a)
-   let tipe = readCType (BCI.tipe itbl)
-   case closurePayload# a of 
-     (# ptrs, nptrs #) -> 
-           let elems = BCI.ptrs itbl 
+getClosureData a =
+   case unpackClosure# a of 
+     (# iptr, ptrs, nptrs #) -> do
+           itbl <- peek (Ptr iptr)
+           let tipe = readCType (BCI.tipe itbl)
+               elems = BCI.ptrs itbl 
                ptrsList = Array 0 (fromIntegral$ elems) ptrs
-           in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
+           ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
 
 readCType :: Integral a => a -> ClosureType
 readCType i
@@ -481,9 +474,10 @@ instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
           trd  (x,y,z) = z
 
 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a = 
- -- Obtain the term and tidy the type before returning it
-     cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes 
+cvObtainTerm hsc_env force mb_ty a = do
+   -- Obtain the term and tidy the type before returning it
+   term <- cvObtainTerm1 hsc_env force mb_ty a
+   return $ tidyTypes term
    where 
          tidyTypes = foldTerm idTermFold {
             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
@@ -505,21 +499,18 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
    go tv hval
     where 
   go tv a = do 
-    ctype <- trIO$ getClosureType a
-    case ctype of
+    clos <- trIO $ getClosureData a
+    case tipe clos of
 -- Thunks we may want to force
       Thunk _ | force -> seq a $ go tv a
 -- We always follow indirections 
-      _       | isIndirection ctype -> do
-        clos   <- trIO$ getClosureData a
-        (go tv $! (ptrs clos ! 0))
+      Indirection _ -> go tv $! (ptrs clos ! 0)
  -- The interesting case
       Constr -> do
-        m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
+        m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
         case m_dc of
           Nothing -> panic "Can't find the DataCon for a term"
           Just dc -> do 
-            clos          <- trIO$ getClosureData a
             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
                 subTtypes  = drop extra_args (dataConRepArgTys dc)
                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
@@ -537,7 +528,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
             return (Term tv dc a subTerms)
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
       otherwise -> do
-         return (Suspension ctype (Just tv) a Nothing)
+         return (Suspension (tipe clos) (Just tv) a Nothing)
 
 -- Access the array of pointers and recurse down. Needs to be done with
 -- care of no introducing a thunk! or go will fail to do its job 
diff --git a/compiler/ghci/TickTree.hs b/compiler/ghci/TickTree.hs
new file mode 100644 (file)
index 0000000..a472e59
--- /dev/null
@@ -0,0 +1,110 @@
+-----------------------------------------------------------------------------
+--
+-- Trees of source spans used by the breakpoint machinery
+--
+-- (c) The University of Glasgow 2007
+--
+-----------------------------------------------------------------------------
+
+module TickTree 
+   ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList )
+   where
+
+import SrcLoc
+
+import Data.List (partition, foldl') 
+
+type TickNumber = Int
+
+newtype TickTree = Root [SpanTree]
+
+data SpanTree 
+   = Node 
+     { spanTreeTick     :: TickNumber 
+     , spanTreeLoc      :: SrcSpan
+     , spanTreeChildren :: [SpanTree]
+     }
+
+mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree
+mkNode tick loc kids
+   = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids }
+
+emptyTickTree :: TickTree
+emptyTickTree = Root []
+
+tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree
+tickTreeFromList 
+   = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree 
+
+insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree
+insertTickTree tick loc (Root children)
+   = Root $ insertSpanTree tick loc children
+
+insertSpanTree :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
+insertSpanTree tick loc [] = [mkNode tick loc []] 
+insertSpanTree tick loc children@(kid:siblings) 
+   | null containedKids = insertDeeper tick loc children
+   | otherwise = mkNode tick loc children : rest
+   where
+   (containedKids, rest) = getContainedKids loc children
+   insertDeeper :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
+   insertDeeper tick loc [] = [mkNode tick loc []] 
+   insertDeeper tick loc nodes@(kid:siblings)
+      | srcSpanStart loc < srcSpanStart kidLoc = newBranch : nodes 
+      | kidLoc `contains` loc = newKid : siblings 
+      | otherwise = kid : insertDeeper tick loc siblings
+      where
+      newBranch = mkNode tick loc []
+      kidLoc = spanTreeLoc kid
+      newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid)
+                      (insertSpanTree tick loc $ spanTreeChildren kid)
+
+getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree])
+getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree)) 
+
+-- True if the left loc contains the right loc
+contains :: SrcSpan -> SrcSpan -> Bool
+contains span1 span2
+   = srcSpanStart span1 <= srcSpanStart span2 &&
+     srcSpanEnd   span1 <= srcSpanEnd   span2   
+
+type TickLoc = (TickNumber, SrcSpan)
+type LineNumber = Int
+type ColumnNumber = Int
+type Coord = (LineNumber, ColumnNumber)
+
+srcSpanStartLine = srcLocLine . srcSpanStart
+
+lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc 
+lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children
+
+lookupSpanTreeLine :: LineNumber -> [SpanTree] -> Maybe TickLoc 
+lookupSpanTreeLine line [] = Nothing 
+lookupSpanTreeLine line (node:nodes)
+   | startLine == line && endLine == line 
+        = Just (spanTreeTick node, spanTreeLoc node) 
+   | startLine > line  
+        = lookupSpanTreeLine line nodes
+   | otherwise = 
+        case lookupSpanTreeLine line (spanTreeChildren node) of
+                Nothing    -> lookupSpanTreeLine line nodes
+                x@(Just _) -> x
+   where
+   startLine = srcSpanStartLine (spanTreeLoc node) 
+   endLine = srcSpanEndLine (spanTreeLoc node) 
+
+lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc 
+lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing
+
+lookupSpanTreeCoord :: Coord -> [SpanTree] -> Maybe TickLoc -> Maybe TickLoc 
+lookupSpanTreeCoord coord [] acc = acc 
+lookupSpanTreeCoord coord (kid:siblings) acc
+   | spanTreeLoc kid `spans` coord 
+        = lookupSpanTreeCoord coord (spanTreeChildren kid) 
+                              (Just (spanTreeTick kid, spanTreeLoc kid))
+   | otherwise 
+        = lookupSpanTreeCoord coord siblings acc
+   where
+   spans :: SrcSpan -> Coord -> Bool
+   spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
+        where loc = mkSrcLoc (srcSpanFile span) l c
index b6f1f48..b82685b 100644 (file)
@@ -50,7 +50,6 @@ import Maybes
 import SrcLoc
 import Util
 import DynFlags
-import Breakpoints
 import Control.Monad
 
 import Data.List
@@ -211,7 +210,7 @@ typecheckIface iface
                              , md_fam_insts = fam_insts
                              , md_rules     = rules
                              , md_exports   = exports
-                              , md_dbg_sites = noDbgSites
+                              , md_modBreaks = emptyModBreaks
                              }
     }
 \end{code}
diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs
new file mode 100644 (file)
index 0000000..788adf2
--- /dev/null
@@ -0,0 +1,96 @@
+--
+-- Break Arrays in the IO monad
+-- Entries in the array are Word sized 
+--
+
+module BreakArray
+  ( BreakArray (BA)
+  , newBreakArray
+  , getBreak 
+  , setBreakOn 
+  , setBreakOff
+  , showBreakArray
+  ) where
+
+import GHC.Exts
+import GHC.IOBase
+import GHC.Prim
+import GHC.Word
+import Constants
+
+data BreakArray = BA (MutableByteArray# RealWorld)
+
+breakOff, breakOn :: Word
+breakOn  = fromIntegral 1
+breakOff = fromIntegral 0
+
+-- XXX crude
+showBreakArray :: BreakArray -> IO ()
+showBreakArray array = do
+   let loop count sz
+          | count == sz = return ()
+          | otherwise = do
+               val <- readBreakArray array count 
+               putStr $ " " ++ show val
+               loop (count + 1) sz
+   loop 0 (size array) 
+   putStr "\n"
+
+setBreakOn :: BreakArray -> Int -> IO Bool 
+setBreakOn array index
+   | safeIndex array index = do 
+        writeBreakArray array index breakOn 
+        return True
+   | otherwise = return False 
+
+setBreakOff :: BreakArray -> Int -> IO Bool 
+setBreakOff array index
+   | safeIndex array index = do
+        writeBreakArray array index breakOff
+        return True
+   | otherwise = return False 
+
+getBreak :: BreakArray -> Int -> IO (Maybe Word)
+getBreak array index 
+   | safeIndex array index = do
+        val <- readBreakArray array index 
+        return $ Just val 
+   | otherwise = return Nothing
+
+safeIndex :: BreakArray -> Int -> Bool
+safeIndex array index = index < size array && index >= 0
+
+size :: BreakArray -> Int
+size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE
+
+allocBA :: Int -> IO BreakArray 
+allocBA (I# sz) = IO $ \s1 ->
+  case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) }
+
+-- create a new break array and initialise elements to zero
+newBreakArray :: Int -> IO BreakArray
+newBreakArray entries@(I# sz) = do
+   BA array <- allocBA (entries * wORD_SIZE) 
+   case breakOff of 
+      W# off -> do    -- Todo: there must be a better way to write zero as a Word!
+         let loop n
+                | n ==# sz = return ()
+                | otherwise = do
+                     writeBA# array n off 
+                     loop (n +# 1#)
+         loop 0#
+   return $ BA array
+
+writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO ()
+writeBA# array i word = IO $ \s ->
+  case writeWordArray# array i word s of { s -> (# s, () #) }
+
+writeBreakArray :: BreakArray -> Int -> Word -> IO ()
+writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word 
+
+readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word 
+readBA# array i = IO $ \s -> 
+   case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) }
+
+readBreakArray :: BreakArray -> Int -> IO Word 
+readBreakArray (BA array) (I# i) = readBA# array i
diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs
deleted file mode 100644 (file)
index c4318ca..0000000
+++ /dev/null
@@ -1,56 +0,0 @@
------------------------------------------------------------------------------\r
---\r
--- GHC API breakpoints. This module includes the main API (BkptHandler) and\r
--- utility code for implementing a client to this API used in GHCi \r
---\r
--- Pepe Iborra (supported by Google SoC) 2006\r
---\r
------------------------------------------------------------------------------\r
-\r
-module Breakpoints where\r
-\r
-#ifdef GHCI\r
-import {-#SOURCE#-} ByteCodeLink ( HValue ) \r
-#endif\r
-\r
-import {-#SOURCE#-} HscTypes     ( Session )\r
-import Name\r
-import Var                       ( Id )\r
-import PrelNames\r
-\r
-import GHC.Exts\r
-\r
-#ifdef GHCI\r
-data BkptHandler a = BkptHandler {\r
-     handleBreakpoint  :: forall b. Session -> [(Id,HValue)] -> BkptLocation a ->  String -> b -> IO b\r
-   , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool\r
-   }\r
-\r
-nullBkptHandler = BkptHandler {\r
-    isAutoBkptEnabled = \ _ _     -> return False,\r
-    handleBreakpoint  = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b\r
-                              }\r
-#endif\r
-\r
-type BkptLocation a = (a, SiteNumber)\r
-type SiteNumber   = Int\r
-\r
-type SiteMap      = [(SiteNumber, Coord)]\r
-type Coord        = (Int, Int)\r
-\r
-noDbgSites :: SiteMap\r
-noDbgSites = []\r
-\r
--- | Returns the 'identity' jumps\r
---   Used to deal with spliced code, where we don't want breakpoints\r
-#ifdef GHCI\r
-lookupBogusBreakpointVal :: Name -> Maybe HValue\r
-lookupBogusBreakpointVal name \r
-  | name == breakpointJumpName     = Just$ unsafeCoerce# (\_ _ a->a)\r
-  | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a)\r
-  | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a)\r
-  | otherwise = Nothing\r
-#else \r
-lookupBogusBreakpointVal _ = Nothing\r
-#endif /* GHCI */\r
-\r
index f10d2f9..fa5ae4b 100644 (file)
@@ -85,10 +85,6 @@ import Util          ( split )
 import Data.Char       ( isUpper )
 import System.IO        ( hPutStrLn, stderr )
 
-#ifdef GHCI
-import Breakpoints      ( BkptHandler )
-import Module           ( ModuleName )
-#endif
 -- -----------------------------------------------------------------------------
 -- DynFlags
 
@@ -208,9 +204,6 @@ data DynFlag
    | Opt_SplitObjs
    | Opt_StgStats
    | Opt_HideAllPackages
-#if defined(GHCI) && defined(DEBUGGER)
-   | Opt_Debugging
-#endif
    | Opt_PrintBindResult
    | Opt_Haddock
    | Opt_Hpc_No_Auto
@@ -321,11 +314,6 @@ data DynFlags = DynFlags {
   
   -- message output
   log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
-
-#ifdef GHCI
-  -- breakpoint handling
- ,bkptHandler           :: Maybe (BkptHandler Module)
-#endif
  }
 
 data HscTarget
@@ -446,9 +434,6 @@ defaultDynFlags =
        packageFlags            = [],
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
-#ifdef GHCI
-        bkptHandler             = Nothing,
-#endif
        flags = [ 
            Opt_ReadUserPackageConf,
     
@@ -1079,9 +1064,6 @@ fFlags = [
   ( "excess-precision",                        Opt_ExcessPrecision ),
   ( "asm-mangling",                    Opt_DoAsmMangling ),
   ( "print-bind-result",               Opt_PrintBindResult ),
-#if defined(GHCI) && defined(DEBUGGER)
-  ( "debugging",                        Opt_Debugging),
-#endif
   ( "force-recomp",                    Opt_ForceRecomp ),
   ( "hpc-no-auto",                     Opt_Hpc_No_Auto )
   ]
index eb2ca8e..5f78c3e 100644 (file)
@@ -60,9 +60,6 @@ module GHC (
        modInfoInstances,
        modInfoIsExportedName,
        modInfoLookupName,
-#if defined(GHCI)
-        modInfoBkptSites,
-#endif
        lookupGlobalName,
 
        -- * Printing
@@ -86,9 +83,8 @@ module GHC (
         isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,
        lookupName,
-
-        getBreakpointHandler, setBreakpointHandler, 
         obtainTerm, obtainTerm1,
+        modInfoModBreaks, 
 #endif
 
        -- * Abstract syntax elements
@@ -194,24 +190,16 @@ import Name               ( nameOccName )
 import Type            ( tidyType )
 import Var             ( varName )
 import VarEnv          ( emptyTidyEnv )
-import GHC.Exts         ( unsafeCoerce# )
-
--- For breakpoints
-import Breakpoints      ( SiteNumber, Coord, nullBkptHandler, 
-                          BkptHandler(..), BkptLocation, noDbgSites )
-import Linker           ( initDynLinker )
-import PrelNames        ( breakpointJumpName, breakpointCondJumpName, 
-                          breakpointAutoJumpName )
-
-import GHC.Exts         ( Int(..), Ptr(..), int2Addr#, indexArray# )
-import GHC.Base         ( Opaque(..) )
-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
-import Foreign          ( unsafePerformIO )
+import GHC.Exts         ( unsafeCoerce#, Ptr )
+import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign          ( poke )
 import Data.Maybe       ( fromMaybe)
 import qualified Linker
 
 import Data.Dynamic     ( Dynamic )
 import Linker          ( HValue, getHValue, extendLinkEnv )
+
+import ByteCodeInstr    (BreakInfo)
 #endif
 
 import Packages                ( initPackages )
@@ -854,7 +842,7 @@ checkModule session@(Session ref) mod = do
                                minf_rdr_env   = Just rdr_env,
                                minf_instances = md_insts details
 #ifdef GHCI
-                               ,minf_dbg_sites = noDbgSites
+                               ,minf_modBreaks = emptyModBreaks 
 #endif
                              }
                   return (Just (CheckedModule {
@@ -1799,7 +1787,7 @@ data ModuleInfo = ModuleInfo {
        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
        minf_instances :: [Instance]
 #ifdef GHCI
-        ,minf_dbg_sites :: [(SiteNumber,Coord)] 
+        ,minf_modBreaks :: ModBreaks 
 #endif
        -- ToDo: this should really contain the ModIface too
   }
@@ -1840,7 +1828,7 @@ getPackageModuleInfo hsc_env mdl = do
                        minf_exports   = names,
                        minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
-                        minf_dbg_sites = noDbgSites
+                        minf_modBreaks = emptyModBreaks  
                }))
 #else
   -- bogusly different for non-GHCI (ToDo)
@@ -1858,7 +1846,7 @@ getHomeModuleInfo hsc_env mdl =
                        minf_rdr_env   = mi_globals $! hm_iface hmi,
                        minf_instances = md_insts details
 #ifdef GHCI
-                       ,minf_dbg_sites = md_dbg_sites details
+                       ,minf_modBreaks = md_modBreaks details  
 #endif
                        }))
 
@@ -1894,7 +1882,7 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do
                            (hsc_HPT hsc_env) (eps_PTE eps) name
 
 #ifdef GHCI
-modInfoBkptSites = minf_dbg_sites
+modInfoModBreaks = minf_modBreaks  
 #endif
 
 isDictonaryId :: Id -> Bool
@@ -1993,7 +1981,6 @@ setContext sess@(Session ref) toplev_mods export_mods = do
   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
                                            ic_exports      = export_mods,
                                            ic_rn_gbl_env   = all_env }}
-  reinstallBreakpointHandlers sess
 
 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
@@ -2164,14 +2151,22 @@ data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
   | RunException Exception     -- ^ statement raised an exception
+  | forall a . RunBreak a ThreadId BreakInfo (IO RunResult)
+
+data Status a
+   = Break RunResult               -- ^ the computation hit a breakpoint
+   | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value
 
--- | Run a statement in the current interactive context.  Statemenet
+-- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.
 runStmt :: Session -> String -> IO RunResult
 runStmt (Session ref) expr
    = do 
        hsc_env <- readIORef ref
 
+        breakMVar  <- newEmptyMVar  -- wait on this when we hit a breakpoint
+        statusMVar <- newEmptyMVar  -- wait on this when a computation is running 
+
        -- Turn off -fwarn-unused-bindings when running a statement, to hide
        -- warnings about the implicit bindings we introduce.
        let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
@@ -2183,36 +2178,58 @@ runStmt (Session ref) expr
           Nothing -> return RunFailed
           Just (new_hsc_env, names, hval) -> do
 
-               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-               either_hvals <- sandboxIO thing_to_run
-
+              -- resume says what to do when we continue execution from a breakpoint
+              -- onBreakAction says what to do when we hit a breakpoint
+              -- they are mutually recursive, hence the strange use tuple let-binding 
+              let (resume, onBreakAction)
+                     = ( do stablePtr <- newStablePtr onBreakAction 
+                            poke breakPointIOAction stablePtr
+                            putMVar breakMVar ()
+                            status <- takeMVar statusMVar
+                            switchOnStatus ref new_hsc_env names status
+                       , \ids apStack -> do 
+                            tid <- myThreadId
+                            putMVar statusMVar (Break (RunBreak apStack tid ids resume))
+                            takeMVar breakMVar 
+                       )
+
+              -- set the onBreakAction to be performed when we hit a breakpoint
+              -- this is visible in the Byte Code Interpreter, thus it is a global
+              -- variable, implemented with stable pointers
+              stablePtr <- newStablePtr onBreakAction
+              poke breakPointIOAction stablePtr
+
+              let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+              status <- sandboxIO statusMVar thing_to_run
+              freeStablePtr stablePtr -- be careful not to leak stable pointers!
+              switchOnStatus ref new_hsc_env names status
+   where
+   switchOnStatus ref hs_env names status = 
+      case status of  
+         -- did we hit a breakpoint or did we complete?
+         (Break result) -> return result 
+         (Complete either_hvals) ->
                case either_hvals of
-                   Left e -> do
-                       -- on error, keep the *old* interactive context,
-                       -- so that 'it' is not bound to something
-                       -- that doesn't exist.
-                       return (RunException e)
-
+                   Left e -> return (RunException e)
                    Right hvals -> do
-                       -- Get the newly bound things, and bind them.  
-                       -- Don't need to delete any shadowed bindings;
-                       -- the new ones override the old ones. 
                        extendLinkEnv (zip names hvals)
-                       
-                       writeIORef ref new_hsc_env
+                       writeIORef ref hs_env 
                        return (RunOk names)
+           
+-- this points to the IO action that is executed when a breakpoint is hit
+foreign import ccall "&breakPointIOAction" 
+        breakPointIOAction :: Ptr (StablePtr (a -> BreakInfo -> IO ())) 
 
 -- When running a computation, we redirect ^C exceptions to the running
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
-sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
-  m <- newEmptyMVar
+sandboxIO :: MVar (Status a) -> IO a -> IO (Status a) 
+sandboxIO statusMVar thing = do
   ts <- takeMVar interruptTargetThread
-  child <- forkIO (do res <- Exception.try thing; putMVar m res)
+  child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
   putMVar interruptTargetThread (child:ts)
-  takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
+  takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
 
 {-
 -- This version of sandboxIO runs the expression in a completely new
@@ -2261,75 +2278,6 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
                      where
                         obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
------------------------------------------------------------------------------
--- Breakpoint handlers
-
-getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
-getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
-setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
-setBreakpointHandler session handler = do
-  dflags <- getSessionDynFlags session
-  setSessionDynFlags session dflags{ bkptHandler = Just handler }
-  let linkEnv =   [ ( breakpointJumpName
-                    , unsafeCoerce# (jumpFunction session handler))
-                  , ( breakpointCondJumpName
-                    , unsafeCoerce# (jumpCondFunction session handler))
-                  , ( breakpointAutoJumpName 
-                    , unsafeCoerce# (jumpAutoFunction session handler))
-                  ]
-  writeIORef v_bkptLinkEnv linkEnv
-  dflags <- getSessionDynFlags session
-  reinstallBreakpointHandlers session
-
-reinstallBreakpointHandlers :: Session -> IO ()
-reinstallBreakpointHandlers session = do
-  dflags <- getSessionDynFlags session
-  let mode = ghcMode dflags
-  when (ghcLink dflags == LinkInMemory) $ do
-    linkEnv <- readIORef v_bkptLinkEnv
-    initDynLinker dflags 
-    extendLinkEnv linkEnv
-
------------------------------------------------------------------------
--- Jump functions
-
-type SiteInfo = (String, SiteNumber)
-jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
-jumpCondFunction  :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
-jumpFunctionM :: Session -> BkptHandler a ->  BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
-
-jumpCondFunction _ _ _ _ False b = b
-jumpCondFunction session handler site args True b
-    = jumpFunction session handler site args b
-
-jumpFunction session handler siteInfo args b 
-    | site <- mkSite siteInfo
-    = unsafePerformIO $ jumpFunctionM session handler site args b
-
-jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = 
-      do 
-         ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
-         let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
-         handleBreakpoint handler session (zip ids hValues) site locmsg b
-
-jumpAutoFunction session handler siteInfo args b 
-    | site <- mkSite siteInfo
-    = unsafePerformIO $ do
-         break <- isAutoBkptEnabled handler session site 
-         if break 
-            then jumpFunctionM session handler site args b
-            else return b
-
-jumpStepByStepFunction session handler siteInfo args b 
-    | site <- mkSite siteInfo
-    = unsafePerformIO $ do
-          jumpFunctionM session handler site args b
-
-mkSite :: SiteInfo -> BkptLocation Module
-mkSite ( modName, sitenum) =
-  (mkModule mainPackageId (mkModuleName modName), sitenum)
-
 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 
index 0627925..4413c52 100644 (file)
@@ -76,7 +76,6 @@ import CodeGen                ( codeGen )
 import CmmParse                ( parseCmmFile )
 import CodeOutput      ( codeOutput )
 import NameEnv          ( emptyNameEnv )
-import Breakpoints      ( noDbgSites )
 
 import DynFlags
 import ErrUtils
@@ -636,7 +635,7 @@ hscInteractive (iface, details, cgguts)
          prepd_binds <- {-# SCC "CorePrep" #-}
                         corePrepPgm dflags core_binds data_tycons ;
          -----------------  Generate byte code ------------------
-         comp_bc <- byteCodeGen dflags prepd_binds data_tycons
+         comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
          ------------------ Create f-x-dynamic C-side stuff ---
          (istub_h_exists, istub_c_exists) 
              <- outputForeignStubs dflags this_mod location foreign_stubs
@@ -682,7 +681,7 @@ hscFileCheck hsc_env mod_summary = do {
                                md_exports   = tcg_exports   tc_result,
                                md_insts     = tcg_insts     tc_result,
                                md_fam_insts = tcg_fam_insts tc_result,
-                                md_dbg_sites = noDbgSites,
+                                md_modBreaks = emptyModBreaks,      
                                md_rules     = [panic "no rules"] }
                                   -- Rules are CoreRules, not the
                                   -- RuleDecls we get out of the typechecker
index 92b7228..c7926e3 100644 (file)
@@ -59,12 +59,14 @@ module HscTypes (
        Linkable(..), isObjectLinkable,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-        HpcInfo, noHpcInfo
+        HpcInfo, noHpcInfo,
+
+        -- Breakpoints
+        ModBreaks (..), emptyModBreaks
     ) where
 
 #include "HsVersions.h"
 
-import Breakpoints      ( SiteNumber, Coord, noDbgSites )
 #ifdef GHCI
 import ByteCodeAsm     ( CompiledByteCode )
 #endif
@@ -100,6 +102,7 @@ import FiniteMap    ( FiniteMap )
 import CoreSyn         ( CoreRule )
 import Maybes          ( orElse, expectJust, catMaybes, seqMaybe )
 import Outputable
+import BreakArray
 import SrcLoc          ( SrcSpan, Located )
 import UniqFM          ( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply      ( UniqSupply )
@@ -109,6 +112,7 @@ import StringBuffer ( StringBuffer )
 
 import System.Time     ( ClockTime )
 import Data.IORef      ( IORef, readIORef )
+import Data.Array       ( Array, array )
 \end{code}
 
 
@@ -456,7 +460,7 @@ data ModDetails
         md_insts     :: ![Instance],   -- Dfun-ids for the instances in this module
         md_fam_insts :: ![FamInst],
         md_rules     :: ![CoreRule],   -- Domain may include Ids from other modules
-        md_dbg_sites     :: ![(SiteNumber, Coord)]     -- Breakpoint sites inserted by the renamer
+        md_modBreaks :: !ModBreaks  -- breakpoint information for this module 
      }
 
 emptyModDetails = ModDetails { md_types = emptyTypeEnv,
@@ -464,7 +468,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
                               md_insts     = [],
                               md_rules     = [],
                               md_fam_insts = [],
-                               md_dbg_sites = noDbgSites}
+                               md_modBreaks = emptyModBreaks } 
 
 -- A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
@@ -498,7 +502,7 @@ data ModGuts
        mg_foreign   :: !ForeignStubs,
        mg_deprecs   :: !Deprecations,   -- Deprecations declared in the module
        mg_hpc_info  :: !HpcInfo,        -- info about coverage tick boxes
-        mg_dbg_sites :: ![(SiteNumber, Coord)]     -- Bkpts inserted by the renamer
+        mg_modBreaks :: !ModBreaks
     }
 
 -- The ModGuts takes on several slightly different forms:
@@ -1140,11 +1144,6 @@ showModMsg target recomp mod_summary
   = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
                    char '(', text (msHsFilePath mod_summary) <> comma,
                    case target of
-#if defined(GHCI) && defined(DEBUGGER)
-                      HscInterpreted | recomp && 
-                                       Opt_Debugging `elem` modflags
-                                 -> text "interpreted(debugging)"
-#endif
                       HscInterpreted | recomp 
                                  -> text "interpreted"
                       HscNothing -> text "nothing"
@@ -1153,7 +1152,6 @@ showModMsg target recomp mod_summary
  where 
     mod     = moduleName (ms_mod mod_summary)
     mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
-    modflags= flags(ms_hspp_opts mod_summary)
 \end{code}
 
 
@@ -1238,5 +1236,25 @@ byteCodeOfObject (BCOs bc) = bc
 byteCodeOfObject other     = pprPanic "byteCodeOfObject" (ppr other)
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+\subsection{Breakpoint Support}
+%*                                                                      *
+%************************************************************************
 
+\begin{code}
+-- all the information about the breakpoints for a given module
+data ModBreaks
+   = ModBreaks
+   { modBreaks_array :: BreakArray
+            -- the array of breakpoint flags indexed by tick number
+   , modBreaks_ticks :: !(Array Int SrcSpan)
+   }
 
+emptyModBreaks :: ModBreaks
+emptyModBreaks = ModBreaks
+   { modBreaks_array = error "ModBreaks.modBreaks_array not initialised"
+         -- Todo: can we avoid this? 
+   , modBreaks_ticks = array (0,-1) []
+   }
+\end{code}
index 6f44bca..b001e1d 100644 (file)
@@ -124,8 +124,9 @@ mkBootModDetails hsc_env (ModGuts { mg_module    = mod
                                  , mg_exports   = exports
                                  , mg_types     = type_env
                                  , mg_insts     = insts
-                                 , mg_fam_insts = fam_insts,
-                                    mg_dbg_sites = sites })
+                                 , mg_fam_insts = fam_insts
+                                  , mg_modBreaks = modBreaks   
+                                  })
   = do { let dflags = hsc_dflags hsc_env 
        ; showPass dflags "Tidy [hoot] type env"
 
@@ -140,7 +141,8 @@ mkBootModDetails hsc_env (ModGuts { mg_module    = mod
                             , md_fam_insts = fam_insts
                             , md_rules     = []
                             , md_exports   = exports
-                             , md_dbg_sites = sites})
+                             , md_modBreaks = modBreaks 
+                             })
        }
   where
 
@@ -244,7 +246,7 @@ tidyProgram hsc_env
                                mg_dir_imps = dir_imps, mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,
-                                mg_dbg_sites = sites })
+                                mg_modBreaks = modBreaks })
 
   = do { let dflags = hsc_dflags hsc_env
        ; showPass dflags "Tidy Core"
@@ -303,7 +305,8 @@ tidyProgram hsc_env
                                md_insts     = tidy_insts,
                                md_fam_insts = fam_insts,
                                md_exports   = exports,
-                                md_dbg_sites = sites })
+                                md_modBreaks = modBreaks })
+
        }
 
 lookup_dfun type_env dfun_id
index f0ecc35..d001c28 100644 (file)
@@ -77,7 +77,6 @@ exposed-modules:
        DriverPipeline
        DsArrows
        DsBinds
-       DsBreakpoint
        DsCCall
        DsExpr
        DsForeign
index 16149d9..1d46095 100644 (file)
@@ -1738,13 +1738,8 @@ primop  NewBCOOp "newBCO#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
-primop  InfoPtrOp "infoPtr#" GenPrimOp
-   a -> Addr#
-   with
-   out_of_line = True
-
-primop  ClosurePayloadOp "closurePayload#" GenPrimOp
-   a -> (# Array# b, ByteArr# #)
+primop  UnpackClosureOp "unpackClosure#" GenPrimOp
+   a -> (# Addr#, Array# b, ByteArr# #)
    with
    out_of_line = True
 
index e26c50b..2595963 100644 (file)
@@ -72,7 +72,6 @@ import SrcLoc
 import HscTypes
 import ListSetOps
 import Outputable
-import Breakpoints
 
 #ifdef GHCI
 import Linker
@@ -97,6 +96,9 @@ import Util
 import Bag
 
 import Control.Monad    ( unless )
+import Data.Maybe      ( isJust )
+import Foreign.Ptr      ( Ptr )
+
 \end{code}
 
 
@@ -318,7 +320,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_deprecs   = NoDeprecs,
                                mg_foreign   = NoStubs,
                                mg_hpc_info  = noHpcInfo,
-                                mg_dbg_sites = noDbgSites
+                                mg_modBreaks = emptyModBreaks  
                    } } ;
 
    tcCoreDump mod_guts ;
@@ -1193,11 +1195,11 @@ lookup_rdr_name rdr_name = do {
     return good_names
  }
 
-tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
-tcRnRecoverDataCon hsc_env a
+tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) 
+tcRnRecoverDataCon hsc_env ptr
   = initTcPrintErrors hsc_env iNTERACTIVE $ 
-    setInteractiveContext hsc_env (hsc_IC hsc_env) $
-     do name    <- recoverDataCon a
+    setInteractiveContext hsc_env (hsc_IC hsc_env) $ do
+        name <- dataConInfoPtrToName ptr
         tcLookupDataCon name
 
 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
index 0de156b..b420851 100644 (file)
@@ -1,5 +1,6 @@
 >module TcRnDriver where
 >import HscTypes
 >import DataCon
+>import Foreign.Ptr
 >
->tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
\ No newline at end of file
+>tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) 
index 4e2ae69..b675cf9 100644 (file)
@@ -376,11 +376,7 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
        -> TcM hs_syn           -- Of type t
 runMeta convert expr
   = do {       -- Desugar
-#if defined(GHCI) && defined(DEBUGGER)
-         ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr)
-#else 
          ds_expr <- initDsTc (dsLExpr expr)
-#endif
        -- Compile and link it; might fail if linking fails
        ; hsc_env <- getTopEnv
        ; src_span <- getSrcSpanM
index 4a75b00..3df7ddd 100644 (file)
@@ -75,6 +75,7 @@
 #define bci_RETURN_D                   50
 #define bci_RETURN_L                   51
 #define bci_RETURN_V                   52
+#define bci_BRK_FUN                    53
 /* If you need to go past 255 then you will run into the flags */
 
 /* If you need to go below 0x0100 then you will run into the instructions */
index cc1987d..66b8fe7 100644 (file)
  *
  * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks
  * interruptibly (eg. with BlockedOnMVar).
+ *
+ * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint
  */
 #define TSO_BLOCKEX       4
 #define TSO_INTERRUPTIBLE 8
+#define TSO_STOPPED_ON_BREAKPOINT 16 
 
 /* -----------------------------------------------------------------------------
    RET_DYN stack frames
index 8267128..3c64827 100644 (file)
@@ -589,8 +589,8 @@ RTS_FUN(readTVarzh_fast);
 RTS_FUN(writeTVarzh_fast);
 RTS_FUN(checkzh_fast);
 
-RTS_FUN(infoPtrzh_fast);
-RTS_FUN(closurePayloadzh_fast);
+RTS_FUN(unpackClosurezh_fast);
+RTS_FUN(getApStackValzh_fast);
 
 RTS_FUN(noDuplicatezh_fast);
 
index a47a215..cda113a 100644 (file)
@@ -316,9 +316,6 @@ BuildingGranSim=$(subst mg,YES,$(filter mg,$(WAYS)))
 
 HscIfaceFileVersion=6
 
-# Building with debugger?
-GhciWithDebugger=YES
-
 #------------------------------------------------------------------------------
 # Options for Libraries
 
index 4407c77..0620e99 100644 (file)
@@ -43,6 +43,11 @@ disInstr ( StgBCO *bco, int pc )
 
    instr = instrs[pc++];
    switch (instr) {
+      case bci_BRK_FUN:
+         debugBelch ("BRK_FUN  " );  printPtr( ptrs[instrs[pc]] ); 
+         debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); debugBelch("\n" );
+         pc += 3;
+         break;
       case bci_SWIZZLE:
          debugBelch("SWIZZLE stkoff %d by %d\n",
                          instrs[pc], (signed int)instrs[pc+1]);
index 62fd2c2..188693c 100644 (file)
@@ -83,6 +83,7 @@ allocate_NONUPD (int n_words)
     return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
 }
 
+rtsBool stop_next_breakpoint = rtsFalse;
 
 #ifdef INTERP_STATS
 
@@ -103,6 +104,7 @@ int it_ofreq[27];
 int it_oofreq[27][27];
 int it_lastopc;
 
+
 #define INTERP_TICK(n) (n)++
 
 void interp_startup ( void )
@@ -175,6 +177,9 @@ static StgWord app_ptrs_itbl[] = {
     (W_)&stg_ap_pppppp_info,
 };
 
+HsStablePtr breakPointIOAction; // points to the IO action which is executed on a breakpoint
+                                // it is set in main/GHC.hs:runStmt
+
 Capability *
 interpretBCO (Capability* cap)
 {
@@ -198,8 +203,8 @@ interpretBCO (Capability* cap)
     //         +---------------+
     //       
     if (Sp[0] == (W_)&stg_enter_info) {
-       Sp++;
-       goto eval;
+       Sp++;
+       goto eval;
     }
 
     // ------------------------------------------------------------------------
@@ -284,8 +289,10 @@ eval_obj:
        break;
        
     case BCO:
+    {
        ASSERT(((StgBCO *)obj)->arity > 0);
        break;
+    }
 
     case AP:   /* Copied from stg_AP_entry. */
     {
@@ -672,6 +679,7 @@ do_apply:
     // Sadly we have three different kinds of stack/heap/cswitch check
     // to do:
 
+
 run_BCO_return:
     // Heap check
     if (doYouWantToGC()) {
@@ -680,6 +688,7 @@ run_BCO_return:
     }
     // Stack checks aren't necessary at return points, the stack use
     // is aggregated into the enclosing function entry point.
+
     goto run_BCO;
     
 run_BCO_return_unboxed:
@@ -689,6 +698,7 @@ run_BCO_return_unboxed:
     }
     // Stack checks aren't necessary at return points, the stack use
     // is aggregated into the enclosing function entry point.
+
     goto run_BCO;
     
 run_BCO_fun:
@@ -715,6 +725,7 @@ run_BCO_fun:
        Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
        RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
     }
+
     goto run_BCO;
     
     // Now, actually interpret the BCO... (no returning to the
@@ -723,7 +734,7 @@ run_BCO:
     INTERP_TICK(it_BCO_entries);
     {
        register int       bciPtr     = 1; /* instruction pointer */
-    register StgWord16 bci;
+        register StgWord16 bci;
        register StgBCO*   bco        = (StgBCO*)obj;
        register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
        register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
@@ -753,6 +764,7 @@ run_BCO:
                 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
            );
 
+
        INTERP_TICK(it_insns);
 
 #ifdef INTERP_STATS
@@ -769,6 +781,88 @@ run_BCO:
 
     switch (bci & 0xFF) {
 
+        /* check for a breakpoint on the beginning of a let binding */
+        case bci_BRK_FUN: 
+        {
+            int arg1_brk_array, arg2_array_index, arg3_freeVars;
+            StgArrWords *breakPoints;
+            int returning_from_break;     /* are we resuming execution from a breakpoint?
+                                          **   if yes, then don't break this time around */
+            StgClosure *ioAction;         // the io action to run at a breakpoint
+
+            StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
+            int i;
+            int size_words;
+
+            arg1_brk_array      = BCO_NEXT;  /* first argument of break instruction */
+            arg2_array_index    = BCO_NEXT;  /* second dargument of break instruction */
+            arg3_freeVars       = BCO_NEXT;  /* third argument of break instruction */
+
+            // check if we are returning from a breakpoint - this info is stored in
+            // the flags field of the current TSO
+            returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; 
+
+            // if we are returning from a break then skip this section and continue executing
+            if (!returning_from_break)
+            {
+               breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
+
+               // stop the current thread if either the "stop_next_breakpoint" flag is true
+               // OR if the breakpoint flag for this particular expression is true
+               if (stop_next_breakpoint == rtsTrue || breakPoints->payload[arg2_array_index] == rtsTrue)
+               {
+                  stop_next_breakpoint = rtsFalse; // make sure we don't automatically stop at the next breakpoint
+
+                  // allocate memory for a new AP_STACK, enough to store the top stack frame
+                  // plus an stg_apply_interp_info pointer and a pointer to the BCO
+                  size_words = BCO_BITMAP_SIZE(obj) + 2;
+                  new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
+                  SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); 
+                  new_aps->size = size_words;
+                  // we should never enter new_aps->fun, so it is assigned to a dummy value
+                  // ToDo: fixme to something that explodes with an error if you enter it 
+                  new_aps->fun = &stg_dummy_ret_closure; 
+
+                  // fill in the payload of the AP_STACK 
+                  new_aps->payload[0] = (W_)&stg_apply_interp_info;
+                  new_aps->payload[1] = (W_)obj;
+
+                  // copy the contents of the top stack frame into the AP_STACK
+                  for (i = 2; i < size_words; i++)
+                  {
+                     new_aps->payload[i] = (W_)Sp[i-2];
+                  }
+
+                  // prepare the stack so that we can call the breakPointIOAction
+                  // 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 (breakPointIOAction);
+                  Sp -= 7;
+                  Sp[6] = (W_)obj;   
+                  Sp[5] = (W_)&stg_apply_interp_info;
+                  Sp[4] = (W_)new_aps;                 /* the AP_STACK */
+                  Sp[3] = (W_)BCO_PTR(arg3_freeVars);  /* the info about local vars of the breakpoint */
+                  Sp[2] = (W_)&stg_ap_ppv_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 */
+
+                  // 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 already
+                  // stopped at just now 
+                  cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
+
+                  // stop this thread and return to the scheduler - eventually we will come back
+                  // and the IO action on the top of the stack will be executed
+                  RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
+               }
+            }
+            // record that this thread is not stopped at a breakpoint anymore
+            cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
+
+            // continue normal execution of the byte code instructions
+           goto nextInsn;
+        }
+
        case bci_STKCHECK: {
            // Explicit stack check at the beginning of a function
            // *only* (stack checks in case alternatives are
@@ -1256,7 +1350,7 @@ run_BCO:
            bciPtr     = nextpc;
            goto nextInsn;
        }
-
        case bci_CASEFAIL:
            barf("interpretBCO: hit a CASEFAIL");
            
@@ -1271,3 +1365,32 @@ run_BCO:
 
     barf("interpretBCO: fell off end of the interpreter");
 }
+
+/* temporary code for peeking inside a AP_STACK and pulling out values
+   based on their stack offset - used in the debugger for inspecting
+   the local values of a breakpoint
+*/
+HsStablePtr rts_getApStackVal (HsStablePtr, int);
+HsStablePtr rts_getApStackVal (HsStablePtr apStackSptr, int offset)
+{
+   HsStablePtr resultSptr;
+   StgAP_STACK *apStack;
+   StgClosure **payload;
+   StgClosure *val;
+
+   apStack = (StgAP_STACK *) deRefStablePtr (apStackSptr);
+   payload = apStack->payload;
+   val = (StgClosure *) payload[offset+2];
+   resultSptr = getStablePtr (val); 
+   return resultSptr;
+}
+
+/* set the single step flag for the debugger to True -
+   it gets set back to false in the interpreter everytime
+   we hit a breakpoint
+*/
+void rts_setStepFlag (void);
+void rts_setStepFlag (void)
+{
+   stop_next_breakpoint = rtsTrue;
+}
index 4ab84ed..58ee939 100644 (file)
@@ -525,8 +525,8 @@ typedef struct _RtsSymbolVal {
       SymX(hs_free_stable_ptr)                 \
       SymX(hs_free_fun_ptr)                    \
       SymX(initLinker)                         \
-      SymX(infoPtrzh_fast)                      \
-      SymX(closurePayloadzh_fast)               \
+      SymX(unpackClosurezh_fast)                \
+      SymX(getApStackValzh_fast)                \
       SymX(int2Integerzh_fast)                 \
       SymX(integer2Intzh_fast)                 \
       SymX(integer2Wordzh_fast)                        \
index 31f58d1..bb9fadd 100644 (file)
@@ -1823,6 +1823,7 @@ newBCOzh_fast
     W_ bco, bitmap_arr, bytes, words;
     
     bitmap_arr = R5;
+
     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
     bytes = WDS(words);
 
@@ -1876,34 +1877,48 @@ mkApUpd0zh_fast
     RET_P(ap);
 }
 
-infoPtrzh_fast
-{
-/* args: R1 = closure to analyze */
-   
-  MAYBE_GC(R1_PTR, infoPtrzh_fast);
-
-  W_ info;
-  info = %GET_STD_INFO(R1);
-  RET_N(info);
-}
-
-closurePayloadzh_fast
+unpackClosurezh_fast
 {
 /* args: R1 = closure to analyze */
 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
 
-    MAYBE_GC(R1_PTR, closurePayloadzh_fast);
-
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
     info  = %GET_STD_INFO(R1);
     ptrs  = TO_W_(%INFO_PTRS(info)); 
     nptrs = TO_W_(%INFO_NPTRS(info));
-    p = 0;
 
-    ALLOC_PRIM (SIZEOF_StgMutArrPtrs + WDS(ptrs), R1_PTR, closurePayloadzh_fast);
-    ptrs_arr = Hp - SIZEOF_StgMutArrPtrs - WDS(ptrs) + WDS(1);
+    // Some closures have non-standard layout, so we omit those here.
+    W_ type;
+    type = TO_W_(%INFO_TYPE(info));
+    switch [0 .. N_CLOSURE_TYPES] type {
+    case THUNK_SELECTOR : {
+        ptrs = 1;
+        nptrs = 0;
+        goto out;
+    }
+    case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, 
+         THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
+        ptrs = 0;
+        nptrs = 0;
+        goto out;
+    }
+    default: {
+        goto out;
+    }}
+out:
+
+    W_ ptrs_arr_sz, nptrs_arr_sz;
+    nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
+    ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs);
+
+    ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
+
+    ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
+    nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
+
     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+    p = 0;
 for:
     if(p < ptrs) {
         W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
@@ -1911,8 +1926,6 @@ for:
         goto for;
     }
     
-    ALLOC_PRIM (SIZEOF_StgArrWords + WDS(nptrs), R1_PTR, closurePayloadzh_fast);
-    nptrs_arr = Hp - SIZEOF_StgArrWords - WDS(nptrs) + WDS(1);
     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
     StgArrWords_words(nptrs_arr) = nptrs;
     p = 0;
@@ -1922,7 +1935,7 @@ for2:
         p = p + 1;
         goto for2;
     }
-    RET_PP(ptrs_arr, nptrs_arr);
+    RET_NPP(info, ptrs_arr, nptrs_arr);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2149,3 +2162,16 @@ noDuplicatezh_fast
         jump %ENTRY_CODE(Sp(0));
     }
 }
+
+getApStackValzh_fast
+{
+   W_ ap_stack, offset, val;
+
+   /* args: R1 = tso, R2 = offset */
+   ap_stack = R1;
+   offset   = R2;
+
+   val = StgClosure_payload(ap_stack,offset); 
+
+   RET_P(val);
+}
index 6da32fc..28cdd0d 100644 (file)
@@ -136,6 +136,7 @@ printClosure( StgClosure *obj )
     case CONSTR_NOCAF_STATIC:
         {
             StgWord i, j;
+
 #ifdef PROFILING
            debugBelch("%s(", info->prof.closure_desc);
            debugBelch("%s", obj->header.prof.ccs->cc->label);
@@ -1105,6 +1106,88 @@ findPtr(P_ p, int follow)
   }
 }
 
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+   names found in the info tables. Closures are printed in a fashion that resembles
+   their Haskell representation. Useful during debugging.
+
+   Todo: support for more closure types, and support for non pointer fields in the
+   payload.
+*/ 
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+   prettyPrintClosure_ (obj);
+   debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+    StgInfoTable *info;
+    StgConInfoTable *con_info;
+
+    /* collapse any indirections */
+    unsigned int type;
+    type = get_itbl(obj)->type;
+           
+    while (type == IND ||
+           type == IND_STATIC ||
+           type == IND_OLDGEN ||
+           type == IND_PERM ||
+           type == IND_OLDGEN_PERM) 
+    {
+      obj = ((StgInd *)obj)->indirectee;
+      type = get_itbl(obj)->type;
+    }
+
+    /* find the info table for this object */
+    info = get_itbl(obj);
+
+    /* determine what kind of object we have */
+    switch (info->type) 
+    {
+        /* full applications of data constructors */
+        case CONSTR:
+        case CONSTR_1_0: 
+        case CONSTR_0_1:
+        case CONSTR_1_1: 
+        case CONSTR_0_2: 
+        case CONSTR_2_0:
+        case CONSTR_STATIC:
+        case CONSTR_NOCAF_STATIC: 
+        {
+           int i; 
+           char *descriptor;
+
+           /* find the con_info for the constructor */
+           con_info = get_con_itbl (obj);
+
+           /* obtain the name of the constructor */
+           descriptor = con_info->con_desc;
+
+           debugBelch ("(%s", descriptor);
+
+           /* process the payload of the closure */
+           /* we don't handle non pointers at the moment */
+           for (i = 0; i < info->layout.payload.ptrs; i++)
+           {
+              debugBelch (" ");
+              prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+           }
+           debugBelch (")");
+           break;
+        }
+
+        /* if it isn't a constructor then just print the closure type */
+        default:
+        {
+           debugBelch ("<%s>", info_type(obj));
+           break;
+        }
+    }
+}
+
 #else /* DEBUG */
 void printPtr( StgPtr p )
 {
@@ -1115,4 +1198,6 @@ void printObj( StgClosure *obj )
 {
     debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
 }
+
+
 #endif /* DEBUG */
index 54bf611..689c2f8 100644 (file)
@@ -13,6 +13,7 @@ extern void              printPtr        ( StgPtr p );
 extern void       printObj        ( StgClosure *obj );
 
 #ifdef DEBUG
+extern void        prettyPrintClosure (StgClosure *obj);
 extern void       printClosure    ( StgClosure *obj );
 extern StgStackPtr printStackObj   ( StgStackPtr sp );
 extern void        printStackChunk ( StgStackPtr sp, StgStackPtr spLim );