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

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 71248e4..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
+        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 []
@@ -70,21 +73,24 @@ mkBreakpointExpr loc bkptFuncId = do
            -- Yes, I know... I'm gonna burn in hell.
             Ptr addr# = castStablePtrToPtr stablePtr
             locals    = ExplicitList opaqueTy (map wrapInOpaque scope)
-            locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
-                              , HsLit (HsString mod_name)
+            locInfo = nlTuple [ HsVar mod_name_ref
                               , HsLit (HsInt (fromIntegral site))]
             funE  = l$ HsVar jumpFuncId
-            ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
-            locsE = l locals
-            locE  = l locInfo
-            msgE  = l (srcSpanLit loc)
-        return $  
-            l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `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
           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
@@ -135,14 +141,12 @@ 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
@@ -162,9 +166,10 @@ debug_enabled = do
 breakpoints_enabled = do
     ghcMode            <- getGhcModeDs
     currentModule      <- getModuleDs
+    dflags             <- getDOptsDs
     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
     return ( not ignore_breakpoints 
-          && ghcMode == Interactive 
+          && hscTarget dflags == HscInterpreted
           && currentModule /= iNTERACTIVE )
 
 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do