PageRenderTime 50ms CodeModel.GetById 21ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/utils/GraphOps.hs

https://github.com/dorchard/ghc
Haskell | 665 lines | 418 code | 138 blank | 109 comment | 5 complexity | f66935e43aafd5e8485b321e02724664 MD5 | raw file
  1. -- | Basic operations on graphs.
  2. --
  3. module GraphOps (
  4. addNode, delNode, getNode, lookupNode, modNode,
  5. size,
  6. union,
  7. addConflict, delConflict, addConflicts,
  8. addCoalesce, delCoalesce,
  9. addExclusion, addExclusions,
  10. addPreference,
  11. coalesceNodes, coalesceGraph,
  12. freezeNode, freezeOneInGraph, freezeAllInGraph,
  13. scanGraph,
  14. setColor,
  15. validateGraph,
  16. slurpNodeConflictCount
  17. )
  18. where
  19. import GraphBase
  20. import Outputable
  21. import Unique
  22. import UniqSet
  23. import UniqFM
  24. import Data.List hiding (union)
  25. import Data.Maybe
  26. -- | Lookup a node from the graph.
  27. lookupNode
  28. :: Uniquable k
  29. => Graph k cls color
  30. -> k -> Maybe (Node k cls color)
  31. lookupNode graph k
  32. = lookupUFM (graphMap graph) k
  33. -- | Get a node from the graph, throwing an error if it's not there
  34. getNode
  35. :: Uniquable k
  36. => Graph k cls color
  37. -> k -> Node k cls color
  38. getNode graph k
  39. = case lookupUFM (graphMap graph) k of
  40. Just node -> node
  41. Nothing -> panic "ColorOps.getNode: not found"
  42. -- | Add a node to the graph, linking up its edges
  43. addNode :: Uniquable k
  44. => k -> Node k cls color
  45. -> Graph k cls color -> Graph k cls color
  46. addNode k node graph
  47. = let
  48. -- add back conflict edges from other nodes to this one
  49. map_conflict
  50. = foldUniqSet
  51. (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  52. (graphMap graph)
  53. (nodeConflicts node)
  54. -- add back coalesce edges from other nodes to this one
  55. map_coalesce
  56. = foldUniqSet
  57. (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  58. map_conflict
  59. (nodeCoalesce node)
  60. in graph
  61. { graphMap = addToUFM map_coalesce k node}
  62. -- | Delete a node and all its edges from the graph.
  63. delNode :: (Uniquable k, Outputable k)
  64. => k -> Graph k cls color -> Maybe (Graph k cls color)
  65. delNode k graph
  66. | Just node <- lookupNode graph k
  67. = let -- delete conflict edges from other nodes to this one.
  68. graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
  69. $ uniqSetToList (nodeConflicts node)
  70. -- delete coalesce edge from other nodes to this one.
  71. graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
  72. $ uniqSetToList (nodeCoalesce node)
  73. -- delete the node
  74. graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
  75. in Just graph3
  76. | otherwise
  77. = Nothing
  78. -- | Modify a node in the graph.
  79. -- returns Nothing if the node isn't present.
  80. --
  81. modNode :: Uniquable k
  82. => (Node k cls color -> Node k cls color)
  83. -> k -> Graph k cls color -> Maybe (Graph k cls color)
  84. modNode f k graph
  85. = case lookupNode graph k of
  86. Just Node{}
  87. -> Just
  88. $ graphMapModify
  89. (\fm -> let Just node = lookupUFM fm k
  90. node' = f node
  91. in addToUFM fm k node')
  92. graph
  93. Nothing -> Nothing
  94. -- | Get the size of the graph, O(n)
  95. size :: Uniquable k
  96. => Graph k cls color -> Int
  97. size graph
  98. = sizeUFM $ graphMap graph
  99. -- | Union two graphs together.
  100. union :: Uniquable k
  101. => Graph k cls color -> Graph k cls color -> Graph k cls color
  102. union graph1 graph2
  103. = Graph
  104. { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
  105. -- | Add a conflict between nodes to the graph, creating the nodes required.
  106. -- Conflicts are virtual regs which need to be colored differently.
  107. addConflict
  108. :: Uniquable k
  109. => (k, cls) -> (k, cls)
  110. -> Graph k cls color -> Graph k cls color
  111. addConflict (u1, c1) (u2, c2)
  112. = let addNeighbor u c u'
  113. = adjustWithDefaultUFM
  114. (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
  115. (newNode u c) { nodeConflicts = unitUniqSet u' }
  116. u
  117. in graphMapModify
  118. ( addNeighbor u1 c1 u2
  119. . addNeighbor u2 c2 u1)
  120. -- | Delete a conflict edge. k1 -> k2
  121. -- returns Nothing if the node isn't in the graph
  122. delConflict
  123. :: Uniquable k
  124. => k -> k
  125. -> Graph k cls color -> Maybe (Graph k cls color)
  126. delConflict k1 k2
  127. = modNode
  128. (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
  129. k1
  130. -- | Add some conflicts to the graph, creating nodes if required.
  131. -- All the nodes in the set are taken to conflict with each other.
  132. addConflicts
  133. :: Uniquable k
  134. => UniqSet k -> (k -> cls)
  135. -> Graph k cls color -> Graph k cls color
  136. addConflicts conflicts getClass
  137. -- just a single node, but no conflicts, create the node anyway.
  138. | (u : []) <- uniqSetToList conflicts
  139. = graphMapModify
  140. $ adjustWithDefaultUFM
  141. id
  142. (newNode u (getClass u))
  143. u
  144. | otherwise
  145. = graphMapModify
  146. $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm
  147. $ uniqSetToList conflicts)
  148. addConflictSet1 :: Uniquable k
  149. => k -> (k -> cls) -> UniqSet k
  150. -> UniqFM (Node k cls color)
  151. -> UniqFM (Node k cls color)
  152. addConflictSet1 u getClass set
  153. = case delOneFromUniqSet set u of
  154. set' -> adjustWithDefaultUFM
  155. (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
  156. (newNode u (getClass u)) { nodeConflicts = set' }
  157. u
  158. -- | Add an exclusion to the graph, creating nodes if required.
  159. -- These are extra colors that the node cannot use.
  160. addExclusion
  161. :: (Uniquable k, Uniquable color)
  162. => k -> (k -> cls) -> color
  163. -> Graph k cls color -> Graph k cls color
  164. addExclusion u getClass color
  165. = graphMapModify
  166. $ adjustWithDefaultUFM
  167. (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
  168. (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
  169. u
  170. addExclusions
  171. :: (Uniquable k, Uniquable color)
  172. => k -> (k -> cls) -> [color]
  173. -> Graph k cls color -> Graph k cls color
  174. addExclusions u getClass colors graph
  175. = foldr (addExclusion u getClass) graph colors
  176. -- | Add a coalescence edge to the graph, creating nodes if requried.
  177. -- It is considered adventageous to assign the same color to nodes in a coalesence.
  178. addCoalesce
  179. :: Uniquable k
  180. => (k, cls) -> (k, cls)
  181. -> Graph k cls color -> Graph k cls color
  182. addCoalesce (u1, c1) (u2, c2)
  183. = let addCoalesce u c u'
  184. = adjustWithDefaultUFM
  185. (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
  186. (newNode u c) { nodeCoalesce = unitUniqSet u' }
  187. u
  188. in graphMapModify
  189. ( addCoalesce u1 c1 u2
  190. . addCoalesce u2 c2 u1)
  191. -- | Delete a coalescence edge (k1 -> k2) from the graph.
  192. delCoalesce
  193. :: Uniquable k
  194. => k -> k
  195. -> Graph k cls color -> Maybe (Graph k cls color)
  196. delCoalesce k1 k2
  197. = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
  198. k1
  199. -- | Add a color preference to the graph, creating nodes if required.
  200. -- The most recently added preference is the most prefered.
  201. -- The algorithm tries to assign a node it's prefered color if possible.
  202. --
  203. addPreference
  204. :: Uniquable k
  205. => (k, cls) -> color
  206. -> Graph k cls color -> Graph k cls color
  207. addPreference (u, c) color
  208. = graphMapModify
  209. $ adjustWithDefaultUFM
  210. (\node -> node { nodePreference = color : (nodePreference node) })
  211. (newNode u c) { nodePreference = [color] }
  212. u
  213. -- | Do agressive coalescing on this graph.
  214. -- returns the new graph and the list of pairs of nodes that got coaleced together.
  215. -- for each pair, the resulting node will have the least key and be second in the pair.
  216. --
  217. coalesceGraph
  218. :: (Uniquable k, Ord k, Eq cls, Outputable k)
  219. => Bool -- ^ If True, coalesce nodes even if this might make the graph
  220. -- less colorable (aggressive coalescing)
  221. -> Triv k cls color
  222. -> Graph k cls color
  223. -> ( Graph k cls color
  224. , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the
  225. -- coalescing was applied.
  226. coalesceGraph aggressive triv graph
  227. = coalesceGraph' aggressive triv graph []
  228. coalesceGraph'
  229. :: (Uniquable k, Ord k, Eq cls, Outputable k)
  230. => Bool
  231. -> Triv k cls color
  232. -> Graph k cls color
  233. -> [(k, k)]
  234. -> ( Graph k cls color
  235. , [(k, k)])
  236. coalesceGraph' aggressive triv graph kkPairsAcc
  237. = let
  238. -- find all the nodes that have coalescence edges
  239. cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
  240. $ eltsUFM $ graphMap graph
  241. -- build a list of pairs of keys for node's we'll try and coalesce
  242. -- every pair of nodes will appear twice in this list
  243. -- ie [(k1, k2), (k2, k1) ... ]
  244. -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for
  245. -- build a list of what nodes get coalesced together for later on.
  246. --
  247. cList = [ (nodeId node1, k2)
  248. | node1 <- cNodes
  249. , k2 <- uniqSetToList $ nodeCoalesce node1 ]
  250. -- do the coalescing, returning the new graph and a list of pairs of keys
  251. -- that got coalesced together.
  252. (graph', mPairs)
  253. = mapAccumL (coalesceNodes aggressive triv) graph cList
  254. -- keep running until there are no more coalesces can be found
  255. in case catMaybes mPairs of
  256. [] -> (graph', reverse kkPairsAcc)
  257. pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
  258. -- | Coalesce this pair of nodes unconditionally \/ agressively.
  259. -- The resulting node is the one with the least key.
  260. --
  261. -- returns: Just the pair of keys if the nodes were coalesced
  262. -- the second element of the pair being the least one
  263. --
  264. -- Nothing if either of the nodes weren't in the graph
  265. coalesceNodes
  266. :: (Uniquable k, Ord k, Eq cls, Outputable k)
  267. => Bool -- ^ If True, coalesce nodes even if this might make the graph
  268. -- less colorable (aggressive coalescing)
  269. -> Triv k cls color
  270. -> Graph k cls color
  271. -> (k, k) -- ^ keys of the nodes to be coalesced
  272. -> (Graph k cls color, Maybe (k, k))
  273. coalesceNodes aggressive triv graph (k1, k2)
  274. | (kMin, kMax) <- if k1 < k2
  275. then (k1, k2)
  276. else (k2, k1)
  277. -- the nodes being coalesced must be in the graph
  278. , Just nMin <- lookupNode graph kMin
  279. , Just nMax <- lookupNode graph kMax
  280. -- can't coalesce conflicting modes
  281. , not $ elementOfUniqSet kMin (nodeConflicts nMax)
  282. , not $ elementOfUniqSet kMax (nodeConflicts nMin)
  283. -- can't coalesce the same node
  284. , nodeId nMin /= nodeId nMax
  285. = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
  286. -- don't do the coalescing after all
  287. | otherwise
  288. = (graph, Nothing)
  289. coalesceNodes_merge
  290. :: (Uniquable k, Ord k, Eq cls, Outputable k)
  291. => Bool
  292. -> Triv k cls color
  293. -> Graph k cls color
  294. -> k -> k
  295. -> Node k cls color
  296. -> Node k cls color
  297. -> (Graph k cls color, Maybe (k, k))
  298. coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
  299. -- sanity checks
  300. | nodeClass nMin /= nodeClass nMax
  301. = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
  302. | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
  303. = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
  304. ---
  305. | otherwise
  306. = let
  307. -- the new node gets all the edges from its two components
  308. node =
  309. Node { nodeId = kMin
  310. , nodeClass = nodeClass nMin
  311. , nodeColor = Nothing
  312. -- nodes don't conflict with themselves..
  313. , nodeConflicts
  314. = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
  315. `delOneFromUniqSet` kMin
  316. `delOneFromUniqSet` kMax
  317. , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
  318. , nodePreference = nodePreference nMin ++ nodePreference nMax
  319. -- nodes don't coalesce with themselves..
  320. , nodeCoalesce
  321. = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
  322. `delOneFromUniqSet` kMin
  323. `delOneFromUniqSet` kMax
  324. }
  325. in coalesceNodes_check aggressive triv graph kMin kMax node
  326. coalesceNodes_check
  327. :: (Uniquable k, Ord k, Eq cls, Outputable k)
  328. => Bool
  329. -> Triv k cls color
  330. -> Graph k cls color
  331. -> k -> k
  332. -> Node k cls color
  333. -> (Graph k cls color, Maybe (k, k))
  334. coalesceNodes_check aggressive triv graph kMin kMax node
  335. -- Unless we're coalescing aggressively, if the result node is not trivially
  336. -- colorable then don't do the coalescing.
  337. | not aggressive
  338. , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
  339. = (graph, Nothing)
  340. | otherwise
  341. = let -- delete the old nodes from the graph and add the new one
  342. Just graph1 = delNode kMax graph
  343. Just graph2 = delNode kMin graph1
  344. graph3 = addNode kMin node graph2
  345. in (graph3, Just (kMax, kMin))
  346. -- | Freeze a node
  347. -- This is for the iterative coalescer.
  348. -- By freezing a node we give up on ever coalescing it.
  349. -- Move all its coalesce edges into the frozen set - and update
  350. -- back edges from other nodes.
  351. --
  352. freezeNode
  353. :: Uniquable k
  354. => k -- ^ key of the node to freeze
  355. -> Graph k cls color -- ^ the graph
  356. -> Graph k cls color -- ^ graph with that node frozen
  357. freezeNode k
  358. = graphMapModify
  359. $ \fm ->
  360. let -- freeze all the edges in the node to be frozen
  361. Just node = lookupUFM fm k
  362. node' = node
  363. { nodeCoalesce = emptyUniqSet }
  364. fm1 = addToUFM fm k node'
  365. -- update back edges pointing to this node
  366. freezeEdge k node
  367. = if elementOfUniqSet k (nodeCoalesce node)
  368. then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
  369. else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
  370. -- If the edge isn't actually in the coelesce set then just ignore it.
  371. fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1
  372. $ nodeCoalesce node
  373. in fm2
  374. -- | Freeze one node in the graph
  375. -- This if for the iterative coalescer.
  376. -- Look for a move related node of low degree and freeze it.
  377. --
  378. -- We probably don't need to scan the whole graph looking for the node of absolute
  379. -- lowest degree. Just sample the first few and choose the one with the lowest
  380. -- degree out of those. Also, we don't make any distinction between conflicts of different
  381. -- classes.. this is just a heuristic, after all.
  382. --
  383. -- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv
  384. -- right here, and add it to a worklist if known triv\/non-move nodes.
  385. --
  386. freezeOneInGraph
  387. :: (Uniquable k, Outputable k)
  388. => Graph k cls color
  389. -> ( Graph k cls color -- the new graph
  390. , Bool ) -- whether we found a node to freeze
  391. freezeOneInGraph graph
  392. = let compareNodeDegree n1 n2
  393. = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
  394. candidates
  395. = sortBy compareNodeDegree
  396. $ take 5 -- 5 isn't special, it's just a small number.
  397. $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
  398. in case candidates of
  399. -- there wasn't anything available to freeze
  400. [] -> (graph, False)
  401. -- we found something to freeze
  402. (n : _)
  403. -> ( freezeNode (nodeId n) graph
  404. , True)
  405. -- | Freeze all the nodes in the graph
  406. -- for debugging the iterative allocator.
  407. --
  408. freezeAllInGraph
  409. :: (Uniquable k, Outputable k)
  410. => Graph k cls color
  411. -> Graph k cls color
  412. freezeAllInGraph graph
  413. = foldr freezeNode graph
  414. $ map nodeId
  415. $ eltsUFM $ graphMap graph
  416. -- | Find all the nodes in the graph that meet some criteria
  417. --
  418. scanGraph
  419. :: Uniquable k
  420. => (Node k cls color -> Bool)
  421. -> Graph k cls color
  422. -> [Node k cls color]
  423. scanGraph match graph
  424. = filter match $ eltsUFM $ graphMap graph
  425. -- | validate the internal structure of a graph
  426. -- all its edges should point to valid nodes
  427. -- If they don't then throw an error
  428. --
  429. validateGraph
  430. :: (Uniquable k, Outputable k, Eq color)
  431. => SDoc -- ^ extra debugging info to display on error
  432. -> Bool -- ^ whether this graph is supposed to be colored.
  433. -> Graph k cls color -- ^ graph to validate
  434. -> Graph k cls color -- ^ validated graph
  435. validateGraph doc isColored graph
  436. -- Check that all edges point to valid nodes.
  437. | edges <- unionManyUniqSets
  438. ( (map nodeConflicts $ eltsUFM $ graphMap graph)
  439. ++ (map nodeCoalesce $ eltsUFM $ graphMap graph))
  440. , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
  441. , badEdges <- minusUniqSet edges nodes
  442. , not $ isEmptyUniqSet badEdges
  443. = pprPanic "GraphOps.validateGraph"
  444. ( text "Graph has edges that point to non-existant nodes"
  445. $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
  446. $$ doc )
  447. -- Check that no conflicting nodes have the same color
  448. | badNodes <- filter (not . (checkNode graph))
  449. $ eltsUFM $ graphMap graph
  450. , not $ null badNodes
  451. = pprPanic "GraphOps.validateGraph"
  452. ( text "Node has same color as one of it's conflicts"
  453. $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
  454. $$ doc)
  455. -- If this is supposed to be a colored graph,
  456. -- check that all nodes have a color.
  457. | isColored
  458. , badNodes <- filter (\n -> isNothing $ nodeColor n)
  459. $ eltsUFM $ graphMap graph
  460. , not $ null badNodes
  461. = pprPanic "GraphOps.validateGraph"
  462. ( text "Supposably colored graph has uncolored nodes."
  463. $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
  464. $$ doc )
  465. -- graph looks ok
  466. | otherwise
  467. = graph
  468. -- | If this node is colored, check that all the nodes which
  469. -- conflict with it have different colors.
  470. checkNode
  471. :: (Uniquable k, Eq color)
  472. => Graph k cls color
  473. -> Node k cls color
  474. -> Bool -- ^ True if this node is ok
  475. checkNode graph node
  476. | Just color <- nodeColor node
  477. , Just neighbors <- sequence $ map (lookupNode graph)
  478. $ uniqSetToList $ nodeConflicts node
  479. , neighbourColors <- catMaybes $ map nodeColor neighbors
  480. , elem color neighbourColors
  481. = False
  482. | otherwise
  483. = True
  484. -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
  485. slurpNodeConflictCount
  486. :: Uniquable k
  487. => Graph k cls color
  488. -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
  489. slurpNodeConflictCount graph
  490. = addListToUFM_C
  491. (\(c1, n1) (_, n2) -> (c1, n1 + n2))
  492. emptyUFM
  493. $ map (\node
  494. -> let count = sizeUniqSet $ nodeConflicts node
  495. in (count, (count, 1)))
  496. $ eltsUFM
  497. $ graphMap graph
  498. -- | Set the color of a certain node
  499. setColor
  500. :: Uniquable k
  501. => k -> color
  502. -> Graph k cls color -> Graph k cls color
  503. setColor u color
  504. = graphMapModify
  505. $ adjustUFM_C
  506. (\n -> n { nodeColor = Just color })
  507. u
  508. {-# INLINE adjustWithDefaultUFM #-}
  509. adjustWithDefaultUFM
  510. :: Uniquable k
  511. => (a -> a) -> a -> k
  512. -> UniqFM a -> UniqFM a
  513. adjustWithDefaultUFM f def k map
  514. = addToUFM_C
  515. (\old _ -> f old)
  516. map
  517. k def
  518. -- Argument order different from UniqFM's adjustUFM
  519. {-# INLINE adjustUFM_C #-}
  520. adjustUFM_C
  521. :: Uniquable k
  522. => (a -> a)
  523. -> k -> UniqFM a -> UniqFM a
  524. adjustUFM_C f k map
  525. = case lookupUFM map k of
  526. Nothing -> map
  527. Just a -> addToUFM map k (f a)