X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=c6a090e2301d8ebb4eb8e35b866df75d6da74489;hp=799e8b6a6822a361c5b1fd4d22df7d8306af7a02;hb=dc8ffcb9797ade3e3a68e6ec0a89fe2e7444e0ef;hpb=0125dc2632c30589829c7a911ea392902f67e4d2

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 799e8b6..c6a090e 100644
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -7,8 +7,8 @@
 -----------------------------------------------------------------------------
 
 \begin{code}
-module DsBreakpoint( 
-                     dsAndThenMaybeInsertBreakpoint
+module DsBreakpoint( debug_enabled
+                   , dsAndThenMaybeInsertBreakpoint
                    , maybeInsertBreakpoint
                    , breakpoints_enabled
                    , mkBreakpointExpr
@@ -18,7 +18,6 @@ import TysPrim
 import TysWiredIn
 import PrelNames        
 import Module
-import PackageConfig
 import SrcLoc
 import TyCon
 import TypeRep
@@ -39,6 +38,7 @@ import Outputable
 import ErrUtils
 import FastString
 import DynFlags
+import MkId
  
 import DsMonad 
 import {-#SOURCE#-}DsExpr ( dsLExpr ) 
@@ -46,21 +46,24 @@ import Control.Monad
 import Data.IORef
 import Foreign.StablePtr
 import GHC.Exts
+
 #ifdef GHCI
-mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
-mkBreakpointExpr loc bkptFuncId = do
+mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
+mkBreakpointExpr loc bkptFuncId ty = do
         scope <- getScope
         mod   <- getModuleDs
-        let mod_name = moduleNameFS$ moduleName mod
+        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 scope
-        site <- if instrumenting
-                   then recordBkpt (srcSpanStart loc)
-                   else return 0
+        stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
+        site      <- if instrumenting
+                        then recordBkpt (srcSpanStart loc)
+                        else return 0
         ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
-        jumpFuncId <- mkJumpFunc bkptFuncId
+        jumpFuncId         <- mkJumpFunc bkptFuncId
+        Just mod_name_ref  <- getModNameRefDs 
         let [opaqueDataCon] = tyConDataCons opaqueTyCon
             opaqueId = dataConWrapId opaqueDataCon
             opaqueTy = mkTyConApp opaqueTyCon []
@@ -69,23 +72,25 @@ 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)
-            locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
-                              , HsLit (HsString mod_name)
+            locals    = ExplicitList opaqueTy (map wrapInOpaque scope)
+            locInfo = nlTuple [ HsVar mod_name_ref
                               , HsLit (HsInt (fromIntegral site))]
             funE  = l$ HsVar jumpFuncId
-            ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
-            hvalE = l hvals
-            locE  = l locInfo
-            msgE  = l (srcSpanLit loc)
-        return $  
-            l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE)
+            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
---          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
+          mkTupleType tys = mkTupleTy Boxed (length tys) tys
 #else
 mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
 #endif
@@ -97,31 +102,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) = 
@@ -158,25 +141,37 @@ mkJumpFunc bkptFuncId
   where 
         tyvar = alphaTyVar
         basicType extra opaqueTy = 
-                           (FunTy intTy
-                            (FunTy (mkListTy opaqueTy)
-                             (FunTy (mkTupleType [stringTy, stringTy, intTy])
-                              (FunTy stringTy
+               (FunTy (mkTupleType [stringTy, intTy])
+                 (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
                           (ForAllTy tyvar
                                (extra
                                 (FunTy (TyVarTy tyvar)
-                                 (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
 
-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
+    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
@@ -198,17 +193,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}