Commit 367b0590 authored by Simon Marlow's avatar Simon Marlow

Breakpoints: get the names of the free variables right

Previously we relied on the names of the Ids attached to a tick being
the same as the names of the original variables in the source code.
Sometimes this worked, sometimes it didn't because the simplifier
would inline away the Id.  So now we do this properly and retain the
original OccNames from the source code for each breakpoint, and use
these to construct the new Ids when we stop.

Doing this involved moving the tracking of in-scope variables from the
desugarer to the coverage pass.
parent cb429c8a
......@@ -63,7 +63,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
let (binds1,st)
= unTM (addTickLHsBinds binds)
$ TT { modName = mod_name
TickEnv { locals = emptyOccEnv }
TT { modName = mod_name
, declPath = []
, tickBoxCount = 0
, mixEntries = []
......@@ -77,18 +78,20 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
createDirectoryIfMissing True hpc_dir
modTime <- getModificationTime' orig_file
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop entries)
let entries' = [ (hpcPos, box)
| (span,_,box) <- entries, Just hpcPos <- [mkHpcPos span] ]
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop entries')
-- Todo: use proper src span type
breakArray <- newBreakArray $ length entries
let fn = mkFastString orig_file
let locsTicks = listArray (0,tickBoxCount st-1)
[ mkSrcSpan (mkSrcLoc fn r1 c1) (mkSrcLoc fn r2 c2)
| (P r1 c1 r2 c2, _box) <- entries ]
let modBreaks = emptyModBreaks
let locsTicks = listArray (0,tickBoxCount st-1)
[ span | (span,_,_) <- entries ]
varsTicks = listArray (0,tickBoxCount st-1)
[ vars | (_,vars,_) <- entries ]
modBreaks = emptyModBreaks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
......@@ -161,8 +164,7 @@ addTickLHsBind other = return other
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprAlways (L pos e0) = do
e1 <- addTickHsExpr e0
fn <- allocTickBox ExpBox pos
return $ fn $ L pos e1
allocTickBox ExpBox pos e1
addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrAlways e
......@@ -188,8 +190,7 @@ addTickLHsExpr (L pos e0) = do
e1 <- addTickHsExpr e0
if opt_Hpc || isGoodBreakExpr e0
then do
fn <- allocTickBox ExpBox pos
return $ fn $ L pos e1
allocTickBox ExpBox pos e1
else
return $ L pos e1
......@@ -211,8 +212,7 @@ addTickLHsExprOptAlt oneOfMany (L pos e0)
| not opt_Hpc = addTickLHsExpr (L pos e0)
| otherwise = do
e1 <- addTickHsExpr e0
fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
return $ fn $ L pos e1
allocTickBox (if oneOfMany then AltBox else ExpBox) pos e1
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addBinTickLHsExpr boxLabel (L pos e0) = do
......@@ -259,11 +259,12 @@ addTickHsExpr (HsIf e1 e2 e3) =
addTickHsExpr (HsLet binds e) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
(bindLocals (map unLoc $ collectLocalBinders binds) $
addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
liftM4 HsDo
(return cxt)
(mapM (liftL (addTickStmt forQual)) stmts)
(addTickLStmts forQual stmts)
(addTickLHsExpr last_exp)
(return srcloc)
where
......@@ -302,9 +303,8 @@ addTickHsExpr (ArithSeq ty arith_seq) =
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
e1 <- addTickHsExpr e0
fn <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos
let (L _ e2) = fn $ L pos e1
return $ e2
e2 <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos e1
return $ unLoc e2
addTickHsExpr (PArrSeq {}) = error "addTickHsExpr: PArrSeq"
addTickHsExpr (HsSCC {}) = error "addTickHsExpr: HsSCC"
addTickHsExpr (HsCoreAnn {}) = error "addTickHsExpr: HsCoreAnn"
......@@ -339,7 +339,7 @@ addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
addTickHsExpr (HsTick _ _ _) = error "addTickhsExpr: HsTick _ _"
addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
......@@ -347,56 +347,83 @@ addTickMatchGroup (MatchGroup matches ty) = do
return $ MatchGroup matches' ty
addTickMatch :: Bool -> Match Id -> TM (Match Id)
addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
gRHSs' <- addTickGRHSs isOneOfMany gRHSs
return $ Match pats opSig gRHSs'
addTickMatch isOneOfMany (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany gRHSs
return $ Match pats opSig gRHSs'
addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
local_binds' <- addTickHsLocalBinds local_binds
return $ GRHSs guarded' local_binds'
bindLocals binders $ do
guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
return $ GRHSs guarded' local_binds'
where
binders = map unLoc (collectLocalBinders local_binds)
addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS isOneOfMany (GRHS stmts expr) = do
stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
expr' <- if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
else addTickLHsExprAlways expr
(stmts',expr') <- addTickLStmts' (Just $ GuardBinBox) stmts []
(if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
else addTickLHsExprAlways expr)
return $ GRHS stmts' expr'
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt isGuard (BindStmt pat e bind fail) =
liftM4 BindStmt
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
(stmts',_) <- addTickLStmts' isGuard stmts [] (return ())
return stmts'
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id]
-> [LStmt Id] -> TM a -> TM ([LStmt Id], a)
addTickLStmts' isGuard [] acc do_rhs = do
rhs <- do_rhs
return (reverse acc, rhs)
addTickLStmts' isGuard (s:ss) acc do_rhs = do
(s', binders) <- addTickLStmt isGuard s
bindLocals binders $ addTickLStmts' isGuard ss (s':acc) do_rhs
addTickLStmt isGuard (L pos stmt) = do
(stmt',vars) <- addTickStmt isGuard stmt
return (L pos stmt', vars)
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id, [Id])
addTickStmt isGuard (BindStmt pat e bind fail) = do
e <- liftM4 BindStmt
(addTickLPat pat)
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) =
liftM3 ExprStmt
return (e, collectPatBinders pat)
addTickStmt isGuard (ExprStmt e bind' ty) = do
e <- liftM3 ExprStmt
(addTick e)
(addTickSyntaxExpr hpcSrcSpan bind')
(return ty)
return (e, [])
where
addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprAlways e
addTickStmt isGuard (LetStmt binds) =
liftM LetStmt
addTickStmt isGuard (LetStmt binds) = do
e <- liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs) =
liftM ParStmt (mapM process pairs)
return (e, map unLoc $ collectLocalBinders binds)
addTickStmt isGuard (ParStmt pairs) = do
e <- liftM ParStmt (mapM process pairs)
return (e, [])
where
process (stmts,ids) =
liftM2 (,)
(mapM (liftL (addTickStmt isGuard)) stmts)
(addTickLStmts isGuard stmts)
(return ids)
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
liftM5 RecStmt
(mapM (liftL (addTickStmt isGuard)) stmts)
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
e <- liftM5 RecStmt
(addTickLStmts isGuard stmts)
(return ids1)
(return ids2)
(return tys)
(addTickDictBinds dictbinds)
return (e,[])
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
......@@ -482,67 +509,77 @@ data TickTransState = TT { modName :: String
, declPath :: [String]
, tickBoxCount:: Int
, mixEntries :: [MixEntry]
}
deriving Show
-- deriving Show
data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
newtype TickEnv = TickEnv { locals :: OccEnv Id }
data TM a = TM { unTM :: TickEnv -> TickTransState -> (a,TickTransState) }
instance Monad TM where
return a = TM $ \ st -> (a,st)
(TM m) >>= k = TM $ \ st -> case m st of
(r1,st1) -> unTM (k r1) st1
return a = TM $ \ e st -> (a,st)
(TM m) >>= k = TM $ \ e st -> case m e st of
(r1,st1) -> unTM (k r1) e st1
--addTick :: LHsExpr Id -> TM (LHsExpr Id)
--addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
addPathEntry :: String -> TM a -> TM a
addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
addPathEntry nm (TM m) = TM $ \ e st -> case m e (st { declPath = declPath st ++ [nm] }) of
(r,st') -> (r,st' { declPath = declPath st })
getPathEntry :: TM [String]
getPathEntry = TM $ \ st -> (declPath st,st)
getPathEntry = TM $ \ e st -> (declPath st,st)
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ e st -> m e{locals = locals e `extendOccEnvList` occnamed_ids} st
where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
let me = (hpcPos,boxLabel)
allocTickBox :: BoxLabel -> SrcSpan -> HsExpr Id -> TM (LHsExpr Id)
allocTickBox boxLabel pos e | isGoodSrcSpan pos = TM $ \ env st ->
let me = (pos, map (nameOccName.idName) ids, boxLabel)
c = tickBoxCount st
mes = mixEntries st
in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
ids = occEnvElts (locals env)
in ( L pos (HsTick c ids (L pos e))
, st {tickBoxCount=c+1,mixEntries=me:mes}
)
allocTickBox boxLabel e = return id
allocTickBox boxLabel pos e = return (L pos e)
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
let me = (hpcPos,boxLabel)
allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe (Int,[Id]))
allocATickBox boxLabel pos | isGoodSrcSpan pos = TM $ \ env st ->
let me = (pos, map (nameOccName.idName) ids, boxLabel)
c = tickBoxCount st
mes = mixEntries st
in ( Just c
ids = occEnvElts (locals env)
in ( Just (c, ids)
, st {tickBoxCount=c+1,mixEntries=me:mes}
)
allocATickBox boxLabel e = return Nothing
allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
let meT = (hpcPos,boxLabel True)
meF = (hpcPos,boxLabel False)
meE = (hpcPos,ExpBox)
allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan pos = TM $ \ _ st ->
let meT = (pos,[],boxLabel True)
meF = (pos,[],boxLabel False)
meE = (pos,[],ExpBox)
c = tickBoxCount st
mes = mixEntries st
in
if opt_Hpc
then ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
then ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
, st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
)
else
( L pos $ HsTick c $ L pos e
( L pos $ HsTick c [] $ L pos e
, st {tickBoxCount=c+1,mixEntries=meE:mes}
)
......@@ -589,14 +626,15 @@ data Mix = Mix
FilePath -- location of original file
Integer -- time (in seconds) of original file's last update, since 1970.
Int -- tab stop value
[MixEntry] -- entries
deriving (Show,Read)
[MixEntry_] -- entries
deriving (Show, Read)
-- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
-- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
-- because if some other program also defined that instance, we will not be able to compile.
type MixEntry = (HpcPos, BoxLabel)
type MixEntry = (SrcSpan, [OccName], BoxLabel)
type MixEntry_ = (HpcPos, BoxLabel)
data BoxLabel = ExpBox
| AltBox
......
......@@ -587,9 +587,9 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
unionVarSets fv_sets)
dsCmd ids local_vars env_ids stack res_ty (HsTick ix expr)
dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
= dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
mkTickBox ix expr1 `thenDs` \ expr2 ->
mkTickBox ix vars expr1 `thenDs` \ expr2 ->
return (expr2,id_set)
-- A | ys |- c :: [ts] t (ys <= xs)
......
......@@ -279,8 +279,7 @@ dsExpr (HsCase discrim matches)
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body)
= (bindLocalsDs (map unLoc $ collectLocalBinders binds) $
dsLExpr body) `thenDs` \ body' ->
= dsLExpr body `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
......@@ -540,9 +539,9 @@ dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
Hpc Support
\begin{code}
dsExpr (HsTick ix e) = do
dsExpr (HsTick ix vars e) = do
e' <- dsLExpr e
mkTickBox ix e'
mkTickBox ix vars e'
-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
......@@ -591,16 +590,12 @@ dsDo stmts body result_ty
; returnDs (mkApps then_expr2 [rhs2, rest]) }
go (LetStmt binds : stmts)
= do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $
go stmts
= do { rest <- go stmts
; dsLocalBinds binds rest }
-- Notice how due to the placement of bindLocals, binders in this stmt
-- are available in posterior stmts but Not in this one rhs.
-- This is to avoid silliness in breakpoints
go (BindStmt pat rhs bind_op fail_op : stmts)
=
do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
do { body <- go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
......@@ -660,7 +655,7 @@ dsMDo tbl stmts body result_ty
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
= do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
= do { body <- go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
......
......@@ -57,21 +57,16 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext
-> GRHSs Id -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx pats grhssa@(GRHSs grhss binds) rhs_ty =
bindLocalsDs binders $ do
dsGRHSs hs_ctx pats grhssa@(GRHSs grhss binds) rhs_ty = do
match_results <- mappM (dsGRHS hs_ctx pats rhs_ty) grhss
let
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs
(\e -> bindLocalsDs patsBinders $
dsLocalBinds binds e)
(\e -> dsLocalBinds binds e)
match_result1
-- NB: nested dsLet inside matchResult
--
returnDs match_result2
where bindsBinders = map unLoc (collectLocalBinders binds)
patsBinders = collectPatsBinders (map (L undefined) pats)
binders = bindsBinders ++ patsBinders
dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
= matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
......@@ -117,8 +112,7 @@ matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
returnDs (mkGuardedMatchResult pred_expr match_result)
matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
= bindLocalsDs (map unLoc $ collectLocalBinders binds) $
matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
= matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
......@@ -126,8 +120,7 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
-- body expression in hand
matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
= bindLocalsDs (collectPatBinders pat) $
matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
= matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
dsLExpr bind_rhs `thenDs` \ core_rhs ->
matchSinglePat core_rhs ctx pat rhs_ty match_result
\end{code}
......
......@@ -23,7 +23,6 @@ module DsMonad (
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
bindLocalsDs, getLocalBindsDs,
-- Warnings
DsWarning, warnDs, failWithDs,
......@@ -141,8 +140,7 @@ data DsGblEnv = DsGblEnv {
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
ds_locals :: OccEnv Id -- For locals in breakpoints
ds_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- Inside [| |] brackets, the desugarer looks
......@@ -207,8 +205,7 @@ mkDsEnvs mod rdr_env type_env msg_var
ds_unqual = mkPrintUnqualified rdr_env,
ds_msgs = msg_var}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan,
ds_locals = emptyOccEnv }
ds_loc = noSrcSpan }
return (gbl_env, lcl_env)
......@@ -329,15 +326,3 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
\end{code}
\begin{code}
getLocalBindsDs :: DsM [Id]
getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
bindLocalsDs :: [Id] -> DsM a -> DsM a
bindLocalsDs new_ids enclosed_scope =
updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
enclosed_scope
where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
\end{code}
......@@ -936,12 +936,12 @@ mkFailurePair expr
\end{code}
\begin{code}
mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
mkOptTickBox Nothing e = return e
mkOptTickBox (Just ix) e = mkTickBox ix e
mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
mkTickBox ix e = do
mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
mkTickBox ix vars e = do
uq <- newUnique
mod <- getModuleDs
let tick | opt_Hpc = mkTickBoxOpId uq mod ix
......@@ -954,11 +954,10 @@ mkTickBox ix e = do
if opt_Hpc
then return (Var tick)
else do
locals <- getLocalBindsDs
let tickVar = Var tick
let tickType = mkFunTys (map idType locals) realWorldStatePrimTy
let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
let scrutApTy = App tickVar (Type tickType)
return (mkApps scrutApTy (map Var locals) :: Expr Id)
return (mkApps scrutApTy (map Var vars) :: Expr Id)
return $ Case scrut var ty [(DEFAULT,[],e)]
where
ty = exprType e
......@@ -969,8 +968,8 @@ mkBinaryTickBox ixT ixF e = do
uq <- newUnique
mod <- getModuleDs
let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
falseBox <- mkTickBox ixF $ Var falseDataConId
trueBox <- mkTickBox ixT $ Var trueDataConId
falseBox <- mkTickBox ixF [] $ Var falseDataConId
trueBox <- mkTickBox ixT [] $ Var trueDataConId
return $ Case e bndr1 boolTy
[ (DataAlt falseDataCon, [], falseBox)
, (DataAlt trueDataCon, [], trueBox)
......
......@@ -95,7 +95,7 @@ data HsBind id
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
fun_tick :: Maybe Int -- This is the (optional) module-local tick number.
fun_tick :: Maybe (Int,[id]) -- This is the (optional) module-local tick number.
}
| PatBind { -- The pattern is never a simple variable;
......
......@@ -228,6 +228,7 @@ data HsExpr id
| HsTick
Int -- module-local tick number
[id] -- variables in scope
(LHsExpr id) -- sub-expression
| HsBinTick
......@@ -410,8 +411,8 @@ ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
ppr_expr (HsTick tickId exp)
= hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
ppr_expr (HsTick tickId vars exp)
= hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), hsep (map pprHsVar vars), ppr exp,ptext SLIT(")")]
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
= hcat [ptext SLIT("bintick<"),
ppr tickIdTrue,
......
......@@ -255,7 +255,10 @@ import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
import PrelNames
import Unique
import Data.Array
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
import Data.Maybe
......@@ -2199,13 +2202,16 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
case status of
-- did we hit a breakpoint or did we complete?
(Break apStack info tid) -> do
hsc_env <- readIORef ref
(new_hsc_env, names) <- extendEnvironment hsc_env apStack
(breakInfo_vars info)
writeIORef ref new_hsc_env
let res = ResumeHandle breakMVar statusMVar final_names
final_ic resume_ic names
return (RunBreak tid names info res)
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
writeIORef ref new_hsc_env
let res = ResumeHandle breakMVar statusMVar final_names
final_ic resume_ic names
return (RunBreak tid names info res)
(Complete either_hvals) ->
case either_hvals of
Left e -> return (RunException e)
......@@ -2304,17 +2310,25 @@ getIdValFromApStack apStack (identifier, stackDepth) = do
freeStablePtr resultSptr
return (identifier, unsafeCoerce# result)
extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
extendEnvironment hsc_env apStack idsOffsets = do
extendEnvironment
:: HscEnv
-> a -- the AP_STACK object built by the interpreter
-> [(Id, Int)] -- free variables and offsets into the AP_STACK
-> [OccName] -- names for the variables (from the source code)
-> IO (HscEnv, [Name])
extendEnvironment hsc_env apStack idsOffsets occs = do
idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
let (ids, hValues) = unzip idsVals
new_ids <- zipWithM mkNewId occs ids
let names = map idName ids
let global_ids = map globaliseAndTidy ids
typed_ids <- return global_ids -- mapM instantiateIdType global_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 [])
let ictxt = hsc_IC hsc_env
rn_env = ic_rn_local_env ictxt
type_env = ic_type_env ictxt
bound_names = map idName typed_ids
all_new_ids = result_id : new_ids
bound_names = map idName all_new_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
......@@ -2323,16 +2337,22 @@ extendEnvironment hsc_env apStack idsOffsets = do
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 (typed_ids)
new_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
Linker.extendLinkEnv (zip names hValues)
return (hsc_env{hsc_IC = new_ic}, names)
Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
return (hsc_env{hsc_IC = new_ic}, result_name:names)
where
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
= let tidied_type = tidyTopType$ idType id
in setIdType (globaliseId VanillaGlobal id) tidied_type
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
ty <- instantiateTyVarsToUnknown hsc_env
let uniq = idUnique id
loc = nameSrcLoc (idName id)
name = mkInternalName uniq occ loc
ty = tidyTopType (idType id)
new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
return new_id
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
......
......@@ -1253,6 +1253,8 @@ data ModBreaks
-- indicating which breakpoints are enabled.
, modBreaks_locs :: !(Array BreakIndex SrcSpan)
-- An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakIndex [OccName])