Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
31751cca
Commit
31751cca
authored
Apr 06, 2006
by
David Himmelstrup
Browse files
GHC.Base.breakpoint isn't vaporware anymore.
-fignore-breakpoints can be used to ignore breakpoints.
parent
1494f895
Changes
10
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/Makefile
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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
View file @
31751cca
...
...
@@ -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 ;
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment