GHC.Base.breakpoint isn't vaporware anymore.

-fignore-breakpoints can be used to ignore breakpoints.

ghc/compiler/Makefile

@@ -406,7 +406,7 @@ endif
 ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
 
 # Yes, include the interepreter, readline, and Template Haskell extensions
-SRC_HC_OPTS += -DGHCI -package template-haskell
+SRC_HC_OPTS += -DGHCI -DBREAKPOINT -package template-haskell
 PKG_DEPENDS += template-haskell
 
 # Use threaded RTS with GHCi, so threads don't get blocked at the prompt.

ghc/compiler/basicTypes/MkId.lhs

@@ -30,7 +30,9 @@ module MkId (
 	mkRuntimeErrorApp,
 	rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
 	nON_EXHAUSTIVE_GUARDS_ERROR_ID,	nO_METHOD_BINDING_ERROR_ID,
-	pAT_ERROR_ID, eRROR_ID
+	pAT_ERROR_ID, eRROR_ID,
+
+        unsafeCoerceName
     ) where
 
 #include "HsVersions.h"

ghc/compiler/deSugar/DsExpr.lhs

@@ -7,6 +7,14 @@
 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 #include "HsVersions.h"
+#if defined(GHCI) && defined(BREAKPOINT)
+import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
+import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
+import IOEnv            ( ioToIOEnv )
+import PrelNames        ( breakpointJumpName )
+import TysWiredIn       ( unitTy )
+import TypeRep          ( Type(..) )
+#endif
 
 import Match		( matchWrapper, matchSinglePat, matchEquations )
 import MatchLit		( dsLit, dsOverLit )
@@ -204,6 +212,36 @@ dsExpr expr@(HsLam a_Match)
   = matchWrapper LambdaExpr a_Match	`thenDs` \ (binders, matching_code) ->
     returnDs (mkLams binders matching_code)
 
+#if defined(GHCI) && defined(BREAKPOINT)
+dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
+    | HsVar funId <- fun
+    , idName funId == breakpointJumpName
+    , ids <- filter (not.hasTyVar.idType) (extractIds arg)
+    = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+         stablePtr <- ioToIOEnv $ newStablePtr ids
+         -- Yes, I know... I'm gonna burn in hell.
+         let Ptr addr# = castStablePtrToPtr stablePtr
+         funCore <- dsLExpr realFun
+         argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
+         hvalCore <- dsLExpr (L loc (extractHVals ids))
+         return ((funCore `App` argCore) `App` hvalCore)
+    where extractIds :: HsExpr Id -> [Id]
+          extractIds (HsApp fn arg)
+              | HsVar argId <- unLoc arg
+              = argId:extractIds (unLoc fn)
+              | TyApp arg' ts <- unLoc arg
+              , HsVar argId <- unLoc arg'
+              = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+          extractIds x = []
+          extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
+          hasTyVar (TyVarTy _) = True
+          hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
+          hasTyVar (NoteTy _ t) = hasTyVar t
+          hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
+          hasTyVar (TyConApp _ ts) = any hasTyVar ts
+          hasTyVar _ = False
+#endif
+
 dsExpr expr@(HsApp fun arg)      
   = dsLExpr fun		`thenDs` \ core_fun ->
     dsLExpr arg		`thenDs` \ core_arg ->

ghc/compiler/ghci/InteractiveUI.hs

