module GHC.Unit.Module.Graph
( ModuleGraph
, ModuleGraphNode(..)
, nodeDependencies
, emptyMG
, mkModuleGraph
, extendMG
, extendMGInst
, extendMG'
, unionMG
, isTemplateHaskellOrQQNonBoot
, filterToposortToModules
, mapMG
, mgModSummaries
, mgModSummaries'
, mgLookupModule
, mgTransDeps
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
, moduleGraphNodes
, SummaryNode
, summaryNodeSummary
, NodeKey(..)
, nodeKeyUnitId
, ModNodeKey
, mkNodeKey
, msKey
, moduleGraphNodeUnitId
, ModNodeKeyWithUid(..)
)
where
import GHC.Prelude
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import GHC.Data.Graph.Directed
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Types.SourceFile ( hscSourceString )
import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
import GHC.Utils.Outputable
import System.FilePath
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
import qualified Data.Set as Set
import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
import Data.Either
import Data.Function
import GHC.Data.List.SetOps
data ModuleGraphNode
= InstantiationNode UnitId InstantiatedUnit
| ModuleNode [NodeKey] ModSummary
| LinkNode [NodeKey] UnitId
moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName
moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)
moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary
moduleGraphNodeModSum (InstantiationNode {}) = Nothing
moduleGraphNodeModSum (LinkNode {}) = Nothing
moduleGraphNodeModSum (ModuleNode _ ms) = Just ms
moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId
moduleGraphNodeUnitId mgn =
case mgn of
InstantiationNode uid _iud -> uid
ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms))
LinkNode _ uid -> uid
instance Outputable ModuleGraphNode where
ppr = \case
InstantiationNode _ iuid -> ppr iuid
ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks
LinkNode uid _ -> text "LN:" <+> ppr uid
instance Eq ModuleGraphNode where
(==) = (==) `on` mkNodeKey
instance Ord ModuleGraphNode where
compare = compare `on` mkNodeKey
data NodeKey = NodeKey_Unit !InstantiatedUnit
| NodeKey_Module !ModNodeKeyWithUid
| NodeKey_Link !UnitId
deriving (Eq, Ord)
instance Outputable NodeKey where
ppr nk = pprNodeKey nk
pprNodeKey :: NodeKey -> SDoc
pprNodeKey (NodeKey_Unit iu) = ppr iu
pprNodeKey (NodeKey_Module mk) = ppr mk
pprNodeKey (NodeKey_Link uid) = ppr uid
nodeKeyUnitId :: NodeKey -> UnitId
nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu
nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
nodeKeyUnitId (NodeKey_Link uid) = uid
data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot
, mnkUnitId :: !UnitId } deriving (Eq, Ord)
instance Outputable ModNodeKeyWithUid where
ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey)
}
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG f mg@ModuleGraph{..} = mg
{ mg_mss = flip fmap mg_mss $ \case
InstantiationNode uid iuid -> InstantiationNode uid iuid
LinkNode uid nks -> LinkNode uid nks
ModuleNode deps ms -> ModuleNode deps (f ms)
}
unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
unionMG a b =
let new_mss = nubOrdBy compare $ mg_mss a `mappend` mg_mss b
in ModuleGraph {
mg_mss = new_mss
, mg_trans_deps = mkTransDeps new_mss
}
mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)
mgTransDeps = mg_trans_deps
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
mgModSummaries' = mg_mss
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
where
go (ModuleNode _ ms)
| NotBoot <- isBootSummary ms
, ms_mod ms == m
= Just ms
go _ = Nothing
emptyMG :: ModuleGraph
emptyMG = ModuleGraph [] Map.empty
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
(xopt LangExt.TemplateHaskell (ms_hspp_opts ms)
|| xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&
(isBootSummary ms == NotBoot)
extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
extendMG ModuleGraph{..} deps ms = ModuleGraph
{ mg_mss = ModuleNode deps ms : mg_mss
, mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss)
}
mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)
mkTransDeps mss =
let (gg, _lookup_node) = moduleGraphNodes False mss
in allReachable gg (mkNodeKey . node_payload)
extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
extendMGInst mg uid depUnitId = mg
{ mg_mss = InstantiationNode uid depUnitId : mg_mss mg
}
extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph
extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }
extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG' mg = \case
InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId
ModuleNode deps ms -> extendMG mg deps ms
LinkNode deps uid -> extendMGLink mg uid deps
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph = foldr (flip extendMG') emptyMG
filterToposortToModules
:: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
InstantiationNode _ _ -> Nothing
LinkNode{} -> Nothing
ModuleNode _deps node -> Just node
where
mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)
mapMaybeSCC f = \case
AcyclicSCC a -> AcyclicSCC <$> f a
CyclicSCC as -> case mapMaybe f as of
[] -> Nothing
[a] -> Just $ AcyclicSCC a
as -> Just $ CyclicSCC as
showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg dflags _ (LinkNode {}) =
let staticLink = case ghcLink dflags of
LinkStaticLib -> True
_ -> False
platform = targetPlatform dflags
exe_file = exeFileName platform staticLink (outputFile_ dflags)
in text exe_file
showModMsg _ _ (InstantiationNode _uid indef_unit) =
ppr $ instUnitInstanceOf indef_unit
showModMsg dflags recomp (ModuleNode _ mod_summary) =
if gopt Opt_HideSourcePaths dflags
then text mod_str
else hsep $
[ text (mod_str ++ replicate (max 0 (16 length mod_str)) ' ')
, char '('
, text (op $ msHsFilePath mod_summary) <> char ','
, message, char ')' ]
where
op = normalise
mod = moduleName (ms_mod mod_summary)
mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
dyn_file = op $ msDynObjFilePath mod_summary
obj_file = op $ msObjFilePath mod_summary
message = case backend dflags of
Interpreter | recomp -> text "interpreted"
NoBackend -> text "nothing"
_ ->
if gopt Opt_BuildDynamicToo dflags
then text obj_file <> comma <+> text dyn_file
else text obj_file
type SummaryNode = Node Int ModuleGraphNode
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey = node_key
summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary = node_payload
nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies drop_hs_boot_nodes = \case
LinkNode deps _uid -> deps
InstantiationNode uid iuid ->
NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid) <$> uniqDSetToList (instUnitHoles iuid)
ModuleNode deps _ms ->
map drop_hs_boot deps
where
hs_boot_key | drop_hs_boot_nodes = NotBoot
| otherwise = IsBoot
drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))
drop_hs_boot x = x
moduleGraphNodes :: Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
(boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries)
where
go (s, key) =
case s of
ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes
-> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s)
_ -> normal_case
where
normal_case =
let lkup_key = ms_mod <$> moduleGraphNodeModSum s
extra = (lkup_key >>= \key -> Map.lookup key boot_summaries)
in Right $ DigraphNode s key $ out_edge_keys $
(fromMaybe [] extra
++ nodeDependencies drop_hs_boot_nodes s)
numbered_summaries = zip summaries [1..]
lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node key = Map.lookup key (unNodeMap node_map)
lookup_key :: NodeKey -> Maybe Int
lookup_key = fmap summaryNodeKey . lookup_node
node_map :: NodeMap SummaryNode
node_map = NodeMap $
Map.fromList [ (mkNodeKey s, node)
| node <- nodes
, let s = summaryNodeSummary node
]
out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = mapMaybe lookup_key
newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
deriving (Functor, Traversable, Foldable)
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
InstantiationNode _ iu -> NodeKey_Unit iu
ModuleNode _ x -> NodeKey_Module $ msKey x
LinkNode _ uid -> NodeKey_Link uid
msKey :: ModSummary -> ModNodeKeyWithUid
msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
type ModNodeKey = ModuleNameWithIsBoot