X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=c714a5ea1cebff348d03fa75382e2a8bf78015c7;hb=8b08c15b8ace5a76e341939081fbb6ad2736ddd1;hp=1abfb0caba86228ec9b15d1397d908b89080717a;hpb=3a99fa889bdff0c86df20cb18c71d30e30a79b43;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 1abfb0c..c714a5e 100644
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -45,7 +45,7 @@ import CoreUtils        ( exprType )
 import Outputable
 import ErrUtils         ( debugTraceMsg )
 import FastString       ( mkFastString, unpackFS )
-import DynFlags         ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) )
+import DynFlags         ( GhcMode(..), DynFlag(..) )
  
 import DsMonad 
 import {-#SOURCE#-}DsExpr ( dsLExpr ) 
@@ -54,7 +54,6 @@ import Data.IORef
 import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
 import GHC.Exts         ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
 
-#if defined(GHCI)
 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
 mkBreakpointExpr loc bkptFuncId = do
         scope' <- getLocalBindsDs
@@ -104,6 +103,55 @@ mkBreakpointExpr loc bkptFuncId = do
           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
           instrumenting = idName bkptFuncId == breakpointAutoName
 
+debug_enabled :: DsM Bool
+#if defined(GHCI) && defined(DEBUGGER)
+debug_enabled = do
+    debugging      <- doptDs Opt_Debugging
+    b_enabled      <- breakpoints_enabled
+    return (debugging && b_enabled)
+#else
+debug_enabled = return False
+#endif
+
+maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
+--maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
+
+isInstrumentationSpot (L loc e) = do
+  ghcmode   <- getGhcModeDs
+  instrumenting <- debug_enabled 
+  return$ instrumenting     
+          && isGoodSrcSpan loc          -- Avoids 'derived' code
+          && (not$ isRedundant e)
+
+isRedundant HsLet  {} = True
+isRedundant HsDo   {} = True
+isRedundant HsCase {} = True
+isRedundant     _     = False
+
+dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
+dynBreakpoint loc | not (isGoodSrcSpan loc) = 
+                         pprPanic "dynBreakpoint" (ppr loc)
+dynBreakpoint loc = do 
+    let autoBreakpoint = 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 | trace "recordBkpt" False = undefined
+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 
@@ -129,5 +177,39 @@ mkJumpFunc bkptFuncId
                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 
+breakpoints_enabled :: DsM Bool
+dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
+
+#ifdef GHCI
+maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
+  instrumenting <- isInstrumentationSpot lhsexpr
+  if instrumenting
+         then do L _ dynBkpt <- dynBreakpoint loc 
+--                 return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
+                 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
+  if instrumenting
+         then do L _ dynBkpt<- dynBreakpoint loc
+                 bkptCore   <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
+                 return (bkptCore `App` coreExpr)
+         else return coreExpr
+  where l = L loc
+
+breakpoints_enabled = do
+    ghcMode            <- getGhcModeDs
+    currentModule      <- getModuleDs
+    ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
+    return ( not ignore_breakpoints 
+          && ghcMode == Interactive 
+          && currentModule /= iNTERACTIVE )
+#else
+maybeInsertBreakpoint expr _ = return expr
+dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
+breakpoints_enabled = return False
 #endif
 \end{code}