PageRenderTime 58ms CodeModel.GetById 29ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/utils/GraphOps.hs

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