PageRenderTime 54ms CodeModel.GetById 23ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/utils/GraphOps.hs

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