From 367b0590cc0d8ba3d1561c85b366a183b8a71d24 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 24 Apr 2007 11:32:02 +0000 Subject: [PATCH 1/1] 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. --- compiler/deSugar/Coverage.lhs | 170 +++++++++++++++++++++++++---------------- compiler/deSugar/DsArrows.lhs | 4 +- compiler/deSugar/DsExpr.lhs | 17 ++--- compiler/deSugar/DsGRHSs.lhs | 15 +--- compiler/deSugar/DsMonad.lhs | 19 +---- compiler/deSugar/DsUtils.lhs | 17 ++--- compiler/hsSyn/HsBinds.lhs | 2 +- compiler/hsSyn/HsExpr.lhs | 5 +- compiler/main/GHC.hs | 56 +++++++++----- compiler/main/HscTypes.lhs | 3 + 10 files changed, 171 insertions(+), 137 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 5fb1fa5..74e0c7d 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 -- 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 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index e5b2b55..fc2432d 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -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) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index d09196d..4163559 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -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) diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 07907bd..4f1065e 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -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} diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index ac6a0c0..577a0d8 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -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} - diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 3c56567..62284db 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -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) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 41bbea9..f2da8bf 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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; diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 2be1ee6..7759885 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 2a2f5c1..c440eb4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1101e86..99495fe 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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]) + -- An array giving the names of the free variables at each breakpoint. } emptyModBreaks :: ModBreaks @@ -1260,5 +1262,6 @@ emptyModBreaks = ModBreaks { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" -- Todo: can we avoid this? , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] } \end{code} -- 1.7.10.4