Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC

Commits:

28 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -346,6 +346,7 @@ import GHC.Driver.Errors
    346 346 
     import GHC.Driver.Errors.Types
    347 347 
     import GHC.Driver.CmdLine
    348 348 
     import GHC.Driver.Session
    349 
    +import GHC.Driver.Session.Inspect
    349 350 
     import GHC.Driver.Backend
    350 351 
     import GHC.Driver.Config.Finder (initFinderOpts)
    351 352 
     import GHC.Driver.Config.Parser (initParserOpts)
    ... ... @@ -378,7 +379,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
    378 379 
     import GHC.Data.StringBuffer
    379 380 
     import GHC.Data.FastString
    380 381 
     import qualified GHC.LanguageExtensions as LangExt
    381 
    -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
    382 
    +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
    382 383
    383 384 
     import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
    384 385 
     import GHC.Tc.Types
    ... ... @@ -425,14 +426,12 @@ import GHC.Types.Target
    425 426 
     import GHC.Types.Basic
    426 427 
     import GHC.Types.TyThing
    427 428 
     import GHC.Types.Name.Env
    428 
    -import GHC.Types.Name.Ppr
    429 429 
     import GHC.Types.TypeEnv
    430 430 
     import GHC.Types.Breakpoint
    431 431 
     import GHC.Types.PkgQual
    432 432
    433 433 
     import GHC.Unit
    434 434 
     import GHC.Unit.Env as UnitEnv
    435 
    -import GHC.Unit.External
    436 435 
     import GHC.Unit.Finder
    437 436 
     import GHC.Unit.Module.ModIface
    438 437 
     import GHC.Unit.Module.ModGuts
    ... ... @@ -1570,169 +1569,6 @@ compileCore simplify fn = do
    1570 1569 
               cm_safe    = safe_mode
    1571 1570 
              }
    1572 1571
    1573 
    --- %************************************************************************
    1574 
    --- %*                                                                      *
    1575 
    ---             Inspecting the session
    1576 
    --- %*                                                                      *
    1577 
    --- %************************************************************************
    1578 
    -
    1579 
    --- | Get the module dependency graph.
    1580 
    -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
    1581 
    -getModuleGraph = liftM hsc_mod_graph getSession
    1582 
    -
    1583 
    -{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}
    1584 
    --- | Return @True@ \<==> module is loaded.
    1585 
    -isLoaded :: GhcMonad m => ModuleName -> m Bool
    1586 
    -isLoaded m = withSession $ \hsc_env -> liftIO $ do
    1587 
    -  hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m
    1588 
    -  return $! not (null hmis)
    1589 
    -
    1590 
    --- | Check whether a 'ModuleName' is found in the 'HomePackageTable'
    1591 
    --- for the given 'UnitId'.
    1592 
    -isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
    1593 
    -isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do
    1594 
    -  hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m
    1595 
    -  return $! isJust hmi
    1596 
    -
    1597 
    --- | Check whether 'Module' is part of the 'HomeUnitGraph'.
    1598 
    ---
    1599 
    --- Similar to 'isLoadedModule', but for 'Module's.
    1600 
    -isLoadedHomeModule :: GhcMonad m => Module -> m Bool
    1601 
    -isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do
    1602 
    -  hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)
    1603 
    -  return $! isJust hmi
    1604 
    -
    1605 
    --- | Return the bindings for the current interactive session.
    1606 
    -getBindings :: GhcMonad m => m [TyThing]
    1607 
    -getBindings = withSession $ \hsc_env ->
    1608 
    -    return $ icInScopeTTs $ hsc_IC hsc_env
    1609 
    -
    1610 
    --- | Return the instances for the current interactive session.
    1611 
    -getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
    1612 
    -getInsts = withSession $ \hsc_env ->
    1613 
    -    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)
    1614 
    -    in return (instEnvElts inst_env, fam_env)
    1615 
    -
    1616 
    -getNamePprCtx :: GhcMonad m => m NamePprCtx
    1617 
    -getNamePprCtx = withSession $ \hsc_env -> do
    1618 
    -  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
    1619 
    -
    1620 
    --- | Container for information about a 'Module'.
    1621 
    -data ModuleInfo = ModuleInfo {
    1622 
    -        minf_type_env  :: TypeEnv,
    1623 
    -        minf_exports   :: [AvailInfo],
    1624 
    -        minf_instances :: [ClsInst],
    1625 
    -        minf_iface     :: Maybe ModIface,
    1626 
    -        minf_safe      :: SafeHaskellMode,
    1627 
    -        minf_modBreaks :: Maybe ModBreaks
    1628 
    -  }
    1629 
    -        -- We don't want HomeModInfo here, because a ModuleInfo applies
    1630 
    -        -- to package modules too.
    1631 
    -
    1632 
    -
    1633 
    --- | Request information about a loaded 'Module'
    1634 
    -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
    1635 
    -getModuleInfo mdl = withSession $ \hsc_env -> do
    1636 
    -  if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)
    1637 
    -        then liftIO $ getHomeModuleInfo hsc_env mdl
    1638 
    -        else liftIO $ getPackageModuleInfo hsc_env mdl
    1639 
    -
    1640 
    -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
    1641 
    -getPackageModuleInfo hsc_env mdl
    1642 
    -  = do  eps <- hscEPS hsc_env
    1643 
    -        iface <- hscGetModuleInterface hsc_env mdl
    1644 
    -        let
    1645 
    -            avails = mi_exports iface
    1646 
    -            pte    = eps_PTE eps
    1647 
    -            tys    = [ ty | name <- concatMap availNames avails,
    1648 
    -                            Just ty <- [lookupTypeEnv pte name] ]
    1649 
    -
    1650 
    -        return (Just (ModuleInfo {
    1651 
    -                        minf_type_env  = mkTypeEnv tys,
    1652 
    -                        minf_exports   = avails,
    1653 
    -                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
    1654 
    -                        minf_iface     = Just iface,
    1655 
    -                        minf_safe      = getSafeMode $ mi_trust iface,
    1656 
    -                        minf_modBreaks = Nothing
    1657 
    -                }))
    1658 
    -
    1659 
    -availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
    1660 
    -availsToGlobalRdrEnv hsc_env mod avails
    1661 
    -  = forceGlobalRdrEnv rdr_env
    1662 
    -    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.
    1663 
    -  where
    1664 
    -    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)
    1665 
    -      -- We're building a GlobalRdrEnv as if the user imported
    1666 
    -      -- all the specified modules into the global interactive module
    1667 
    -    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
    1668 
    -    decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,
    1669 
    -                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,
    1670 
    -                         is_dloc = srcLocSpan interactiveSrcLoc,
    1671 
    -                         is_level = NormalLevel }
    1672 
    -
    1673 
    -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
    1674 
    -getHomeModuleInfo hsc_env mdl =
    1675 
    -  HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case
    1676 
    -    Nothing  -> return Nothing
    1677 
    -    Just hmi -> do
    1678 
    -      let details  = hm_details hmi
    1679 
    -          iface    = hm_iface hmi
    1680 
    -      return (Just (ModuleInfo {
    1681 
    -                        minf_type_env  = md_types details,
    1682 
    -                        minf_exports   = md_exports details,
    1683 
    -                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.
    1684 
    -                        minf_instances = instEnvElts $ md_insts details,
    1685 
    -                        minf_iface     = Just iface,
    1686 
    -                        minf_safe      = getSafeMode $ mi_trust iface
    1687 
    -                       ,minf_modBreaks = getModBreaks hmi
    1688 
    -                        }))
    1689 
    -
    1690 
    --- | The list of top-level entities defined in a module
    1691 
    -modInfoTyThings :: ModuleInfo -> [TyThing]
    1692 
    -modInfoTyThings minf = typeEnvElts (minf_type_env minf)
    1693 
    -
    1694 
    -modInfoExports :: ModuleInfo -> [Name]
    1695 
    -modInfoExports minf = concatMap availNames $! minf_exports minf
    1696 
    -
    1697 
    -modInfoExportsWithSelectors :: ModuleInfo -> [Name]
    1698 
    -modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf
    1699 
    -
    1700 
    --- | Returns the instances defined by the specified module.
    1701 
    --- Warning: currently unimplemented for package modules.
    1702 
    -modInfoInstances :: ModuleInfo -> [ClsInst]
    1703 
    -modInfoInstances = minf_instances
    1704 
    -
    1705 
    -modInfoIsExportedName :: ModuleInfo -> Name -> Bool
    1706 
    -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
    1707 
    -
    1708 
    -mkNamePprCtxForModule ::
    1709 
    -  GhcMonad m =>
    1710 
    -  Module     ->
    1711 
    -  ModuleInfo ->
    1712 
    -  m NamePprCtx
    1713 
    -mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
    1714 
    -  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
    1715 
    -      ptc = initPromotionTickContext (hsc_dflags hsc_env)
    1716 
    -  return name_ppr_ctx
    1717 
    -
    1718 
    -modInfoLookupName :: GhcMonad m =>
    1719 
    -                     ModuleInfo -> Name
    1720 
    -                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
    1721 
    -modInfoLookupName minf name = withSession $ \hsc_env -> do
    1722 
    -   case lookupTypeEnv (minf_type_env minf) name of
    1723 
    -     Just tyThing -> return (Just tyThing)
    1724 
    -     Nothing      -> liftIO (lookupType hsc_env name)
    1725 
    -
    1726 
    -modInfoIface :: ModuleInfo -> Maybe ModIface
    1727 
    -modInfoIface = minf_iface
    1728 
    -
    1729 
    --- | Retrieve module safe haskell mode
    1730 
    -modInfoSafe :: ModuleInfo -> SafeHaskellMode
    1731 
    -modInfoSafe = minf_safe
    1732 
    -
    1733 
    -modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks
    1734 
    -modInfoModBreaks = minf_modBreaks
    1735 
    -
    1736 1572 
     isDictonaryId :: Id -> Bool
    1737 1573 
     isDictonaryId id = isDictTy (idType id)
    1738 1574
    ... ... @@ -2063,7 +1899,7 @@ getGHCiMonad :: GhcMonad m => m Name
    2063 1899 
     getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
    2064 1900
    2065 1901 
     getHistorySpan :: GhcMonad m => History -> m SrcSpan
    2066 
    -getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan hsc_env h
    1902 
    +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h
    2067 1903
    2068 1904 
     obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
    2069 1905 
     obtainTermFromVal bound force ty a = withSession $ \hsc_env ->

  • compiler/GHC/Core/FVs.hs
    ... ... @@ -287,7 +287,7 @@ exprs_fvs :: [CoreExpr] -> FV
    287 287 
     exprs_fvs exprs = mapUnionFV expr_fvs exprs
    288 288
    289 289 
     tickish_fvs :: CoreTickish -> FV
    290 
    -tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids
    290 
    +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids
    291 291 
     tickish_fvs _ = emptyFV
    292 292
    293 293 
     {- **********************************************************************
    ... ... @@ -759,8 +759,8 @@ freeVars = go
    759 759 
             , AnnTick tickish expr2 )
    760 760 
           where
    761 761 
             expr2 = go expr
    762 
    -        tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids
    763 
    -        tickishFVs _                      = emptyDVarSet
    762 
    +        tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids
    763 
    +        tickishFVs _                    = emptyDVarSet
    764 764
    765 765 
         go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)
    766 766 
         go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)

  • compiler/GHC/Core/Lint.hs
    ... ... @@ -897,8 +897,8 @@ lintCoreExpr (Cast expr co)
    897 897
    898 898 
     lintCoreExpr (Tick tickish expr)
    899 899 
       = do { case tickish of
    900 
    -           Breakpoint _ _ ids _ -> forM_ ids $ \id -> lintIdOcc id 0
    901 
    -           _                    -> return ()
    900 
    +           Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0
    901 
    +           _                  -> return ()
    902 902 
            ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }
    903 903 
       where
    904 904 
         block_joins = not (tickish `tickishScopesLike` SoftScope)

  • compiler/GHC/Core/Map/Expr.hs
    ... ... @@ -198,11 +198,10 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where
    198 198
    199 199 
     eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool
    200 200 
     eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where
    201 
    -    go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)
    201 
    +    go (Breakpoint lext lid lids) (Breakpoint rext rid rids)
    202 202 
             =  lid == rid
    203 203 
             && D env1 lids == D env2 rids
    204 204 
             && lext == rext
    205 
    -        && lmod == rmod
    206 205 
         go l r = l == r
    207 206
    208 207 
     -- Compares for equality, modulo alpha

  • compiler/GHC/Core/Opt/OccurAnal.hs
    ... ... @@ -2501,7 +2501,7 @@ occAnal env (Tick tickish body)
    2501 2501 
           -- For a non-soft tick scope, we can inline lambdas only, so we
    2502 2502 
           -- abandon tail calls, and do markAllInsideLam too: usage_lam
    2503 2503
    2504 
    -      |  Breakpoint _ _ ids _ <- tickish
    2504 
    +      | Breakpoint _ _ ids <- tickish
    2505 2505 
           = -- Never substitute for any of the Ids in a Breakpoint
    2506 2506 
             addManyOccs usage_lam (mkVarSet ids)
    2507 2507

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -1461,8 +1461,8 @@ simplTick env tickish expr cont
    1461 1461
    1462 1462
    1463 1463 
       simplTickish env tickish
    1464 
    -    | Breakpoint ext n ids modl <- tickish
    1465 
    -          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl
    1464 
    +    | Breakpoint ext bid ids <- tickish
    1465 
    +          = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids)
    1466 1466 
         | otherwise = tickish
    1467 1467
    1468 1468 
       -- Push type application and coercion inside a tick

  • compiler/GHC/Core/Ppr.hs
    ... ... @@ -31,6 +31,7 @@ import GHC.Prelude
    31 31
    32 32 
     import GHC.Core
    33 33 
     import GHC.Core.Stats (exprStats)
    34 
    +import GHC.Types.Breakpoint
    34 35 
     import GHC.Types.Fixity (LexicalFixity(..))
    35 36 
     import GHC.Types.Literal( pprLiteral )
    36 37 
     import GHC.Types.Name( pprInfixName, pprPrefixName )
    ... ... @@ -694,10 +695,10 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
    694 695 
                 ppr modl, comma,
    695 696 
                 ppr ix,
    696 697 
                 text ">"]
    697 
    -  ppr (Breakpoint _ext ix vars modl) =
    698 
    +  ppr (Breakpoint _ext bid vars) =
    698 699 
           hcat [text "break<",
    699 
    -            ppr modl, comma,
    700 
    -            ppr ix,
    700 
    +            ppr (bi_tick_mod bid), comma,
    701 
    +            ppr (bi_tick_index bid),
    701 702 
                 text ">",
    702 703 
                 parens (hcat (punctuate comma (map ppr vars)))]
    703 704 
       ppr (ProfNote { profNoteCC = cc,

  • compiler/GHC/Core/Subst.hs
    ... ... @@ -602,8 +602,8 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs
    602 602 
     ------------------
    603 603 
     -- | Drop free vars from the breakpoint if they have a non-variable substitution.
    604 604 
     substTickish :: Subst -> CoreTickish -> CoreTickish
    605 
    -substTickish subst (Breakpoint ext n ids modl)
    606 
    -   = Breakpoint ext n (mapMaybe do_one ids) modl
    605 
    +substTickish subst (Breakpoint ext bid ids)
    606 
    +   = Breakpoint ext bid (mapMaybe do_one ids)
    607 607 
      where
    608 608 
         do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst
    609 609

  • compiler/GHC/Core/Tidy.hs
    ... ... @@ -235,8 +235,8 @@ tidyAlt env (Alt con vs rhs)
    235 235
    236 236 
     ------------  Tickish  --------------
    237 237 
     tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
    238 
    -tidyTickish env (Breakpoint ext ix ids modl)
    239 
    -  = Breakpoint ext ix (map (tidyVarOcc env) ids) modl
    238 
    +tidyTickish env (Breakpoint ext bid ids)
    239 
    +  = Breakpoint ext bid (map (tidyVarOcc env) ids)
    240 240 
     tidyTickish _   other_tickish       = other_tickish
    241 241
    242 242 
     ------------  Rules  --------------

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -2492,11 +2492,10 @@ cheapEqExpr' ignoreTick e1 e2
    2492 2492
    2493 2493 
     -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots
    2494 2494 
     eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
    2495 
    -eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)
    2495 
    +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)
    2496 2496 
           = lid == rid &&
    2497 2497 
             map (rnOccL env) lids == map (rnOccR env) rids &&
    2498 
    -        lext == rext &&
    2499 
    -        lmod == rmod
    2498 
    +        lext == rext
    2500 2499 
     eqTickish _ l r = l == r
    2501 2500
    2502 2501 
     -- | Finds differences between core bindings, see @diffExpr@.

  • compiler/GHC/CoreToIface.hs
    ... ... @@ -586,8 +586,8 @@ toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push
    586 586 
     toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix
    587 587 
     toIfaceTickish (SourceNote src (LexicalFastString names)) =
    588 588 
       IfaceSource src names
    589 
    -toIfaceTickish (Breakpoint _ ix fv m) =
    590 
    -  IfaceBreakpoint ix (toIfaceVar <$> fv) m
    589 
    +toIfaceTickish (Breakpoint _ ix fv) =
    590 
    +  IfaceBreakpoint ix (toIfaceVar <$> fv)
    591 591
    592 592 
     ---------------------
    593 593 
     toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr

  • compiler/GHC/CoreToStg.hs
    ... ... @@ -643,10 +643,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument
    643 643 
     coreToStgTick :: Type -- type of the ticked expression
    644 644 
                   -> CoreTickish
    645 645 
                   -> StgTickish
    646 
    -coreToStgTick _ty (HpcTick m i)                = HpcTick m i
    647 
    -coreToStgTick _ty (SourceNote span nm)         = SourceNote span nm
    648 
    -coreToStgTick _ty (ProfNote cc cnt scope)      = ProfNote cc cnt scope
    649 
    -coreToStgTick !ty (Breakpoint _ bid fvs modl)  = Breakpoint ty bid fvs modl
    646 
    +coreToStgTick _ty (HpcTick m i)           = HpcTick m i
    647 
    +coreToStgTick _ty (SourceNote span nm)    = SourceNote span nm
    648 
    +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
    649 
    +coreToStgTick !ty (Breakpoint _ bid fvs)  = Breakpoint ty bid fvs
    650 650
    651 651 
     -- ---------------------------------------------------------------------------
    652 652 
     -- The magic for lets:

  • compiler/GHC/CoreToStg/Prep.hs
    ... ... @@ -842,9 +842,9 @@ cpeRhsE env (Tick tickish expr)
    842 842 
       = do { body <- cpeBodyNF env expr
    843 843 
            ; return (emptyFloats, mkTick tickish' body) }
    844 844 
       where
    845 
    -    tickish' | Breakpoint ext n fvs modl <- tickish
    845 
    +    tickish' | Breakpoint ext bid fvs <- tickish
    846 846 
                  -- See also 'substTickish'
    847 
    -             = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl
    847 
    +             = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
    848 848 
                  | otherwise
    849 849 
                  = tickish
    850 850

  • compiler/GHC/Driver/Session/Inspect.hs
    1 
    +{-# LANGUAGE LambdaCase #-}
    2 
    +
    3 
    +-- | GHC API utilities for inspecting the GHC session
    4 
    +module GHC.Driver.Session.Inspect where
    5 
    +
    6 
    +import GHC.Prelude
    7 
    +import GHC.Data.Maybe
    8 
    +import Control.Monad
    9 
    +
    10 
    +import GHC.ByteCode.Types
    11 
    +import GHC.Core.FamInstEnv
    12 
    +import GHC.Core.InstEnv
    13 
    +import GHC.Driver.Env
    14 
    +import GHC.Driver.Main
    15 
    +import GHC.Driver.Monad
    16 
    +import GHC.Driver.Session
    17 
    +import GHC.Rename.Names
    18 
    +import GHC.Runtime.Context
    19 
    +import GHC.Runtime.Interpreter
    20 
    +import GHC.Types.Avail
    21 
    +import GHC.Types.Name
    22 
    +import GHC.Types.Name.Ppr
    23 
    +import GHC.Types.Name.Reader
    24 
    +import GHC.Types.Name.Set
    25 
    +import GHC.Types.PkgQual
    26 
    +import GHC.Types.SafeHaskell
    27 
    +import GHC.Types.SrcLoc
    28 
    +import GHC.Types.TyThing
    29 
    +import GHC.Types.TypeEnv
    30 
    +import GHC.Unit.External
    31 
    +import GHC.Unit.Home.ModInfo
    32 
    +import GHC.Unit.Module
    33 
    +import GHC.Unit.Module.Graph
    34 
    +import GHC.Unit.Module.ModDetails
    35 
    +import GHC.Unit.Module.ModIface
    36 
    +import GHC.Utils.Misc
    37 
    +import GHC.Utils.Outputable
    38 
    +import qualified GHC.Unit.Home.Graph as HUG
    39 
    +
    40 
    +-- %************************************************************************
    41 
    +-- %*                                                                      *
    42 
    +--             Inspecting the session
    43 
    +-- %*                                                                      *
    44 
    +-- %************************************************************************
    45 
    +
    46 
    +-- | Get the module dependency graph.
    47 
    +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
    48 
    +getModuleGraph = liftM hsc_mod_graph getSession
    49 
    +
    50 
    +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}
    51 
    +-- | Return @True@ \<==> module is loaded.
    52 
    +isLoaded :: GhcMonad m => ModuleName -> m Bool
    53 
    +isLoaded m = withSession $ \hsc_env -> liftIO $ do
    54 
    +  hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m
    55 
    +  return $! not (null hmis)
    56 
    +
    57 
    +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'
    58 
    +-- for the given 'UnitId'.
    59 
    +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
    60 
    +isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do
    61 
    +  hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m
    62 
    +  return $! isJust hmi
    63 
    +
    64 
    +-- | Check whether 'Module' is part of the 'HomeUnitGraph'.
    65 
    +--
    66 
    +-- Similar to 'isLoadedModule', but for 'Module's.
    67 
    +isLoadedHomeModule :: GhcMonad m => Module -> m Bool
    68 
    +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do
    69 
    +  hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)
    70 
    +  return $! isJust hmi
    71 
    +
    72 
    +-- | Return the bindings for the current interactive session.
    73 
    +getBindings :: GhcMonad m => m [TyThing]
    74 
    +getBindings = withSession $ \hsc_env ->
    75 
    +    return $ icInScopeTTs $ hsc_IC hsc_env
    76 
    +
    77 
    +-- | Return the instances for the current interactive session.
    78 
    +getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
    79 
    +getInsts = withSession $ \hsc_env ->
    80 
    +    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)
    81 
    +    in return (instEnvElts inst_env, fam_env)
    82 
    +
    83 
    +getNamePprCtx :: GhcMonad m => m NamePprCtx
    84 
    +getNamePprCtx = withSession $ \hsc_env -> do
    85 
    +  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
    86 
    +
    87 
    +-- | Container for information about a 'Module'.
    88 
    +data ModuleInfo = ModuleInfo {
    89 
    +        minf_type_env  :: TypeEnv,
    90 
    +        minf_exports   :: [AvailInfo],
    91 
    +        minf_instances :: [ClsInst],
    92 
    +        minf_iface     :: Maybe ModIface,
    93 
    +        minf_safe      :: SafeHaskellMode,
    94 
    +        minf_modBreaks :: Maybe ModBreaks
    95 
    +  }
    96 
    +        -- We don't want HomeModInfo here, because a ModuleInfo applies
    97 
    +        -- to package modules too.
    98 
    +
    99 
    +-- | Request information about a loaded 'Module'
    100 
    +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
    101 
    +getModuleInfo mdl = withSession $ \hsc_env -> do
    102 
    +  if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)
    103 
    +        then liftIO $ getHomeModuleInfo hsc_env mdl
    104 
    +        else liftIO $ getPackageModuleInfo hsc_env mdl
    105 
    +
    106 
    +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
    107 
    +getPackageModuleInfo hsc_env mdl
    108 
    +  = do  eps <- hscEPS hsc_env
    109 
    +        iface <- hscGetModuleInterface hsc_env mdl
    110 
    +        let
    111 
    +            avails = mi_exports iface
    112 
    +            pte    = eps_PTE eps
    113 
    +            tys    = [ ty | name <- concatMap availNames avails,
    114 
    +                            Just ty <- [lookupTypeEnv pte name] ]
    115 
    +
    116 
    +        return (Just (ModuleInfo {
    117 
    +                        minf_type_env  = mkTypeEnv tys,
    118 
    +                        minf_exports   = avails,
    119 
    +                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
    120 
    +                        minf_iface     = Just iface,
    121 
    +                        minf_safe      = getSafeMode $ mi_trust iface,
    122 
    +                        minf_modBreaks = Nothing
    123 
    +                }))
    124 
    +
    125 
    +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
    126 
    +availsToGlobalRdrEnv hsc_env mod avails
    127 
    +  = forceGlobalRdrEnv rdr_env
    128 
    +    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.
    129 
    +  where
    130 
    +    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)
    131 
    +      -- We're building a GlobalRdrEnv as if the user imported
    132 
    +      -- all the specified modules into the global interactive module
    133 
    +    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
    134 
    +    decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,
    135 
    +                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,
    136 
    +                         is_dloc = srcLocSpan interactiveSrcLoc,
    137 
    +                         is_level = NormalLevel }
    138 
    +
    139 
    +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
    140 
    +getHomeModuleInfo hsc_env mdl =
    141 
    +  HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case
    142 
    +    Nothing  -> return Nothing
    143 
    +    Just hmi -> do
    144 
    +      let details  = hm_details hmi
    145 
    +          iface    = hm_iface hmi
    146 
    +      return (Just (ModuleInfo {
    147 
    +                        minf_type_env  = md_types details,
    148 
    +                        minf_exports   = md_exports details,
    149 
    +                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.
    150 
    +                        minf_instances = instEnvElts $ md_insts details,
    151 
    +                        minf_iface     = Just iface,
    152 
    +                        minf_safe      = getSafeMode $ mi_trust iface,
    153 
    +                        minf_modBreaks = getModBreaks hmi
    154 
    +                        }))
    155 
    +
    156 
    +-- | The list of top-level entities defined in a module
    157 
    +modInfoTyThings :: ModuleInfo -> [TyThing]
    158 
    +modInfoTyThings minf = typeEnvElts (minf_type_env minf)
    159 
    +
    160 
    +modInfoExports :: ModuleInfo -> [Name]
    161 
    +modInfoExports minf = concatMap availNames $! minf_exports minf
    162 
    +
    163 
    +modInfoExportsWithSelectors :: ModuleInfo -> [Name]
    164 
    +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf
    165 
    +
    166 
    +-- | Returns the instances defined by the specified module.
    167 
    +-- Warning: currently unimplemented for package modules.
    168 
    +modInfoInstances :: ModuleInfo -> [ClsInst]
    169 
    +modInfoInstances = minf_instances
    170 
    +
    171 
    +modInfoIsExportedName :: ModuleInfo -> Name -> Bool
    172 
    +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
    173 
    +
    174 
    +mkNamePprCtxForModule ::
    175 
    +  GhcMonad m =>
    176 
    +  Module     ->
    177 
    +  ModuleInfo ->
    178 
    +  m NamePprCtx
    179 
    +mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
    180 
    +  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
    181 
    +      ptc = initPromotionTickContext (hsc_dflags hsc_env)
    182 
    +  return name_ppr_ctx
    183 
    +
    184 
    +modInfoLookupName :: GhcMonad m =>
    185 
    +                     ModuleInfo -> Name
    186 
    +                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
    187 
    +modInfoLookupName minf name = withSession $ \hsc_env -> do
    188 
    +   case lookupTypeEnv (minf_type_env minf) name of
    189 
    +     Just tyThing -> return (Just tyThing)
    190 
    +     Nothing      -> liftIO (lookupType hsc_env name)
    191 
    +
    192 
    +modInfoIface :: ModuleInfo -> Maybe ModIface
    193 
    +modInfoIface = minf_iface
    194 
    +
    195 
    +-- | Retrieve module safe haskell mode
    196 
    +modInfoSafe :: ModuleInfo -> SafeHaskellMode
    197 
    +modInfoSafe = minf_safe
    198 
    +
    199 
    +modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks
    200 
    +modInfoModBreaks = minf_modBreaks
    201 
    +

  • compiler/GHC/HsToCore/Ticks.hs
    ... ... @@ -35,6 +35,7 @@ import GHC.Driver.Flags (DumpFlag(..))
    35 35 
     import GHC.Utils.Outputable as Outputable
    36 36 
     import GHC.Utils.Panic
    37 37 
     import GHC.Utils.Logger
    38 
    +import GHC.Types.Breakpoint
    38 39 
     import GHC.Types.SrcLoc
    39 40 
     import GHC.Types.Basic
    40 41 
     import GHC.Types.Id
    ... ... @@ -1235,7 +1236,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
    1235 1236
    1236 1237 
         Breakpoints -> do
    1237 1238 
           i <- addMixEntry me
    1238 
    -      pure (Breakpoint noExtField i ids (this_mod env))
    1239 
    +      pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids)
    1239 1240
    1240 1241 
         SourceNotes | RealSrcSpan pos' _ <- pos ->
    1241 1242 
           return $ SourceNote pos' $ LexicalFastString cc_name

  • compiler/GHC/Iface/Syntax.hs
    ... ... @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
    56 56
    57 57 
     import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,
    58 58 
                                constraintKindTyConKey )
    59 
    +import GHC.Types.Breakpoint
    59 60 
     import GHC.Types.Unique ( hasKey )
    60 61 
     import GHC.Iface.Type
    61 62 
     import GHC.Iface.Recomp.Binary
    ... ... @@ -699,7 +700,7 @@ data IfaceTickish
    699 700 
       = IfaceHpcTick    Module Int               -- from HpcTick x
    700 701 
       | IfaceSCC        CostCentre Bool Bool     -- from ProfNote
    701 702 
       | IfaceSource  RealSrcSpan FastString      -- from SourceNote
    702 
    -  | IfaceBreakpoint Int [IfaceExpr] Module   -- from Breakpoint
    703 
    +  | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint
    703 704
    704 705 
     data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr
    705 706 
             -- Note: IfLclName, not IfaceBndr (and same with the case binder)
    ... ... @@ -1848,7 +1849,7 @@ pprIfaceTickish (IfaceSCC cc tick scope)
    1848 1849 
       = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
    1849 1850 
     pprIfaceTickish (IfaceSource src _names)
    1850 1851 
       = braces (pprUserRealSpan True src)
    1851 
    -pprIfaceTickish (IfaceBreakpoint m ix fvs)
    1852 
    +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
    1852 1853 
       = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs)
    1853 1854
    1854 1855 
     ------------------
    ... ... @@ -2198,7 +2199,7 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
    2198 2199 
       = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
    2199 2200
    2200 2201 
     freeNamesIfTickish :: IfaceTickish -> NameSet
    2201 
    -freeNamesIfTickish (IfaceBreakpoint _ fvs _) =
    2202 
    +freeNamesIfTickish (IfaceBreakpoint _ fvs) =
    2202 2203 
       fnList freeNamesIfExpr fvs
    2203 2204 
     freeNamesIfTickish _ = emptyNameSet
    2204 2205
    ... ... @@ -2919,7 +2920,7 @@ instance Binary IfaceTickish where
    2919 2920 
             put_ bh (srcSpanEndLine src)
    2920 2921 
             put_ bh (srcSpanEndCol src)
    2921 2922 
             put_ bh name
    2922 
    -    put_ bh (IfaceBreakpoint m ix fvs) = do
    2923 
    +    put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do
    2923 2924 
             putByte bh 3
    2924 2925 
             put_ bh m
    2925 2926 
             put_ bh ix
    ... ... @@ -2947,7 +2948,7 @@ instance Binary IfaceTickish where
    2947 2948 
                 3 -> do m <- get bh
    2948 2949 
                         ix <- get bh
    2949 2950 
                         fvs <- get bh
    2950 
    -                    return (IfaceBreakpoint m ix fvs)
    2951 
    +                    return (IfaceBreakpoint (BreakpointId m ix) fvs)
    2951 2952 
                 _ -> panic ("get IfaceTickish " ++ show h)
    2952 2953
    2953 2954 
     instance Binary IfaceConAlt where
    ... ... @@ -3206,7 +3207,7 @@ instance NFData IfaceTickish where
    3206 3207 
         IfaceHpcTick m i -> rnf m `seq` rnf i
    3207 3208 
         IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2
    3208 3209 
         IfaceSource src str -> rnf src `seq` rnf str
    3209 
    -    IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs
    3210 
    +    IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs
    3210 3211
    3211 3212 
     instance NFData IfaceConAlt where
    3212 3213 
       rnf = \case

  • compiler/GHC/Iface/Tidy.hs
    ... ... @@ -955,7 +955,7 @@ dffvExpr :: CoreExpr -> DFFV ()
    955 955 
     dffvExpr (Var v)              = insert v
    956 956 
     dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
    957 957 
     dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
    958 
    -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e
    958 
    +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e
    959 959 
     dffvExpr (Tick _other e)    = dffvExpr e
    960 960 
     dffvExpr (Cast e _)           = dffvExpr e
    961 961 
     dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)

  • compiler/GHC/IfaceToCore.hs
    ... ... @@ -1732,9 +1732,9 @@ tcIfaceTickish :: IfaceTickish -> IfL CoreTickish
    1732 1732 
     tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
    1733 1733 
     tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
    1734 1734 
     tcIfaceTickish (IfaceSource src name)   = return (SourceNote src (LexicalFastString name))
    1735 
    -tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do
    1735 
    +tcIfaceTickish (IfaceBreakpoint bid fvs) = do
    1736 1736 
       fvs' <- mapM tcIfaceExpr fvs
    1737 
    -  return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl)
    1737 
    +  return (Breakpoint NoExtField bid [f | Var f <- fvs'])
    1738 1738
    1739 1739 
     -------------------------
    1740 1740 
     tcIfaceLit :: Literal -> IfL Literal

  • compiler/GHC/Runtime/Debugger/Breakpoints.hs
    1 
    +
    1 2 
     -- | GHC API debugger module for finding and setting breakpoints.
    2 3 
     --
    3 4 
     -- This module is user facing and is at least used by `GHCi` and `ghc-debugger`
    4 5 
     -- to find and set breakpoints.
    5 6 
     module GHC.Runtime.Debugger.Breakpoints where
    6 7
    8 
    +import GHC.Prelude
    9 
    +
    7 10 
     import Control.Monad.Catch
    8 11 
     import Control.Monad
    9 12 
     import Data.Array
    ... ... @@ -13,10 +16,18 @@ import Data.Maybe
    13 16 
     import qualified Data.List.NonEmpty as NE
    14 17 
     import qualified Data.Semigroup as S
    15 18
    16 
    -import GHC
    17 
    -import GHC.Prelude
    19 
    +import GHC.ByteCode.Types (BreakIndex, ModBreaks(..))
    20 
    +import GHC.Driver.Env
    21 
    +import GHC.Driver.Monad
    22 
    +import GHC.Driver.Session.Inspect
    23 
    +import GHC.Runtime.Eval
    18 24 
     import GHC.Runtime.Eval.Utils
    25 
    +import GHC.Types.Name
    19 26 
     import GHC.Types.SrcLoc
    27 
    +import GHC.Types.Breakpoint
    28 
    +import GHC.Unit.Module
    29 
    +import GHC.Unit.Module.Graph
    30 
    +import GHC.Unit.Module.ModSummary
    20 31 
     import GHC.Utils.Outputable
    21 32 
     import GHC.Utils.Panic
    22 33 
     import qualified GHC.Data.Strict as Strict
    ... ... @@ -44,10 +55,10 @@ findBreakByLine line arr
    44 55 
             ticks = arr ! line
    45 56
    46 57 
             starts_here = [ (ix,pan) | (ix, pan) <- ticks,
    47 
    -                        GHC.srcSpanStartLine pan == line ]
    58 
    +                        srcSpanStartLine pan == line ]
    48 59
    49 60 
             (comp, incomp) = partition ends_here starts_here
    50 
    -            where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
    61 
    +            where ends_here (_,pan) = srcSpanEndLine pan == line
    51 62
    52 63 
     -- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate.
    53 64 
     findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakIndex, RealSrcSpan)
    ... ... @@ -63,8 +74,8 @@ findBreakByCoord (line, col) arr
    63 74 
             contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ]
    64 75
    65 76 
             after_here = [ tick | tick@(_,pan) <- ticks,
    66 
    -                              GHC.srcSpanStartLine pan == line,
    67 
    -                              GHC.srcSpanStartCol pan >= col ]
    77 
    +                              srcSpanStartLine pan == line,
    78 
    +                              srcSpanStartCol pan >= col ]
    68 79
    69 80 
     leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
    70 81 
     leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd
    ... ... @@ -112,7 +123,7 @@ resolveFunctionBreakpoint inp = do
    112 123 
         Nothing -> do
    113 124 
           -- No errors found, go and return the module info
    114 125 
           let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod
    115 
    -      mb_mod_info  <- GHC.getModuleInfo mod
    126 
    +      mb_mod_info  <- getModuleInfo mod
    116 127 
           case mb_mod_info of
    117 128 
             Nothing -> pure . Left $
    118 129 
               text "Could not find ModuleInfo of " <> ppr mod
    ... ... @@ -120,16 +131,16 @@ resolveFunctionBreakpoint inp = do
    120 131 
       where
    121 132 
         -- Try to lookup the module for an identifier that is in scope.
    122 133 
         -- `parseName` throws an exception, if the identifier is not in scope
    123 
    -    lookupModuleInscope :: GHC.GhcMonad m => String -> m (Maybe Module)
    134 
    +    lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module)
    124 135 
         lookupModuleInscope mod_top_lvl = do
    125 
    -        names <- GHC.parseName mod_top_lvl
    126 
    -        pure $ Just $ NE.head $ GHC.nameModule <$> names
    136 
    +        names <- parseName mod_top_lvl
    137 
    +        pure $ Just $ NE.head $ nameModule <$> names
    127 138
    128 139 
         -- Lookup the Module of a module name in the module graph
    129 
    -    lookupModuleInGraph :: GHC.GhcMonad m => String -> m (Maybe Module)
    140 
    +    lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module)
    130 141 
         lookupModuleInGraph mod_str = do
    131 
    -        graph <- GHC.getModuleGraph
    132 
    -        let hmods = ms_mod <$> GHC.mgModSummaries graph
    142 
    +        graph <- getModuleGraph
    143 
    +        let hmods = ms_mod <$> mgModSummaries graph
    133 144 
             pure $ find ((== mod_str) . moduleNameString . moduleName) hmods
    134 145
    135 146 
         -- Check validity of an identifier to set a breakpoint:
    ... ... @@ -137,21 +148,21 @@ resolveFunctionBreakpoint inp = do
    137 148 
         --  2. the identifier must be in an interpreted module
    138 149 
         --  3. the ModBreaks array for module `mod` must have an entry
    139 150 
         --     for the function
    140 
    -    validateBP :: GHC.GhcMonad m => String -> String -> Maybe Module
    151 
    +    validateBP :: GhcMonad m => String -> String -> Maybe Module
    141 152 
                            -> m (Maybe SDoc)
    142 153 
         validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text
    143 154 
             (combineModIdent mod_str (takeWhile (/= '.') fun_str)))
    144 155 
             <+> text "not in scope"
    145 156 
         validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"
    146 157 
         validateBP _ fun_str (Just modl) = do
    147 
    -        isInterpr <- GHC.moduleIsInterpreted modl
    158 
    +        isInterpr <- moduleIsInterpreted modl
    148 159 
             mb_err_msg <- case isInterpr of
    149 160 
               False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted"
    150 161 
               True -> do
    151 162 
                 mb_modbreaks <- getModBreak modl
    152 163 
                 let found = case mb_modbreaks of
    153 164 
                       Nothing -> False
    154 
    -                  Just mb -> fun_str `elem` (intercalate "." <$> elems (GHC.modBreaks_decls mb))
    165 
    +                  Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb))
    155 166 
                 if found
    156 167 
                   then pure Nothing
    157 168 
                   else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str)
    ... ... @@ -163,13 +174,13 @@ resolveFunctionBreakpoint inp = do
    163 174 
     -- for
    164 175 
     --   (a) this binder only (it maybe a top-level or a nested declaration)
    165 176 
     --   (b) that do not have an enclosing breakpoint
    166 
    -findBreakForBind :: String {-^ Name of bind to break at -} -> GHC.ModBreaks -> [(BreakIndex, RealSrcSpan)]
    177 
    +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakIndex, RealSrcSpan)]
    167 178 
     findBreakForBind str_name modbreaks = filter (not . enclosed) ticks
    168 179 
       where
    169 180 
         ticks = [ (index, span)
    170 
    -            | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),
    181 
    +            | (index, decls) <- assocs (modBreaks_decls modbreaks),
    171 182 
                   str_name == intercalate "." decls,
    172 
    -              RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]
    183 
    +              RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ]
    173 184 
         enclosed (_,sp0) = any subspan ticks
    174 185 
           where subspan (_,sp) = sp /= sp0 &&
    175 186 
                              realSrcSpanStart sp <= realSrcSpanStart sp0 &&
    ... ... @@ -180,53 +191,53 @@ findBreakForBind str_name modbreaks = filter (not . enclosed) ticks
    180 191 
     --------------------------------------------------------------------------------
    181 192
    182 193 
     -- | Maps line numbers to the breakpoint ticks existing at that line for a module.
    183 
    -type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
    194 
    +type TickArray = Array Int [(BreakIndex,RealSrcSpan)]
    184 195
    185 196 
     -- | Construct the 'TickArray' for the given module.
    186 197 
     makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray)
    187 198 
     makeModuleLineMap m = do
    188 
    -  mi <- GHC.getModuleInfo m
    189 
    -  return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi)
    199 
    +  mi <- getModuleInfo m
    200 
    +  return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi)
    190 201 
       where
    191 202 
         mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray
    192 203 
         mkTickArray ticks
    193 204 
           = accumArray (flip (:)) [] (1, max_line)
    194 205 
                 [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]
    195 206 
             where
    196 
    -            max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
    197 
    -            srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]
    207 
    +            max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
    208 
    +            srcSpanLines pan = [ srcSpanStartLine pan ..  srcSpanEndLine pan ]
    198 209
    199 210 
     -- | Get the 'ModBreaks' of the given 'Module' when available
    200 
    -getModBreak :: GHC.GhcMonad m
    201 
    -            => Module -> m (Maybe ModBreaks)
    211 
    +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks)
    202 212 
     getModBreak m = do
    203 
    -   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
    204 
    -   pure $ GHC.modInfoModBreaks mod_info
    213 
    +   mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m
    214 
    +   pure $ modInfoModBreaks mod_info
    205 215
    206 216 
     --------------------------------------------------------------------------------
    207 217 
     -- Getting current breakpoint information
    208 218 
     --------------------------------------------------------------------------------
    209 219
    210 
    -getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
    220 
    +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan)
    211 221 
     getCurrentBreakSpan = do
    212 
    -  resumes <- GHC.getResumeContext
    222 
    +  hug <- hsc_HUG <$> getSession
    223 
    +  resumes <- getResumeContext
    213 224 
       case resumes of
    214 225 
         [] -> return Nothing
    215 226 
         (r:_) -> do
    216 
    -        let ix = GHC.resumeHistoryIx r
    227 
    +        let ix = resumeHistoryIx r
    217 228 
             if ix == 0
    218 
    -           then return (Just (GHC.resumeSpan r))
    229 
    +           then return (Just (resumeSpan r))
    219 230 
                else do
    220 
    -                let hist = GHC.resumeHistory r !! (ix-1)
    221 
    -                pan <- GHC.getHistorySpan hist
    231 
    +                let hist = resumeHistory r !! (ix-1)
    232 
    +                pan <- liftIO $ getHistorySpan hug hist
    222 233 
                     return (Just pan)
    223 234
    224 
    -getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
    235 
    +getCurrentBreakModule :: GhcMonad m => m (Maybe Module)
    225 236 
     getCurrentBreakModule = do
    226 
    -  resumes <- GHC.getResumeContext
    237 
    +  resumes <- getResumeContext
    227 238 
       return $ case resumes of
    228 239 
         [] -> Nothing
    229 
    -    (r:_) -> case GHC.resumeHistoryIx r of
    230 
    -      0  -> ibi_tick_mod <$> GHC.resumeBreakpointId r
    231 
    -      ix -> Just $ GHC.getHistoryModule $ GHC.resumeHistory r !! (ix-1)
    240 
    +    (r:_) -> case resumeHistoryIx r of
    241 
    +      0  -> ibi_tick_mod <$> resumeBreakpointId r
    242 
    +      ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1)
    232 243

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -144,25 +144,25 @@ import qualified GHC.Unit.Home.Graph as HUG
    144 144 
     getResumeContext :: GhcMonad m => m [Resume]
    145 145 
     getResumeContext = withSession (return . ic_resume . hsc_IC)
    146 146
    147 
    -mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> IO History
    148 
    -mkHistory hsc_env hval ibi = History hval ibi <$> findEnclosingDecls hsc_env ibi
    147 
    +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History
    148 
    +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi
    149 149
    150 150 
     getHistoryModule :: History -> Module
    151 151 
     getHistoryModule = ibi_tick_mod . historyBreakpointId
    152 152
    153 
    -getHistorySpan :: HscEnv -> History -> IO SrcSpan
    154 
    -getHistorySpan hsc_env hist = do
    153 
    +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan
    154 
    +getHistorySpan hug hist = do
    155 155 
       let ibi = historyBreakpointId hist
    156 
    -  brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
    156 
    +  brks <- readModBreaks hug (ibi_tick_mod ibi)
    157 157 
       return $ modBreaks_locs brks ! ibi_tick_index ibi
    158 158
    159 159 
     {- | Finds the enclosing top level function name -}
    160 160 
     -- ToDo: a better way to do this would be to keep hold of the decl_path computed
    161 161 
     -- by the coverage pass, which gives the list of lexically-enclosing bindings
    162 162 
     -- for each tick.
    163 
    -findEnclosingDecls :: HscEnv -> InternalBreakpointId -> IO [String]
    164 
    -findEnclosingDecls hsc_env ibi = do
    165 
    -  brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
    163 
    +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String]
    164 
    +findEnclosingDecls hug ibi = do
    165 
    +  brks <- readModBreaks hug (ibi_tick_mod ibi)
    166 166 
       return $ modBreaks_decls brks ! ibi_tick_index ibi
    167 167
    168 168 
     -- | Update fixity environment in the current interactive context.
    ... ... @@ -349,7 +349,8 @@ handleRunStatus step expr bindings final_ids status history0 = do
    349 349 
         --  - or one of the stepping options in @EvalOpts@ caused us to stop at one
    350 350 
         EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
    351 351 
           let ibi = evalBreakpointToId eval_break
    352 
    -      tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
    352 
    +      let hug = hsc_HUG hsc_env
    353 
    +      tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
    353 354 
           let
    354 355 
             span      = modBreaks_locs tick_brks ! ibi_tick_index ibi
    355 356 
             decl      = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi
    ... ... @@ -390,7 +391,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
    390 391 
             let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
    391 392 
             status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv
    392 393 
             history <- if not tracing then pure history0 else do
    393 
    -          history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi
    394 
    +          history1 <- liftIO $ mkHistory hug apStack_fhv ibi
    394 395 
               let !history' = history1 `consBL` history0
    395 396 
                     -- history is strict, otherwise our BoundedList is pointless.
    396 397 
               return history'
    ... ... @@ -443,27 +444,27 @@ resumeExec step mbCnt
    443 444 
                     -- When the user specified a break ignore count, set it
    444 445 
                     -- in the interpreter
    445 446 
                     case (mb_brkpt, mbCnt) of
    446 
    -                  (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt
    447 
    +                  (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt
    447 448 
                       _ -> return ()
    448 449
    449 450 
                     let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
    450 451 
                     status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
    451 452 
                     let prevHistoryLst = fromListBL 50 hist
    453 
    +                    hug = hsc_HUG hsc_env
    452 454 
                         hist' = case mb_brkpt of
    453 455 
                            Nothing -> pure prevHistoryLst
    454 456 
                            Just bi
    455 457 
                              | breakHere False step span -> do
    456 
    -                            hist1 <- liftIO (mkHistory hsc_env apStack bi)
    458 
    +                            hist1 <- liftIO (mkHistory hug apStack bi)
    457 459 
                                 return $ hist1 `consBL` fromListBL 50 hist
    458 460 
                              | otherwise -> pure prevHistoryLst
    459 461 
                     handleRunStatus step expr bindings final_ids status =<< hist'
    460 462
    461 
    -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m ()   -- #19157
    462 
    -setupBreakpoint hsc_env bi cnt = do
    463 
    -  let modl = bi_tick_mod bi
    464 
    -  modBreaks <- liftIO $ readModBreaks hsc_env modl
    463 
    +setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m ()   -- #19157
    464 
    +setupBreakpoint interp bi cnt = do
    465 
    +  hug <- hsc_HUG <$> getSession
    466 
    +  modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
    465 467 
       let breakarray = modBreaks_flags modBreaks
    466 
    -      interp = hscInterp hsc_env
    467 468 
       _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
    468 469 
       pure ()
    469 470
    ... ... @@ -494,7 +495,7 @@ moveHist fn = do
    494 495 
                 span <- case mb_info of
    495 496 
                           Nothing  -> return $ mkGeneralSrcSpan (fsLit "<unknown>")
    496 497 
                           Just ibi -> liftIO $ do
    497 
    -                        brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
    498 
    +                        brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi)
    498 499 
                             return $ modBreaks_locs brks ! ibi_tick_index ibi
    499 500 
                 (hsc_env1, names) <-
    500 501 
                   liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info
    ... ... @@ -525,11 +526,6 @@ moveHist fn = do
    525 526 
     result_fs :: FastString
    526 527 
     result_fs = fsLit "_result"
    527 528
    528 
    --- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'.
    529 
    -readModBreaks :: HscEnv -> Module -> IO ModBreaks
    530 
    -readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env)
    531 
    -
    532 
    -
    533 529 
     bindLocalsAtBreakpoint
    534 530 
             :: HscEnv
    535 531 
             -> ForeignHValue
    ... ... @@ -560,8 +556,9 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
    560 556 
     -- Just case: we stopped at a breakpoint, we have information about the location
    561 557 
     -- of the breakpoint and the free variables of the expression.
    562 558 
     bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
    563 
    -   info_brks <- readModBreaks hsc_env (ibi_info_mod ibi)
    564 
    -   tick_brks <- readModBreaks hsc_env (ibi_tick_mod ibi)
    559 
    +   let hug = hsc_HUG hsc_env
    560 
    +   info_brks <- readModBreaks hug (ibi_info_mod ibi)
    561 
    +   tick_brks <- readModBreaks hug (ibi_tick_mod ibi)
    565 562 
        let info   = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks)
    566 563 
            interp = hscInterp hsc_env
    567 564 
            occs   = modBreaks_vars tick_brks ! ibi_tick_index ibi

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -27,10 +27,9 @@ module GHC.Runtime.Interpreter
    27 27 
       , getClosure
    28 28 
       , whereFrom
    29 29 
       , getModBreaks
    30 
    +  , readModBreaks
    30 31 
       , seqHValue
    31 32 
       , evalBreakpointToId
    32 
    -  , interpreterDynamic
    33 
    -  , interpreterProfiled
    34 33
    35 34 
       -- * The object-code linker
    36 35 
       , initObjLinker
    ... ... @@ -98,7 +97,6 @@ import GHC.Unit.Env
    98 97
    99 98 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    100 99 
     import GHCi.Run
    101 
    -import GHC.Platform.Ways
    102 100 
     #endif
    103 101
    104 102 
     import Control.Concurrent
    ... ... @@ -117,6 +115,7 @@ import qualified GHC.InfoProv as InfoProv
    117 115
    118 116 
     import GHC.Builtin.Names
    119 117 
     import GHC.Types.Name
    118 
    +import qualified GHC.Unit.Home.Graph as HUG
    120 119
    121 120 
     -- Standard libraries
    122 121 
     import GHC.Exts
    ... ... @@ -732,13 +731,12 @@ wormholeRef interp _r = case interpInstance interp of
    732 731 
       ExternalInterp {}
    733 732 
         -> throwIO (InstallationError "this operation requires -fno-external-interpreter")
    734 733
    735 
    --- -----------------------------------------------------------------------------
    736 
    --- Misc utils
    737 
    -
    738 
    -fromEvalResult :: EvalResult a -> IO a
    739 
    -fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
    740 
    -fromEvalResult (EvalSuccess a) = return a
    734 
    +--------------------------------------------------------------------------------
    735 
    +-- * Finding breakpoint information
    736 
    +--------------------------------------------------------------------------------
    741 737
    738 
    +-- | Get the breakpoint information from the ByteCode object associated to this
    739 
    +-- 'HomeModInfo'.
    742 740 
     getModBreaks :: HomeModInfo -> Maybe ModBreaks
    743 741 
     getModBreaks hmi
    744 742 
       | Just linkable <- homeModInfoByteCode hmi,
    ... ... @@ -748,24 +746,15 @@ getModBreaks hmi
    748 746 
       | otherwise
    749 747 
       = Nothing -- probably object code
    750 748
    751 
    --- | Interpreter uses Profiling way
    752 
    -interpreterProfiled :: Interp -> Bool
    753 
    -interpreterProfiled interp = case interpInstance interp of
    754 
    -#if defined(HAVE_INTERNAL_INTERPRETER)
    755 
    -  InternalInterp     -> hostIsProfiled
    756 
    -#endif
    757 
    -  ExternalInterp ext -> case ext of
    758 
    -    ExtIServ i -> iservConfProfiled (interpConfig i)
    759 
    -    ExtJS {}   -> False -- we don't support profiling yet in the JS backend
    760 
    -    ExtWasm i -> wasmInterpProfiled $ interpConfig i
    761 
    -
    762 
    --- | Interpreter uses Dynamic way
    763 
    -interpreterDynamic :: Interp -> Bool
    764 
    -interpreterDynamic interp = case interpInstance interp of
    765 
    -#if defined(HAVE_INTERNAL_INTERPRETER)
    766 
    -  InternalInterp     -> hostIsDynamic
    767 
    -#endif
    768 
    -  ExternalInterp ext -> case ext of
    769 
    -    ExtIServ i -> iservConfDynamic (interpConfig i)
    770 
    -    ExtJS {}   -> False -- dynamic doesn't make sense for JS
    771 
    -    ExtWasm {} -> True  -- wasm dyld can only load dynamic code
    749 
    +-- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module'
    750 
    +-- from the 'HomeUnitGraph'.
    751 
    +readModBreaks :: HomeUnitGraph -> Module -> IO ModBreaks
    752 
    +readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug
    753 
    +
    754 
    +-- -----------------------------------------------------------------------------
    755 
    +-- Misc utils
    756 
    +
    757 
    +fromEvalResult :: EvalResult a -> IO a
    758 
    +fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
    759 
    +fromEvalResult (EvalSuccess a) = return a
    760 
    +

  • compiler/GHC/Runtime/Interpreter/Types.hs
    ... ... @@ -24,7 +24,8 @@ module GHC.Runtime.Interpreter.Types
    24 24 
        , interpSymbolSuffix
    25 25 
        , eliminateInterpSymbol
    26 26 
        , interpretedInterpSymbol
    27 
    -
    27 
    +   , interpreterProfiled
    28 
    +   , interpreterDynamic
    28 29
    29 30 
        -- * IServ
    30 31 
        , IServ
    ... ... @@ -48,6 +49,9 @@ import GHCi.RemoteTypes
    48 49 
     import GHCi.Message         ( Pipe )
    49 50
    50 51 
     import GHC.Platform
    52 
    +#if defined(HAVE_INTERNAL_INTERPRETER)
    53 
    +import GHC.Platform.Ways
    54 
    +#endif
    51 55 
     import GHC.Utils.TmpFs
    52 56 
     import GHC.Utils.Logger
    53 57 
     import GHC.Unit.Env
    ... ... @@ -136,6 +140,28 @@ data ExtInterpInstance c = ExtInterpInstance
    136 140 
           -- ^ Instance specific extra fields
    137 141 
       }
    138 142
    143 
    +-- | Interpreter uses Profiling way
    144 
    +interpreterProfiled :: Interp -> Bool
    145 
    +interpreterProfiled interp = case interpInstance interp of
    146 
    +#if defined(HAVE_INTERNAL_INTERPRETER)
    147 
    +  InternalInterp     -> hostIsProfiled
    148 
    +#endif
    149 
    +  ExternalInterp ext -> case ext of
    150 
    +    ExtIServ i -> iservConfProfiled (interpConfig i)
    151 
    +    ExtJS {}   -> False -- we don't support profiling yet in the JS backend
    152 
    +    ExtWasm i -> wasmInterpProfiled $ interpConfig i
    153 
    +
    154 
    +-- | Interpreter uses Dynamic way
    155 
    +interpreterDynamic :: Interp -> Bool
    156 
    +interpreterDynamic interp = case interpInstance interp of
    157 
    +#if defined(HAVE_INTERNAL_INTERPRETER)
    158 
    +  InternalInterp     -> hostIsDynamic
    159 
    +#endif
    160 
    +  ExternalInterp ext -> case ext of
    161 
    +    ExtIServ i -> iservConfDynamic (interpConfig i)
    162 
    +    ExtJS {}   -> False -- dynamic doesn't make sense for JS
    163 
    +    ExtWasm {} -> True  -- wasm dyld can only load dynamic code
    164 
    +
    139 165 
     ------------------------
    140 166 
     -- JS Stuff
    141 167 
     ------------------------

  • compiler/GHC/Stg/BcPrep.hs
    ... ... @@ -49,7 +49,7 @@ bcPrepRHS con@StgRhsCon{} = pure con
    49 49
    50 50 
     bcPrepExpr :: StgExpr -> BcPrepM StgExpr
    51 51 
     -- explicitly match all constructors so we get a warning if we miss any
    52 
    -bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs)
    52 
    +bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
    53 53 
       | isLiftedTypeKind (typeKind tick_ty) = do
    54 54 
           id <- newId tick_ty
    55 55 
           rhs' <- bcPrepExpr rhs

  • compiler/GHC/Stg/FVs.hs
    ... ... @@ -257,8 +257,8 @@ exprFVs env = go
    257 257 
           , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs
    258 258 
           = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs')
    259 259 
             where
    260 
    -          tickish (Breakpoint _ _ ids _) = mkDVarSet ids
    261 
    -          tickish _                      = emptyDVarSet
    260 
    +          tickish (Breakpoint _ _ ids) = mkDVarSet ids
    261 
    +          tickish _                    = emptyDVarSet
    262 262
    263 263 
         go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs)
    264 264 
           where

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -33,6 +33,7 @@ import GHC.Platform.Profile
    33 33 
     import GHC.Runtime.Interpreter
    34 34 
     import GHCi.FFI
    35 35 
     import GHC.Types.Basic
    36 
    +import GHC.Types.Breakpoint
    36 37 
     import GHC.Utils.Outputable
    37 38 
     import GHC.Types.Name
    38 39 
     import GHC.Types.Id
    ... ... @@ -388,7 +389,7 @@ schemeR_wrk fvs nm original_body (args, body)
    388 389 
     -- | Introduce break instructions for ticked expressions.
    389 390 
     -- If no breakpoint information is available, the instruction is omitted.
    390 391 
     schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
    391 
    -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
    392 
    +schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do
    392 393 
       code <- schemeE d 0 p rhs
    393 394 
       hsc_env <- getHscEnv
    394 395 
       current_mod <- getCurrentModule
    ... ... @@ -640,10 +641,9 @@ schemeE d s p (StgLet _ext binds body) = do
    640 641 
          thunk_codes <- sequence compile_binds
    641 642 
          return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
    642 643
    643 
    -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs)
    644 
    -   = panic ("schemeE: Breakpoint without let binding: " ++
    645 
    -            show bp_id ++
    646 
    -            " forgot to run bcPrep?")
    644 
    +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
    645 
    +   = pprPanic "schemeE: Breakpoint without let binding: " $
    646 
    +            ppr bp_id <> text " forgot to run bcPrep?"
    647 647
    648 648 
     -- ignore other kinds of tick
    649 649 
     schemeE d s p (StgTick _ rhs) = schemeE d s p rhs

  • compiler/GHC/Types/Breakpoint.hs
    ... ... @@ -8,6 +8,9 @@ where
    8 8
    9 9 
     import GHC.Prelude
    10 10 
     import GHC.Unit.Module
    11 
    +import GHC.Utils.Outputable
    12 
    +import Control.DeepSeq
    13 
    +import Data.Data (Data)
    11 14
    12 15 
     -- | Breakpoint identifier.
    13 16 
     --
    ... ... @@ -16,7 +19,7 @@ data BreakpointId = BreakpointId
    16 19 
       { bi_tick_mod   :: !Module  -- ^ Breakpoint tick module
    17 20 
       , bi_tick_index :: !Int     -- ^ Breakpoint tick index
    18 21 
       }
    19 
    -  deriving (Eq, Ord)
    22 
    +  deriving (Eq, Ord, Data)
    20 23
    21 24 
     -- | Internal breakpoint identifier
    22 25 
     --
    ... ... @@ -53,3 +56,11 @@ toBreakpointId ibi = BreakpointId
    53 56 
     -- So every breakpoint occurrence gets assigned a module-unique *info index* and
    54 57 
     -- we store it alongside the occurrence module (*info module*) in the
    55 58 
     -- InternalBreakpointId datatype.
    59 
    +
    60 
    +instance Outputable BreakpointId where
    61 
    +  ppr BreakpointId{bi_tick_mod, bi_tick_index} =
    62 
    +    text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index
    63 
    +
    64 
    +instance NFData BreakpointId where
    65 
    +  rnf BreakpointId{bi_tick_mod, bi_tick_index} =
    66 
    +    rnf bi_tick_mod `seq` rnf bi_tick_index

  • compiler/GHC/Types/Tickish.hs
    ... ... @@ -31,6 +31,7 @@ import GHC.Core.Type
    31 31
    32 32 
     import GHC.Unit.Module
    33 33
    34 
    +import GHC.Types.Breakpoint
    34 35 
     import GHC.Types.CostCentre
    35 36 
     import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan )
    36 37 
     import GHC.Types.Var
    ... ... @@ -128,7 +129,7 @@ data GenTickish pass =
    128 129 
       -- and (b) substituting (don't substitute for them)
    129 130 
       | Breakpoint
    130 131 
         { breakpointExt    :: XBreakpoint pass
    131 
    -    , breakpointId     :: !Int
    132 
    +    , breakpointId     :: !BreakpointId
    132 133 
         , breakpointFVs    :: [XTickishId pass]
    133 134 
                                     -- ^ the order of this list is important:
    134 135 
                                     -- it matches the order of the lists in the
    ... ... @@ -136,7 +137,6 @@ data GenTickish pass =
    136 137 
                                     --
    137 138 
                                     -- Careful about substitution!  See
    138 139 
                                     -- Note [substTickish] in "GHC.Core.Subst".
    139 
    -    , breakpointModule :: Module
    140 140 
         }
    141 141
    142 142 
       -- | A source note.

  • compiler/ghc.cabal.in
    ... ... @@ -548,6 +548,7 @@ Library
    548 548 
             GHC.Driver.Plugins.External
    549 549 
             GHC.Driver.Ppr
    550 550 
             GHC.Driver.Session
    551 
    +        GHC.Driver.Session.Inspect
    551 552 
             GHC.Driver.Session.Units
    552 553 
             GHC.Hs
    553 554 
             GHC.Hs.Basic

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help