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
568e6b65
Commit
568e6b65
authored
Apr 25, 2007
by
Simon Marlow
Browse files
remember the type of _result
parent
b5986072
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/ByteCodeGen.lhs
View file @
568e6b65
...
...
@@ -298,6 +298,7 @@ schemeER_wrk d p rhs
{ breakInfo_module = tickInfo_module tickInfo
, breakInfo_number = tickNumber
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo
return $ breakInstr `consOL` code
...
...
compiler/ghci/ByteCodeInstr.lhs
View file @
568e6b65
...
...
@@ -13,6 +13,7 @@ module ByteCodeInstr (
import ByteCodeItbls ( ItblPtr )
import Type
import Outputable
import Name
import Id
...
...
@@ -141,13 +142,15 @@ data BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: Int
, breakInfo_vars :: [(Id,Int)]
, breakInfo_resty :: Type
}
instance Outputable BreakInfo where
ppr info = text "BreakInfo" <+>
parens (ppr (breakInfo_module info) <+>
ppr (breakInfo_number info) <+>
ppr (breakInfo_vars info))
ppr (breakInfo_vars info) <+>
ppr (breakInfo_resty info))
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
...
...
compiler/main/GHC.hs
View file @
568e6b65
...
...
@@ -2207,9 +2207,12 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
hsc_env
<-
readIORef
ref
mod_info
<-
getHomeModuleInfo
hsc_env
(
moduleName
(
breakInfo_module
info
))
let
breaks
=
minf_modBreaks
(
expectJust
"handlRunStatus"
mod_info
)
let
occs
=
modBreaks_vars
breaks
!
breakInfo_number
info
(
new_hsc_env
,
names
)
<-
extendEnvironment
hsc_env
apStack
(
breakInfo_vars
info
)
occs
let
index
=
breakInfo_number
info
occs
=
modBreaks_vars
breaks
!
index
span
=
modBreaks_locs
breaks
!
index
(
new_hsc_env
,
names
)
<-
extendEnvironment
hsc_env
apStack
span
(
breakInfo_vars
info
)
(
breakInfo_resty
info
)
occs
writeIORef
ref
new_hsc_env
let
res
=
ResumeHandle
breakMVar
statusMVar
final_names
final_ic
resume_ic
names
...
...
@@ -2315,31 +2318,33 @@ getIdValFromApStack apStack (identifier, stackDepth) = do
extendEnvironment
::
HscEnv
->
a
-- the AP_STACK object built by the interpreter
->
SrcSpan
->
[(
Id
,
Int
)]
-- free variables and offsets into the AP_STACK
->
Type
->
[
OccName
]
-- names for the variables (from the source code)
->
IO
(
HscEnv
,
[
Name
])
extendEnvironment
hsc_env
apStack
idsOffsets
occs
=
do
extendEnvironment
hsc_env
apStack
span
idsOffsets
result_ty
occs
=
do
idsVals
<-
mapM
(
getIdValFromApStack
apStack
)
idsOffsets
let
(
ids
,
hValues
)
=
unzip
idsVals
new_ids
<-
zipWithM
mkNewId
occs
ids
let
names
=
map
idName
ids
let
tyvars
=
varSetElems
(
tyVarsOfTypes
(
map
idType
new_ids
))
new_tyvars
=
map
mk_skol
tyvars
new_tyvar_tys
=
map
mkTyVarTy
new_tyvars
mk_skol
tyvar
=
mkTcTyVar
(
tyVarName
tyvar
)
(
tyVarKind
tyvar
)
(
SkolemTv
UnkSkol
)
subst
=
mkTvSubst
emptyInScopeSet
(
mkVarEnv
(
zip
tyvars
new_tyvar_tys
))
subst_id
id
=
id
`
setIdType
`
substTy
subst
(
idType
id
)
subst_ids
=
map
subst_id
new_ids
Just
(
ATyCon
unknown_tc
)
<-
tcRnLookupName
hsc_env
unknownTyConName
let
result_name
=
mkSystemVarName
(
mkBuiltinUnique
33
)
FSLIT
(
"_result"
)
result_id
=
Id
.
mkLocalId
result_name
(
mkTyConApp
unknown_tc
[]
)
-- make an Id for _result. We use the Unique of the FastString "_result";
-- we don't care about uniqueness here, because there will only be one
-- _result in scope at any time.
let
result_fs
=
FSLIT
(
"_result"
)
result_name
=
mkInternalName
(
getUnique
result_fs
)
(
mkVarOccFS
result_fs
)
(
srcSpanStart
span
)
result_id
=
Id
.
mkLocalId
result_name
result_ty
let
all_ids
=
result_id
:
ids
(
id_tys
,
tyvarss
)
=
mapAndUnzip
(
skolemiseTy
.
idType
)
all_ids
new_tyvars
=
unionVarSets
tyvarss
new_ids
=
zipWith
setIdType
all_ids
id_tys
let
ictxt
=
hsc_IC
hsc_env
type_env
=
ic_type_env
ictxt
all_new_ids
=
result_id
:
subst_ids
bound_names
=
map
idName
all_new_ids
bound_names
=
map
idName
new_ids
-- Remove any shadowed bindings from the type_env;
-- they are inaccessible but might, I suppose, cause
-- a space leak if we leave them there
...
...
@@ -2348,10 +2353,10 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
n
<-
old_bound_names
,
nameOccName
name
==
nameOccName
n
]
;
filtered_type_env
=
delListFromNameEnv
type_env
shadowed
new_type_env
=
extendTypeEnvWithIds
filtered_type_env
all_
new_ids
new_type_env
=
extendTypeEnvWithIds
filtered_type_env
new_ids
old_tyvars
=
ic_tyvars
ictxt
new_ic
=
ictxt
{
ic_type_env
=
new_type_env
,
ic_tyvars
=
extendVarSetList
old_tyvars
new_tyvars
}
ic_tyvars
=
old_tyvars
`
unionVarSet
`
new_tyvars
}
Linker
.
extendLinkEnv
(
zip
names
hValues
)
Linker
.
extendLinkEnv
[(
result_name
,
unsafeCoerce
#
apStack
)]
return
(
hsc_env
{
hsc_IC
=
new_ic
},
result_name
:
names
)
...
...
@@ -2365,6 +2370,18 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
new_id
=
Id
.
mkGlobalId
VanillaGlobal
name
ty
(
idInfo
id
)
return
new_id
skolemiseTy
::
Type
->
(
Type
,
TyVarSet
)
skolemiseTy
ty
=
(
substTy
subst
ty
,
mkVarSet
new_tyvars
)
where
env
=
mkVarEnv
(
zip
tyvars
new_tyvar_tys
)
subst
=
mkTvSubst
emptyInScopeSet
env
tyvars
=
varSetElems
(
tyVarsOfType
ty
)
new_tyvars
=
map
skolemiseTyVar
tyvars
new_tyvar_tys
=
map
mkTyVarTy
new_tyvars
skolemiseTyVar
::
TyVar
->
TyVar
skolemiseTyVar
tyvar
=
mkTcTyVar
(
tyVarName
tyvar
)
(
tyVarKind
tyvar
)
(
SkolemTv
UnkSkol
)
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
...
...
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