@@ -13,6 +13,22 @@ module InteractiveUI (
 
 #include "HsVersions.h"
 
+#if defined(GHCI) && defined(BREAKPOINT)
+import GHC.Exts         ( Int(..), Ptr(..), int2Addr# )
+import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
+import System.IO.Unsafe ( unsafePerformIO )
+import Var              ( Id, globaliseId, idName, idType )
+import HscTypes         ( Session(..), InteractiveContext(..), HscEnv(..)
+                        , extendTypeEnvWithIds )
+import RdrName          ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
+import NameEnv          ( delListFromNameEnv )
+import TcType           ( tidyTopType )
+import qualified Id     ( setIdType )
+import IdInfo           ( GlobalIdDetails(..) )
+import Linker           ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker  )
+import PrelNames        ( breakpointJumpName )
+#endif
+
 -- The GHC interface
 import qualified GHC
 import GHC		( Session, verbosity, dopt, DynFlag(..), Target(..),
@@ -176,9 +192,67 @@ helpText =
  "                         (eg. -v2, -fglasgow-exts, etc.)\n"
 
 
+#if defined(GHCI) && defined(BREAKPOINT)
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+  = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
+  where
+    tidy_type = tidyTopType (idType id)
+
+
+printScopeMsg :: Session -> String -> [Id] -> IO ()
+printScopeMsg session location ids
+    = GHC.getPrintUnqual session >>= \unqual ->
+      printForUser stdout unqual $
+        text "Local bindings in scope:" $$
+        nest 2 (pprWithCommas showId ids)
+    where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
+jumpFunction session@(Session ref) (I# idsPtr) hValues location b
+    = unsafePerformIO $
+      do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+         let names = map idName ids
+         ASSERT (length names == length hValues) return ()
+         printScopeMsg session location ids
+         hsc_env <- readIORef ref
+
+         let ictxt = hsc_IC hsc_env
+             global_ids = map globaliseAndTidy ids
+             rn_env   = ic_rn_local_env ictxt
+             type_env = ic_type_env ictxt
+             bound_names = map idName global_ids
+             new_rn_env  = extendLocalRdrEnv rn_env bound_names
+		-- Remove any shadowed bindings from the type_env;
+		-- they are inaccessible but might, I suppose, cause 
+		-- a space leak if we leave them there
+             shadowed = [ n | name <- bound_names,
+                          let rdr_name = mkRdrUnqual (nameOccName name),
+                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+             filtered_type_env = delListFromNameEnv type_env shadowed
+             new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
+             new_ic = ictxt { ic_rn_local_env = new_rn_env, 
+		  	      ic_type_env     = new_type_env }
+         writeIORef ref (hsc_env { hsc_IC = new_ic })
+         withExtendedLinkEnv (zip names hValues) $
+           startGHCi (runGHCi [] Nothing)
+                     GHCiState{ progname = "<interactive>",
+                                args = [],
+                                prompt = location++"> ",
+                                session = session,
+                                options = [] }
+         writeIORef ref hsc_env
+         putStrLn $ "Returning to normal execution..."
+         return b
+#endif
+
 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 interactiveUI session srcs maybe_expr = do
-
+#if defined(GHCI) && defined(BREAKPOINT)
+   initDynLinker =<< GHC.getSessionDynFlags session
+   extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
+#endif
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
@@ -756,6 +830,9 @@ afterLoad ok session = do
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
   setContextAfterLoad session graph'
   modulesLoadedMsg ok (map GHC.ms_mod graph')
+#if defined(GHCI) && defined(BREAKPOINT)
+  io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
+#endif
 
 setContextAfterLoad session [] = do
   io (GHC.setContext session [] [prelude_mod])

ghc/compiler/ghci/Linker.lhs

@@ -16,9 +16,9 @@ necessary.
 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
 
 module Linker ( HValue, showLinkerState,
-		linkExpr, unload, extendLinkEnv,
+		linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
                 extendLoadedPkgs,
-		linkPackages,
+		linkPackages,initDynLinker
 	) where
 
 #include "HsVersions.h"
@@ -54,7 +54,7 @@ import Data.List	( partition, nub )
 import System.IO	( putStr, putStrLn, hPutStrLn, stderr, fixIO )
 import System.Directory	( doesFileExist )
 
-import Control.Exception ( block, throwDyn )
+import Control.Exception ( block, throwDyn, bracket )
 import Maybe		( isJust, fromJust )
 
 #if __GLASGOW_HASKELL__ >= 503
@@ -137,6 +137,18 @@ extendLinkEnv new_bindings
 	    new_pls = pls { closure_env = new_closure_env }
 	writeIORef v_PersistentLinkerState new_pls
 
+withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+withExtendedLinkEnv new_env action
+    = bracket set_new_env
+              reset_old_env
+              (const action)
+    where set_new_env = do pls <- readIORef v_PersistentLinkerState
+                           let new_closure_env = extendClosureEnv (closure_env pls) new_env
+                               new_pls = pls { closure_env = new_closure_env }
+                           writeIORef v_PersistentLinkerState new_pls
+                           return pls
+          reset_old_env pls = writeIORef v_PersistentLinkerState pls
+
 -- filterNameMap removes from the environment all entries except 
 -- 	those for a given set of modules;
 -- Note that this removes all *local* (i.e. non-isExternal) names too 

ghc/compiler/main/DynFlags.hs

@@ -164,6 +164,7 @@ data DynFlag
    | Opt_OmitInterfacePragmas
    | Opt_DoLambdaEtaExpansion
    | Opt_IgnoreAsserts
+   | Opt_IgnoreBreakpoints
    | Opt_DoEtaReduction
    | Opt_CaseMerge
    | Opt_UnboxStrictFields
@@ -995,6 +996,7 @@ fFlags = [
   ( "omit-interface-pragmas",		Opt_OmitInterfacePragmas ),
   ( "do-lambda-eta-expansion",		Opt_DoLambdaEtaExpansion ),
   ( "ignore-asserts",			Opt_IgnoreAsserts ),
+  ( "ignore-breakpoints",               Opt_IgnoreBreakpoints),
   ( "do-eta-reduction",			Opt_DoEtaReduction ),
   ( "case-merge",			Opt_CaseMerge ),
   ( "unbox-strict-fields",		Opt_UnboxStrictFields ),

ghc/compiler/prelude/PrelNames.lhs

@@ -186,7 +186,8 @@ basicKnownKeyNames
 	-- Others
 	otherwiseIdName, 
 	plusIntegerName, timesIntegerName,
-	eqStringName, assertName, assertErrorName, runSTRepName,
+	eqStringName, assertName, breakpointName, assertErrorName,
+        runSTRepName,
 	printName, fstName, sndName,
 
 	-- MonadFix
@@ -470,14 +471,20 @@ returnMName	   = methName monadClassName FSLIT("return") returnMClassOpKey
 failMName	   = methName monadClassName FSLIT("fail")   failMClassOpKey
 
 -- Random PrelBase functions
-otherwiseIdName   = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey
-foldrName	  = varQual pREL_BASE FSLIT("foldr")     foldrIdKey
-buildName	  = varQual pREL_BASE FSLIT("build")     buildIdKey
-augmentName	  = varQual pREL_BASE FSLIT("augment")   augmentIdKey
-appendName	  = varQual pREL_BASE FSLIT("++")        appendIdKey
-andName		  = varQual pREL_BASE FSLIT("&&")	 andIdKey
-orName		  = varQual pREL_BASE FSLIT("||")	 orIdKey
-assertName        = varQual pREL_BASE FSLIT("assert")    assertIdKey
+otherwiseIdName   = varQual pREL_BASE FSLIT("otherwise")  otherwiseIdKey
+foldrName	  = varQual pREL_BASE FSLIT("foldr")      foldrIdKey
+buildName	  = varQual pREL_BASE FSLIT("build")      buildIdKey
+augmentName	  = varQual pREL_BASE FSLIT("augment")    augmentIdKey
+appendName	  = varQual pREL_BASE FSLIT("++")         appendIdKey
+andName		  = varQual pREL_BASE FSLIT("&&")	  andIdKey
+orName		  = varQual pREL_BASE FSLIT("||")	  orIdKey
+assertName        = varQual pREL_BASE FSLIT("assert")     assertIdKey
+breakpointName    = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey
+breakpointJumpName
+    = mkInternalName
+        breakpointJumpIdKey
+        (mkOccNameFS varName FSLIT("breakpointJump"))
+        noSrcLoc
 
 -- PrelTup
 fstName		  = varQual pREL_TUP FSLIT("fst") fstIdKey
@@ -902,6 +909,9 @@ thenIOIdKey		      = mkPreludeMiscIdUnique 59
 lazyIdKey		      = mkPreludeMiscIdUnique 60
 assertErrorIdKey	      = mkPreludeMiscIdUnique 61
 
+breakpointIdKey               = mkPreludeMiscIdUnique 62
+breakpointJumpIdKey           = mkPreludeMiscIdUnique 63
+
 -- Parallel array functions
 nullPIdKey	              = mkPreludeMiscIdUnique 80
 lengthPIdKey		      = mkPreludeMiscIdUnique 81

ghc/compiler/rename/RnExpr.lhs

@@ -33,6 +33,13 @@ import BasicTypes	( FixityDirection(..) )
 import PrelNames	( thFAKE, hasKey, assertIdKey, assertErrorName,
 			  loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
 			  negateName, thenMName, bindMName, failMName )
+#if defined(GHCI) && defined(BREAKPOINT)
+import PrelNames        ( breakpointJumpName, undefined_RDR, breakpointIdKey )
+import UniqFM           ( eltsUFM )
+import DynFlags         ( GhcMode(..) )
+import SrcLoc           ( srcSpanFile, srcSpanStartLine )
+import Name             ( isTyVarName )
+#endif
 import Name		( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
 import RdrName		( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
@@ -87,18 +94,31 @@ rnLExpr = wrapLocFstM rnExpr
 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 
 rnExpr (HsVar v)
-  = lookupOccRn v	`thenM` \ name ->
-    doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
-    if name `hasKey` assertIdKey && not ignore_asserts then
-	-- We expand it to (GHC.Err.assertError location_string)
-        mkAssertErrorExpr	`thenM` \ (e, fvs) ->
-	returnM (e, fvs `addOneFV` name)
-		-- Keep 'assert' as a free var, to ensure it's not reported as unused!
-    else
-        -- The normal case.  Even if the Id was 'assert', if we are 
-	-- ignoring assertions we leave it as GHC.Base.assert; 
-	-- this function just ignores its first arg.
-       returnM (HsVar name, unitFV name)
+  = do name           <- lookupOccRn v
+       localRdrEnv    <- getLocalRdrEnv
+       lclEnv         <- getLclEnv
+       ignore_asserts <- doptM Opt_IgnoreAsserts
+       ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
+       let conds = [ (name `hasKey` assertIdKey
+                      && not ignore_asserts,
+                      do (e, fvs) <- mkAssertErrorExpr
+                         return (e, fvs `addOneFV` name))
+#if defined(GHCI) && defined(BREAKPOINT)
+                   , (name `hasKey` breakpointIdKey
+                      && not ignore_breakpoints,
+                      do ghcMode <- getGhcMode
+                         case ghcMode of
+                           Interactive
+                               -> do let isWantedName = not.isTyVarName
+                                     (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv))
+                                     return (e, fvs `addOneFV` name)
+                           _ -> return (HsVar name, unitFV name)
+                     )
+#endif
+                   ]
+       case lookup True conds of
+         Just action -> action
+         Nothing     -> return (HsVar name, unitFV name)
 
 rnExpr (HsIPVar v)
   = newIPNameRn v		`thenM` \ name ->
@@ -913,6 +933,32 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
 				-- The ones needed after the RecStmt
 \end{code}
 
+%************************************************************************
+%*									*
+\subsubsection{breakpoint utils}
+%*									*
+%************************************************************************
+
+\begin{code}
+#if defined(GHCI) && defined(BREAKPOINT)
+mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakPointExpr scope
+    = do sloc <- getSrcSpanM
+         undef <- lookupOccRn undefined_RDR
+         let inLoc = L sloc
+             lHsApp x y = inLoc (HsApp x y)
+             mkExpr fnName args = mkExpr' fnName (reverse args)
+             mkExpr' fnName [] = inLoc (HsVar fnName)
+             mkExpr' fnName (arg:args)
+                 = lHsApp (mkExpr' fnName args) (inLoc arg)
+             expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg]
+             mkScopeArg args
+                 = unLoc $ mkExpr undef (map HsVar args)
+             msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))
+         return (expr, emptyFVs)
+#endif
+\end{code}
+
 %************************************************************************
 %*									*
 \subsubsection{Assertion utils}

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -66,7 +66,7 @@ import Var		( Var )
 import Module           ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
 import OccName		( mkVarOccFS )
 import Name		( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
-			  mkExternalName )
+			  mkExternalName, isInternalName )
 import NameSet
 import TyCon		( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
 import SrcLoc		( srcLocSpan, Located(..), noLoc )
@@ -1253,6 +1253,7 @@ loadUnqualIfaces ictxt
     unqual_mods = [ nameModule name
 		  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
 		    let name = gre_name gre,
+                    not (isInternalName name),
 		    isTcOcc (nameOccName name),  -- Types and classes only
 		    unQualOK gre ]		 -- In scope unqualified
     doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")

ghc/compiler/typecheck/TcRnMonad.lhs

@@ -10,6 +10,17 @@ module TcRnMonad(
 import TcRnTypes	-- Re-export all
 import IOEnv		-- Re-export all
 
+#if defined(GHCI) && defined(BREAKPOINT)
+import TypeRep          ( Type(..), liftedTypeKind, TyThing(..) )
+import Var              ( mkTyVar, mkGlobalId )
+import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
+import OccName          ( mkOccName, tvName )
+import SrcLoc           ( noSrcLoc  )
+import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy )
+import PrelNames        ( breakpointJumpName )
+import NameEnv          ( mkNameEnv )
+#endif
+
 import HsSyn		( emptyLHsBinds )
 import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
 			  TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
@@ -81,7 +92,6 @@ initTc hsc_env hsc_src mod do_this
 	keep_var     <- newIORef emptyNameSet ;
 	th_var	     <- newIORef False ;
 	dfun_n_var   <- newIORef 1 ;
-
       	let {
 	     gbl_env = TcGblEnv {
 		tcg_mod      = mod,
@@ -124,10 +134,30 @@ initTc hsc_env hsc_src mod do_this
    
 	-- OK, here's the business end!
 	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
-			     do { r <- tryM do_this 
-				; case r of
-				    Right res -> return (Just res)
-				    Left _    -> return Nothing } ;
+		     do {
+#if defined(GHCI) && defined(BREAKPOINT)
+                          unique <- newUnique ;
+                          let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
+                                tyvar = mkTyVar var liftedTypeKind;
+                                breakpointJumpType = mkGlobalId
+                                                     (VanillaGlobal)
+                                                     (breakpointJumpName)
+                                                     (FunTy intTy
+                                                      (FunTy (mkListTy unitTy)
+                                                       (FunTy stringTy
+                                                        (ForAllTy tyvar
+                                                         (FunTy (TyVarTy tyvar)
+                                                          (TyVarTy tyvar))))))
+                                                     (vanillaIdInfo);
+                                new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+                              };
+                          r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
+#else
+                          r <- tryM do_this
+#endif
+			; case r of
+			  Right res -> return (Just res)
+			  Left _    -> return Nothing } ;
 
 	-- Collect any error messages
 	msgs <- readIORef errs_var ;