Comments only

[ghc-hetmet.git] / compiler / deSugar / DsBreakpoint.lhs

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index c714a5e..1d17c97 100644 (file)
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -14,46 +14,44 @@ module DsBreakpoint(
                    , mkBreakpointExpr
                    ) where
 
-import IOEnv            ( ioToIOEnv )
-import TysPrim          ( alphaTyVar )
-import TysWiredIn       ( intTy, stringTy, mkTupleTy, mkListTy, boolTy )
+import IOEnv
+import TysPrim
+import TysWiredIn
 import PrelNames        
-import Module           ( moduleName, moduleNameFS, modulePackageId )
-import PackageConfig    ( packageIdFS)
-import SrcLoc           ( SrcLoc, Located(..), SrcSpan, srcSpanFile,
-                          noLoc, noSrcLoc, isGoodSrcSpan,
-                          srcLocLine, srcLocCol, srcSpanStart )
-
-import TyCon            ( isUnLiftedTyCon, tyConDataCons )
-import TypeRep          ( Type(..) )
+import Module
+import PackageConfig
+import SrcLoc
+import TyCon
+import TypeRep
 import DataCon          
 import Type             
-import MkId             ( unsafeCoerceId, lazyId )
-import Name             ( Name, mkInternalName )
-import Var              ( mkTyVar )
-import Id               ( Id, idType, mkGlobalId, idName )
+import MkId
+import Name
+import Var
+import Id 
 
-import IdInfo           ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) )
-import BasicTypes       ( Boxity(Boxed) )
-import OccName          ( mkOccName, tvName )
+import IdInfo
+import BasicTypes
+import OccName
 
 import TcRnMonad
 import HsSyn            
-import HsLit            ( HsLit(HsString, HsInt) )
-import CoreSyn          ( CoreExpr, Expr (App) )
-import CoreUtils        ( exprType )
+import HsLit
+import CoreSyn
+import CoreUtils
 import Outputable
-import ErrUtils         ( debugTraceMsg )
-import FastString       ( mkFastString, unpackFS )
-import DynFlags         ( GhcMode(..), DynFlag(..) )
+import ErrUtils
+import FastString
+import DynFlags
  
 import DsMonad 
 import {-#SOURCE#-}DsExpr ( dsLExpr ) 
 import Control.Monad
 import Data.IORef
-import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
-import GHC.Exts         ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# )
+import Foreign.StablePtr
+import GHC.Exts
 
+#ifdef GHCI
 mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id)
 mkBreakpointExpr loc bkptFuncId = do
         scope' <- getLocalBindsDs
@@ -61,7 +59,8 @@ mkBreakpointExpr loc bkptFuncId = do
         let scope = filter (isValidType .idType ) scope'
             mod_name = moduleNameFS$ moduleName mod
         if null scope && instrumenting
-         then return (l$ HsVar lazyId) 
+           -- need to return some expresion, hence lazy is used here as a noop (hopefully)
+         then return (l$ HsVar lazyId)  
          else do
           when (not instrumenting) $
               warnDs (text "Extracted ids:" <+> (ppr scope $$ 
@@ -102,6 +101,9 @@ mkBreakpointExpr loc bkptFuncId = do
           srcSpanLit :: SrcSpan -> HsExpr Id
           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
           instrumenting = idName bkptFuncId == breakpointAutoName
+#else
+mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
+#endif
 
 debug_enabled :: DsM Bool
 #if defined(GHCI) && defined(DEBUGGER)
@@ -113,9 +115,6 @@ debug_enabled = do
 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 
@@ -125,14 +124,14 @@ isInstrumentationSpot (L loc e) = do
 
 isRedundant HsLet  {} = True
 isRedundant HsDo   {} = True
-isRedundant HsCase {} = True
+isRedundant HsCase {} = False
 isRedundant     _     = False
 
 dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
 dynBreakpoint loc | not (isGoodSrcSpan loc) = 
                          pprPanic "dynBreakpoint" (ppr loc)
 dynBreakpoint loc = do 
-    let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName 
+    let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName 
                          breakpointAutoTy vanillaIdInfo
     dflags <- getDOptsDs 
     ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
@@ -143,7 +142,6 @@ dynBreakpoint loc = do
 
 -- 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
@@ -173,19 +171,20 @@ mkJumpFunc bkptFuncId
                                  (TyVarTy tyvar))))))))
         build name extra  = do 
             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
-            return$ mkGlobalId VanillaGlobal name
+            return$ Id.mkGlobalId VanillaGlobal name
                       (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
         mkTupleType tys = mkTupleTy Boxed (length tys) tys
 
 breakpoints_enabled :: DsM Bool
 dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
+-- | Takes an expression and its type
+maybeInsertBreakpoint :: LHsExpr Id -> Type ->  DsM (LHsExpr Id)
 
 #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