X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=71248e48bf8a1b01107f069c6afbdf7111b6d792;hb=91388bb33e3f8d9baa926e54e0d1b1949f5fefa0;hp=1393a9df2be17b476a1f3ce5df4f3dc81e38da9d;hpb=402cb6db0de6e607d874328784bd43e747376dc1;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 1393a9d..71248e4 100644
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -14,7 +14,6 @@ module DsBreakpoint(
                    , mkBreakpointExpr
                    ) where
 
-import IOEnv
 import TysPrim
 import TysWiredIn
 import PrelNames        
@@ -25,9 +24,6 @@ import TyCon
 import TypeRep
 import DataCon          
 import Type             
-import MkId
-import Name
-import Var
 import Id 
 
 import IdInfo
@@ -50,7 +46,6 @@ import Control.Monad
 import Data.IORef
 import Foreign.StablePtr
 import GHC.Exts
-
 #ifdef GHCI
 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
 mkBreakpointExpr loc bkptFuncId = do
@@ -61,11 +56,11 @@ mkBreakpointExpr loc bkptFuncId = do
               warnDs (text "Extracted ids:" <+> (ppr scope $$ 
                                                    ppr (map idType scope)))
         stablePtr <- ioToIOEnv $ newStablePtr scope
-        site <- if instrumenting
-                   then recordBkpt (srcSpanStart loc)
-                   else return 0
+        site      <- if instrumenting
+                        then recordBkpt (srcSpanStart loc)
+                        else return 0
         ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
-        jumpFuncId <- mkJumpFunc bkptFuncId
+        jumpFuncId         <- mkJumpFunc bkptFuncId
         let [opaqueDataCon] = tyConDataCons opaqueTyCon
             opaqueId = dataConWrapId opaqueDataCon
             opaqueTy = mkTyConApp opaqueTyCon []
@@ -74,20 +69,19 @@ mkBreakpointExpr loc bkptFuncId = do
                           (l(HsVar id)))
            -- Yes, I know... I'm gonna burn in hell.
             Ptr addr# = castStablePtrToPtr stablePtr
-            hvals = ExplicitList opaqueTy (map wrapInOpaque scope)
+            locals    = ExplicitList opaqueTy (map wrapInOpaque scope)
             locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
                               , HsLit (HsString mod_name)
                               , HsLit (HsInt (fromIntegral site))]
             funE  = l$ HsVar jumpFuncId
             ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
-            hvalE = l hvals
+            locsE = l locals
             locE  = l locInfo
             msgE  = l (srcSpanLit loc)
         return $  
-            l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
+            l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE)        
     where l = L loc
           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
---          isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? 
           srcSpanLit :: SrcSpan -> HsExpr Id
           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
           instrumenting = idName bkptFuncId == breakpointAutoName
@@ -102,31 +96,9 @@ getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
           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
 
-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
-
-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
-
 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 #ifdef DEBUG
 dynBreakpoint loc | not (isGoodSrcSpan loc) = 
@@ -177,11 +149,24 @@ mkJumpFunc bkptFuncId
                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 
-breakpoints_enabled :: DsM Bool
+debug_enabled, breakpoints_enabled :: DsM Bool
 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
 maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 
-#ifdef GHCI
+#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
+    ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
+    return ( not ignore_breakpoints 
+          && ghcMode == Interactive 
+          && currentModule /= iNTERACTIVE )
+
 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
   instrumenting <- isInstrumentationSpot lhsexpr
   scope         <- getScope
@@ -203,17 +188,25 @@ dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
                  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
+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}