diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Binary.hs | 3 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 17 | ||||
| -rw-r--r-- | compiler/utils/Exception.hs | 6 | ||||
| -rw-r--r-- | compiler/utils/FastString.lhs | 5 | ||||
| -rw-r--r-- | compiler/utils/GraphColor.hs | 597 | ||||
| -rw-r--r-- | compiler/utils/GraphOps.hs | 923 | ||||
| -rw-r--r-- | compiler/utils/ListSetOps.lhs | 79 | ||||
| -rw-r--r-- | compiler/utils/MonadUtils.hs | 18 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 268 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs-boot | 7 | ||||
| -rw-r--r-- | compiler/utils/Panic.lhs | 197 | ||||
| -rw-r--r-- | compiler/utils/Platform.hs | 14 | ||||
| -rw-r--r-- | compiler/utils/Pretty.lhs | 9 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.lhs | 4 | ||||
| -rw-r--r-- | compiler/utils/Util.lhs | 211 |
15 files changed, 1153 insertions, 1205 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index feb4be50c1..77bd190fa9 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -267,9 +267,6 @@ expandBin (BinMem _ _ sz_r arr_r) off = do copyBytes new old sz writeFastMutInt sz_r sz' writeIORef arr_r arr' - when False $ -- disabled - hPutStrLn stderr ("Binary: expanding to size: " ++ show sz') - return () expandBin (BinIO _ _ _) _ = return () -- no need to expand a file, we'll assume they expand by themselves. diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 1bb460674c..9ae84a7897 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -47,7 +47,7 @@ module Digraph( ------------------------------------------------------------------------------ -import Util ( sortLe, minWith, count ) +import Util ( minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -59,7 +59,8 @@ import Control.Monad.ST -- std interfaces import Data.Maybe import Data.Array -import Data.List ( (\\) ) +import Data.List hiding (transpose) +import Data.Ord import Data.Array.ST import qualified Data.Map as Map import qualified Data.Set as Set @@ -140,8 +141,7 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte max_v = length nodes - 1 bounds = (0, max_v) :: (Vertex, Vertex) - sorted_nodes = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT - in sortLe le nodes + sorted_nodes = sortBy (comparing key_extractor) nodes numbered_nodes = zipWith (,) [0..] sorted_nodes key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes] @@ -240,9 +240,6 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) -instance PlatformOutputable a => PlatformOutputable (SCC a) where - pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) - pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ @@ -429,12 +426,6 @@ instance Show a => Show (Tree a) where showTree :: Show a => Tree a -> String showTree = drawTree . mapTree show -instance Show a => Show (Forest a) where - showsPrec _ f s = showForest f ++ s - -showForest :: Show a => Forest a -> String -showForest = unlines . map showTree - drawTree :: Tree String -> String drawTree = unlines . draw diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index 28196eba2b..db5bcad629 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -6,12 +6,10 @@ module Exception ) where -import Prelude hiding (catch) - import Control.Exception catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = catch +catchIO = Control.Exception.catch handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = flip catchIO @@ -75,7 +73,7 @@ class Monad m => ExceptionMonad m where return r instance ExceptionMonad IO where - gcatch = catch + gcatch = Control.Exception.catch gmask f = mask (\x -> f x) gblock = block gunblock = unblock diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index c37fc26f72..2c94de75f9 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -3,10 +3,6 @@ % \begin{code} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fno-warn-unused-imports #-} --- XXX GHC 6.9 seems to be confused by unpackCString# being used only in --- a RULE - {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -106,7 +102,6 @@ import Data.Maybe ( isJust ) import Data.Char ( ord ) import GHC.IO ( IO(..) ) -import GHC.Ptr ( Ptr(..) ) #if __GLASGOW_HASKELL__ >= 701 import Foreign.Safe diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs index b9ed3e2643..7ba8efbd03 100644 --- a/compiler/utils/GraphColor.hs +++ b/compiler/utils/GraphColor.hs @@ -1,22 +1,13 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. -- -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph +module GraphColor ( + module GraphBase, + module GraphOps, + module GraphPpr, + colorGraph ) where @@ -28,325 +19,351 @@ import GraphPpr import Unique import UniqFM import UniqSet -import Outputable +import Outputable import Data.Maybe import Data.List - + -- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. -- colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced - -- r1 should be replaced by r2 in the source + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced + -- r1 should be replaced by r2 in the source colorGraph iterative spinCount colors triv spill graph0 = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + -- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. +-- potentially uncolorable (problem) nodes. -- --- Checking whether a node is trivially colorable or not is a resonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- Checking whether a node is trivially colorable or not is a resonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. -- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. -- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are avaliable - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound @(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are avaliable + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound @(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce -- Select: -- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. -- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - -- | Try to assign a color to all these nodes. -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) -assignColors colors graph ks - = assignColors' colors graph [] ks + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of - where assignColors' _ graph prob [] - = (graph, prob) + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + | otherwise + = Nothing - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - | otherwise - = Nothing - - -- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. -- selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ uniqSetToList - $ nodeConflicts node - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concat $ map nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- uniqSetToList colors_ok - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ uniqSetToList + $ nodeConflicts node + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concat $ map nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- uniqSetToList colors_ok + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 69d4943fb0..7bf3ecdffb 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -1,28 +1,20 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Basic operations on graphs. -- module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount + addNode, delNode, getNode, lookupNode, modNode, + size, + union, + addConflict, delConflict, addConflicts, + addCoalesce, delCoalesce, + addExclusion, addExclusions, + addPreference, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, + setColor, + validateGraph, + slurpNodeConflictCount ) where @@ -33,610 +25,641 @@ import Unique import UniqSet import UniqFM -import Data.List hiding (union) +import Data.List hiding (union) import Data.Maybe -- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) -lookupNode graph k - = lookupUFM (graphMap graph) k +lookupNode graph k + = lookupUFM (graphMap graph) k -- | Get a node from the graph, throwing an error if it's not there getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color getNode graph k = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" -- | Add a node to the graph, linking up its edges addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict - = foldUniqSet - (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce - = foldUniqSet - (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - + = let + -- add back conflict edges from other nodes to this one + map_conflict + = foldUniqSet + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce + = foldUniqSet + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + -- | Delete a node and all its edges from the graph. delNode :: (Uniquable k, Outputable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) + => k -> Graph k cls color -> Maybe (Graph k cls color) delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ uniqSetToList (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ uniqSetToList (nodeCoalesce node) - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ uniqSetToList (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ uniqSetToList (nodeCoalesce node) + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing -- | Modify a node in the graph. --- returns Nothing if the node isn't present. +-- returns Nothing if the node isn't present. -- modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) modNode f k graph = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph - Nothing -> Nothing + Nothing -> Nothing -- | Get the size of the graph, O(n) -size :: Uniquable k - => Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - +size :: Uniquable k + => Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + -- | Union two graphs together. -union :: Uniquable k - => Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } +union :: Uniquable k + => Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } -- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. +-- Conflicts are virtual regs which need to be colored differently. addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + -- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 -- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. +-- All the nodes in the set are taken to conflict with each other. addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- uniqSetToList conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ uniqSetToList conflicts) + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color +addConflicts conflicts getClass -addConflictSet1 u getClass set + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- uniqSetToList conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ uniqSetToList conflicts) + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set = case delOneFromUniqSet set u of set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u -- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. +-- These are extra colors that the node cannot use. addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors + = foldr (addExclusion u getClass) graph colors -- | Add a coalescence edge to the graph, creating nodes if requried. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 . addCoalesce u2 c2 u1) -- | Delete a coalescence edge (k1 -> k2) from the graph. delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 -- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. +-- The most recently added preference is the most prefered. +-- The algorithm tries to assign a node it's prefered color if possible. -- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u -- | Do agressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coaleced together. --- for each pair, the resulting node will have the least key and be second in the pair. +-- returns the new graph and the list of pairs of nodes that got coaleced together. +-- for each pair, the resulting node will have the least key and be second in the pair. -- coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) coalesceGraph' aggressive triv graph kkPairsAcc = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ eltsUFM $ graphMap graph - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- uniqSetToList $ nodeCoalesce node1 ] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ eltsUFM $ graphMap graph + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- uniqSetToList $ nodeCoalesce node1 ] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) -- | Coalesce this pair of nodes unconditionally \/ agressively. --- The resulting node is the one with the least key. +-- The resulting node is the one with the least key. -- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one -- --- Nothing if either of the nodes weren't in the graph +-- Nothing if either of the nodes weren't in the graph coalesceNodes - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax +coalesceNodes_merge + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - in coalesceNodes_check aggressive triv graph kMin kMax node + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) coalesceNodes_check aggressive triv graph kMin kMax node - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 - in (graph3, Just (kMax, kMin)) + in (graph3, Just (kMax, kMin)) -- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. -- freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen freezeNode k = graphMapModify $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } - fm1 = addToUFM fm k node' + fm1 = addToUFM fm k node' - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - $ nodeCoalesce node + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + $ nodeCoalesce node - in fm2 + in fm2 -- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. -- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. -- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. -- freezeOneInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze + :: (Uniquable k, Outputable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - in case candidates of + in case candidates of - -- there wasn't anything available to freeze - [] -> (graph, False) + -- there wasn't anything available to freeze + [] -> (graph, False) - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) -- | Freeze all the nodes in the graph --- for debugging the iterative allocator. +-- for debugging the iterative allocator. -- freezeAllInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> Graph k cls color + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ eltsUFM $ graphMap graph + = foldr freezeNode graph + $ map nodeId + $ eltsUFM $ graphMap graph -- | Find all the nodes in the graph that meet some criteria -- scanGraph - :: Uniquable k - => (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] scanGraph match graph - = filter match $ eltsUFM $ graphMap graph + = filter match $ eltsUFM $ graphMap graph -- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error +-- all its edges should point to valid nodes +-- If they don't then throw an error -- validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph validateGraph doc isColored graph - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ eltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existant nodes" - $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GraphOps.validateGraph" + ( text "Graph has edges that point to non-existant nodes" + $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph -- | If this node is colored, check that all the nodes which --- conflict with it have different colors. +-- conflict with it have different colors. checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ uniqSetToList $ nodeConflicts node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True + | otherwise + = True -- | Slurp out a map of how many nodes had a certain number of conflict neighbours slurpNodeConflictCount - :: Uniquable k - => Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + :: Uniquable k + => Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ eltsUFM - $ graphMap graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ eltsUFM + $ graphMap graph -- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - + = addToUFM_C + (\old _ -> f old) + map + k def + -- Argument order different from UniqFM's adjustUFM {-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a adjustUFM_C f k map = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) + Nothing -> map + Just a -> addToUFM map k (f a) diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 2c6c6b0b6c..077eae2574 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -5,28 +5,16 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module ListSetOps ( unionLists, minusList, insertList, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, - emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C, - mkLookupFun, findInList, assocElts, -- Duplicate handling hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq, - - -- Remove redudant elts - removeRedundant -- Used in the ghc/InteractiveUI, - -- although not in the compiler itself ) where #include "HsVersions.h" @@ -77,22 +65,11 @@ Inefficient finite maps based on association lists and equality. -- A finite mapping based on equality and association lists type Assoc a b = [(a,b)] -emptyAssoc :: Assoc a b -unitAssoc :: a -> b -> Assoc a b -assocElts :: Assoc a b -> [(a,b)] assoc :: (Eq a) => String -> Assoc a b -> a -> b assocDefault :: (Eq a) => b -> Assoc a b -> a -> b assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b -mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c -extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b -plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b - -- combining fn takes (old->new->result) - -emptyAssoc = [] -unitAssoc a b = [(a,b)] -assocElts xs = xs assocDefaultUsing _ deflt [] _ = deflt assocDefaultUsing eq deflt ((k,v) : rest) key @@ -108,45 +85,8 @@ assocMaybe alist key where lookup [] = Nothing lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest - -mapAssoc f alist = [(key, f val) | (key,val) <- alist] - -plusAssoc_C _ [] new = new -- Shortcut for common case -plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new - -extendAssoc_C combine old_list (new_key, new_val) - = go old_list - where - go [] = [(new_key, new_val)] - go ((old_key, old_val) : old_list) - | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list) - | otherwise = (old_key, old_val) : go old_list -\end{code} - - -@mkLookupFun eq alist@ is a function which looks up -its argument in the association list @alist@, returning a Maybe type. -@mkLookupFunDef@ is similar except that it is given a value to return -on failure. - -\begin{code} -mkLookupFun :: (key -> key -> Bool) -- Equality predicate - -> [(key,val)] -- The assoc list - -> key -- The key - -> Maybe val -- The corresponding value - -mkLookupFun eq alist s - = case [a | (s',a) <- alist, s' `eq` s] of - [] -> Nothing - (a:_) -> Just a - -findInList :: (a -> Bool) -> [a] -> Maybe a -findInList _ [] = Nothing -findInList p (x:xs) | p x = Just x - | otherwise = findInList p xs \end{code} - %************************************************************************ %* * \subsection[Utils-dups]{Duplicate-handling} @@ -173,10 +113,9 @@ equivClasses :: (a -> a -> Ordering) -- Comparison equivClasses _ [] = [] equivClasses _ stuff@[_] = [stuff] -equivClasses cmp items = runs eq (sortLe le items) +equivClasses cmp items = runs eq (sortBy cmp items) where eq a b = case cmp a b of { EQ -> True; _ -> False } - le a b = case cmp a b of { LT -> True; EQ -> True; GT -> False } \end{code} The first cases in @equivClasses@ above are just to cut to the point @@ -218,22 +157,6 @@ findDupsEq _ [] = [] findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs | otherwise = (x:eq_xs) : findDupsEq eq neq_xs where (eq_xs, neq_xs) = partition (eq x) xs - -removeRedundant :: (a -> a -> Bool) -- True <=> discard the *second* argument - -> [a] -> [a] --- Remove any element y for which --- another element x is in the list --- and (x `subsumes` y) --- Preserves order -removeRedundant subsumes xs - = WARN( length xs > 10, text "removeRedundant" <+> int (length xs) ) - -- This is a quadratic algorithm :-) so warn if the list gets long - go [] xs - where - go acc [] = reverse acc - go acc (x:xs) - | any (`subsumes` x) acc = go acc xs - | otherwise = go (x : filterOut (x `subsumes`) acc) xs \end{code} diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 3108a03d64..6f15ecc03d 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -16,8 +16,6 @@ module MonadUtils , MonadFix(..) , MonadIO(..) - , ID, runID - , liftIO1, liftIO2, liftIO3, liftIO4 , zipWith3M @@ -32,8 +30,6 @@ module MonadUtils , maybeMapM ) where -import Outputable - ------------------------------------------------------------------------------- -- Detection of available libraries ------------------------------------------------------------------------------- @@ -55,20 +51,6 @@ import Control.Monad import Control.Monad.Fix ------------------------------------------------------------------------------- --- The ID monad -------------------------------------------------------------------------------- - -newtype ID a = ID a -instance Monad ID where - return x = ID x - (ID x) >>= f = f x - _ >> y = y - fail s = panic s - -runID :: ID a -> a -runID (ID x) = x - -------------------------------------------------------------------------------- -- MTL ------------------------------------------------------------------------------- diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index c506e23410..7ffce77a47 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,7 +13,6 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), - PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -23,7 +22,8 @@ module Outputable ( char, text, ftext, ptext, int, intWithCommas, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, paBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, @@ -38,13 +38,13 @@ module Outputable ( colBinder, bold, keyword, -- * Converting 'SDoc' into strings and outputing it - printSDoc, printErrs, printOutput, hPrintDump, printDump, + hPrintDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, showSDoc, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showPpr, - showSDocUnqual, showsPrecSDoc, + showSDocUnqual, renderWithStyle, pprInfixVar, pprPrefixVar, @@ -56,6 +56,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, QualifyName(..), + sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, @@ -66,18 +67,21 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, pprDefiniteTrace, warnPprTrace, - trace, pgmError, panic, sorry, panicFastInt, assertPanic + trace, pgmError, panic, sorry, panicFastInt, assertPanic, + pprDebugAndThen, ) where +import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags, + targetPlatform, pprUserLength, pprCols ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) import StaticFlags import FastString import FastTypes -import Platform import qualified Pretty -import Util ( snocView ) +import Util +import Platform import Pretty ( Doc, Mode(..) ) import Panic @@ -87,7 +91,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set import Data.Word -import System.IO ( Handle, stderr, stdout, hFlush ) +import System.IO ( Handle, hFlush ) import System.FilePath @@ -192,16 +196,17 @@ defaultDumpStyle | opt_PprStyle_Debug = PprDebug | otherwise = PprDump -- | Style for printing error messages -mkErrStyle :: PrintUnqualified -> PprStyle -mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength) +mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags)) -defaultErrStyle :: PprStyle +defaultErrStyle :: DynFlags -> PprStyle -- Default style for error messages -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs -defaultErrStyle - | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay - | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) +defaultErrStyle dflags = mkUserStyle alwaysQualify depth + where depth = if opt_PprStyle_Debug + then AllTheWay + else PartWay (pprUserLength dflags) mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth @@ -233,19 +238,21 @@ data SDocContext = SDC { sdocStyle :: !PprStyle , sdocLastColour :: !PprColour -- ^ The most recently used colour. This allows nesting colours. + , sdocDynFlags :: !DynFlags } -initSDocContext :: PprStyle -> SDocContext -initSDocContext sty = SDC +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags sty = SDC { sdocStyle = sty , sdocLastColour = colReset + , sdocDynFlags = dflags } withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} -withPprStyleDoc :: PprStyle -> SDoc -> Doc -withPprStyleDoc sty d = runSDoc d (initSDocContext sty) +withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc +withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) pprDeeper :: SDoc -> SDoc pprDeeper d = SDoc $ \ctx -> case ctx of @@ -278,6 +285,12 @@ pprSetDepth depth doc = SDoc $ \ctx -> getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithPlatform :: (Platform -> SDoc) -> SDoc +sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \end{code} \begin{code} @@ -317,53 +330,35 @@ ifPprDebug d = SDoc $ \ctx -> \end{code} \begin{code} --- Unused [7/02 sof] -printSDoc :: SDoc -> PprStyle -> IO () -printSDoc d sty = do - Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty)) - hFlush stdout - --- I'm not sure whether the direct-IO approach of Pretty.printDoc --- above is better or worse than the put-big-string approach here -printErrs :: SDoc -> PprStyle -> IO () -printErrs doc sty = do - Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty)) - hFlush stderr - -printOutput :: Doc -> IO () -printOutput doc = Pretty.printDoc PageMode stdout doc - -printDump :: SDoc -> IO () -printDump doc = hPrintDump stdout doc - -hPrintDump :: Handle -> SDoc -> IO () -hPrintDump h doc = do - Pretty.printDoc PageMode h - (runSDoc better_doc (initSDocContext defaultDumpStyle)) +hPrintDump :: DynFlags -> Handle -> SDoc -> IO () +hPrintDump dflags h doc = do + Pretty.printDoc PageMode (pprCols dflags) h + (runSDoc better_doc (initSDocContext dflags defaultDumpStyle)) hFlush h where better_doc = doc $$ blankLine -printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () -printForUser handle unqual doc - = Pretty.printDoc PageMode handle - (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () +printForUser dflags handle unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) -printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () -printForUserPartWay handle d unqual doc - = Pretty.printDoc PageMode handle - (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d)))) +printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc + -> IO () +printForUserPartWay dflags handle d unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d)))) -- printForC, printForAsm do what they sound like -printForC :: Handle -> SDoc -> IO () -printForC handle doc = - Pretty.printDoc LeftMode handle - (runSDoc doc (initSDocContext (PprCode CStyle))) +printForC :: DynFlags -> Handle -> SDoc -> IO () +printForC dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode CStyle))) -printForAsm :: Handle -> SDoc -> IO () -printForAsm handle doc = - Pretty.printDoc LeftMode handle - (runSDoc doc (initSDocContext (PprCode AsmStyle))) +printForAsm :: DynFlags -> Handle -> SDoc -> IO () +printForAsm dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -374,48 +369,45 @@ mkCodeStyle = PprCode -- Can't make SDoc an instance of Show because SDoc is just a function type -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string -showSDoc :: SDoc -> String -showSDoc d = +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags d = Pretty.showDocWith PageMode - (runSDoc d (initSDocContext defaultUserStyle)) + (runSDoc d (initSDocContext dflags defaultUserStyle)) -renderWithStyle :: SDoc -> PprStyle -> String -renderWithStyle sdoc sty = - Pretty.render (runSDoc sdoc (initSDocContext sty)) +renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String +renderWithStyle dflags sdoc sty = + Pretty.render (runSDoc sdoc (initSDocContext dflags sty)) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. -showSDocOneLine :: SDoc -> String -showSDocOneLine d = - Pretty.showDocWith PageMode - (runSDoc d (initSDocContext defaultUserStyle)) +showSDocOneLine :: DynFlags -> SDoc -> String +showSDocOneLine dflags d + = Pretty.showDocWith PageMode + (runSDoc d (initSDocContext dflags defaultUserStyle)) -showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = - show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +showSDocForUser dflags unqual doc + = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) -showSDocUnqual :: SDoc -> String +showSDocUnqual :: DynFlags -> SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = - show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) - -showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) +showSDocUnqual dflags d + = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay))) -showSDocDump :: SDoc -> String -showSDocDump d = - Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle)) -showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = - Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump)) -showSDocDebug :: SDoc -> String -showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug)) -showPpr :: Outputable a => a -> String -showPpr = showSDoc . ppr +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags = showSDoc dflags . ppr \end{code} \begin{code} @@ -444,27 +436,31 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n -parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc +parens, braces, brackets, quotes, quote, + paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' +paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]") cparen :: Bool -> SDoc -> SDoc cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- 'quotes' encloses something in single quotes... --- but it omits them if the thing ends in a single quote +-- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. quotes d = SDoc $ \sty -> - let pp_d = runSDoc d sty in - case snocView (show pp_d) of - Just (_, '\'') -> pp_d - _other -> Pretty.quotes pp_d + let pp_d = runSDoc d sty + str = show pp_d + in case (str, snocView str) of + (_, Just (_, '\'')) -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc @@ -611,13 +607,6 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr - -class PlatformOutputable a where - pprPlatform :: Platform -> a -> SDoc - pprPlatformPrec :: Platform -> Rational -> a -> SDoc - - pprPlatform platform = pprPlatformPrec platform 0 - pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -627,8 +616,6 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n -instance PlatformOutputable Int where - pprPlatform _ = ppr instance Outputable Word16 where ppr n = integer $ fromIntegral n @@ -641,29 +628,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" -instance PlatformOutputable () where - pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) -instance (PlatformOutputable a) => PlatformOutputable [a] where - pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a) => Outputable (Set a) where ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) -instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where - pprPlatform platform (x,y) - = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") ppr (Just x) = ptext (sLit "Just") <+> ppr x -instance PlatformOutputable a => PlatformOutputable (Maybe a) where - pprPlatform _ Nothing = ptext (sLit "Nothing") - pprPlatform platform (Just x) = ptext (sLit "Just") <+> pprPlatform platform x instance (Outputable a, Outputable b) => Outputable (Either a b) where ppr (Left x) = ptext (sLit "Left") <+> ppr x @@ -720,8 +697,6 @@ instance Outputable FastString where instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) -instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where - pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) instance (PlatformOutputable elt) => PlatformOutputable (Set.Set elt) where @@ -920,62 +895,57 @@ plural _ = char 's' pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" -pprPanic = pprAndThen panic +pprPanic = panicDoc pprSorry :: String -> SDoc -> a -- ^ Throw an exception saying "this isn't finished yet" -pprSorry = pprAndThen sorry +pprSorry = sorryDoc pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pprAndThen pgmError +pprPgmError = pgmErrorDoc pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x - | otherwise = pprAndThen trace str doc x + | otherwise = pprDebugAndThen tracingDynFlags trace str doc x -pprDefiniteTrace :: String -> SDoc -> a -> a +pprDefiniteTrace :: DynFlags -> String -> SDoc -> a -> a -- ^ Same as pprTrace, but show even if -dno-debug-output is on -pprDefiniteTrace str doc x = pprAndThen trace str doc x +pprDefiniteTrace dflags str doc x = pprDebugAndThen dflags trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' -pprPanicFastInt heading pretty_msg = - panicFastInt (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = text heading <+> pretty_msg - - -pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = - cont (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [text heading, nest 4 pretty_msg] - -assertPprPanic :: String -> Int -> SDoc -> a --- ^ Panic with an assertation failure, recording the given file and line number. --- Should typically be accessed with the ASSERT family of macros -assertPprPanic file line msg - = panic (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg] +pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x + = pprDebugAndThen tracingDynFlags trace str msg x + where + str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line]) + +assertPprPanic :: String -> Int -> SDoc -> a +-- ^ Panic with an assertation failure, recording the given file and line number. +-- Should typically be accessed with the ASSERT family of macros +assertPprPanic file line msg + = pprDebugAndThen tracingDynFlags panic "ASSERT failed!" doc where - doc = sep [hsep [text "WARNING: file", text file, text "line", int line], - msg] + doc = sep [ hsep [ text "file", text file + , text "line", int line ] + , msg ] + +pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (show (runSDoc doc (initSDocContext dflags PprDebug))) + where + doc = sep [text heading, nest 4 pretty_msg] \end{code} diff --git a/compiler/utils/Outputable.lhs-boot b/compiler/utils/Outputable.lhs-boot new file mode 100644 index 0000000000..e013307ef9 --- /dev/null +++ b/compiler/utils/Outputable.lhs-boot @@ -0,0 +1,7 @@ + +\begin{code} +module Outputable where + +data SDoc +\end{code} + diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index cc3603baeb..a459199fdb 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -8,33 +8,33 @@ It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Panic ( GhcException(..), showGhcException, throwGhcException, handleGhcException, ghcError, progName, pgmError, panic, sorry, panicFastInt, assertPanic, trace, - - Exception.Exception(..), showException, try, tryMost, throwTo, + panicDoc, sorryDoc, panicDocFastInt, pgmErrorDoc, + + Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, - installSignalHandlers, interruptTargetThread + installSignalHandlers, + pushInterruptTargetThread, popInterruptTargetThread ) where #include "HsVersions.h" +import {-# SOURCE #-} Outputable (SDoc) + import Config import FastTypes import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, - myThreadId ) + +import Control.Concurrent import Data.Dynamic -import Debug.Trace ( trace ) +#if __GLASGOW_HASKELL__ < 705 +import Data.Maybe +#endif +import Debug.Trace ( trace ) import System.IO.Unsafe import System.Exit import System.Environment @@ -51,44 +51,51 @@ import GHC.ConsoleHandler import GHC.Stack #endif --- | GHC's own exception type +#if __GLASGOW_HASKELL__ >= 705 +import System.Mem.Weak ( Weak, deRefWeak ) +#endif + +-- | GHC's own exception type -- error messages all take the form: -- -- @ --- <location>: <error> +-- <location>: <error> -- @ --- --- If the location is on the command line, or in GHC itself, then --- <location>="ghc". All of the error types below correspond to +-- +-- If the location is on the command line, or in GHC itself, then +-- <location>="ghc". All of the error types below correspond to -- a <location> of "ghc", except for ProgramError (where the string is -- assumed to contain a location already, so we don't print one). data GhcException - = PhaseFailed String -- name of phase - ExitCode -- an external phase (eg. cpp) failed + = PhaseFailed String -- name of phase + ExitCode -- an external phase (eg. cpp) failed -- | Some other fatal signal (SIGHUP,SIGTERM) - | Signal Int + | Signal Int -- | Prints the short usage msg after the error - | UsageError String + | UsageError String -- | A problem with the command line arguments, but don't print usage. | CmdLineError String -- | The 'impossible' happened. - | Panic String + | Panic String + | PprPanic String SDoc - -- | The user tickled something that's known not to work yet, + -- | The user tickled something that's known not to work yet, -- but we're not counting it as a bug. | Sorry String + | PprSorry String SDoc -- | An installation problem. | InstallationError String -- | An error in the user's code, probably. - | ProgramError String - deriving (Typeable, Eq) + | ProgramError String + | PprProgramError String SDoc + deriving (Typeable) instance Exception GhcException @@ -113,41 +120,59 @@ short_usage = "Usage: For basic information, try the `--help' option." showException :: Exception e => e -> String showException = show +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. showGhcException :: GhcException -> String -> String showGhcException exception = case exception of - UsageError str - -> showString str . showChar '\n' . showString short_usage - - PhaseFailed phase code - -> showString "phase `" . showString phase . - showString "' failed (exitcode = " . shows (int_code code) . - showString ")" - - CmdLineError str -> showString str - ProgramError str -> showString str - InstallationError str -> showString str - Signal n -> showString "signal: " . shows n - - Panic s - -> showString $ - "panic! (the 'impossible' happened)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n\n" - ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" - - Sorry s - -> showString $ - "sorry! (unimplemented feature or known bug)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n" - - where int_code code = - case code of - ExitSuccess -> (0::Int) - ExitFailure x -> x + UsageError str + -> showString str . showChar '\n' . showString short_usage + + PhaseFailed phase code + -> showString "phase `" . showString phase . + showString "' failed (exitcode = " . shows (int_code code) . + showString ")" + + CmdLineError str -> showString str + PprProgramError str _ -> + showGhcException (ProgramError (str ++ "\n<<details unavailable>>")) + ProgramError str -> showString str + InstallationError str -> showString str + Signal n -> showString "signal: " . shows n + + PprPanic s _ -> + showGhcException (Panic (s ++ "\n<<details unavailable>>")) + Panic s + -> showString $ + "panic! (the 'impossible' happened)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n\n" + ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" + + PprSorry s _ -> + showGhcException (Sorry (s ++ "\n<<details unavailable>>")) + Sorry s + -> showString $ + "sorry! (unimplemented feature or known bug)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n" + + where int_code code = + case code of + ExitSuccess -> (0::Int) + ExitFailure x -> x -- | Alias for `throwGhcException` @@ -176,6 +201,11 @@ panic x = throwGhcException (Panic x) sorry x = throwGhcException (Sorry x) pgmError x = throwGhcException (ProgramError x) +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + -- | Panic while pretending to return an unboxed int. -- You can't use the regular panic functions in expressions @@ -183,11 +213,14 @@ pgmError x = throwGhcException (ProgramError x) panicFastInt :: String -> FastInt panicFastInt s = case (panic s) of () -> _ILIT(0) +panicDocFastInt :: String -> SDoc -> FastInt +panicDocFastInt s d = case (panicDoc s d) of () -> _ILIT(0) + -- | Throw an failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a -assertPanic file line = - Exception.throw (Exception.AssertionFailed +assertPanic file line = + Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) @@ -221,20 +254,20 @@ tryMost action = do r <- try action installSignalHandlers :: IO () installSignalHandlers = do main_thread <- myThreadId - modifyMVar_ interruptTargetThread (return . (main_thread :)) + pushInterruptTargetThread main_thread let interrupt_exn = (toException UserInterrupt) interrupt = do - withMVar interruptTargetThread $ \targets -> - case targets of - [] -> return () - (thread:_) -> throwTo thread interrupt_exn + mt <- peekInterruptTargetThread + case mt of + Nothing -> return () + Just t -> throwTo t interrupt_exn -- #if !defined(mingw32_HOST_OS) - _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing -- see #3656; in the future we should install these automatically for -- all Haskell programs in the same way that we install a ^C handler. @@ -256,8 +289,44 @@ installSignalHandlers = do return () #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# NOINLINE interruptTargetThread #-} +interruptTargetThread :: MVar [Weak ThreadId] +interruptTargetThread = unsafePerformIO (newMVar []) + +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + wtid <- mkWeakThreadId tid + modifyMVar_ interruptTargetThread $ return . (wtid :) + +peekInterruptTargetThread :: IO (Maybe ThreadId) +peekInterruptTargetThread = + withMVar interruptTargetThread $ loop + where + loop [] = return Nothing + loop (t:ts) = do + r <- deRefWeak t + case r of + Nothing -> loop ts + Just t -> return (Just t) +#else {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + modifyMVar_ interruptTargetThread $ return . (tid :) + +peekInterruptTargetThread :: IO (Maybe ThreadId) +peekInterruptTargetThread = + withMVar interruptTargetThread $ return . listToMaybe +#endif + +popInterruptTargetThread :: IO () +popInterruptTargetThread = + modifyMVar_ interruptTargetThread $ + \tids -> return $! case tids of [] -> [] + (_:ts) -> ts + \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 66f51e64e6..8252621661 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -7,6 +7,7 @@ module Platform ( OS(..), ArmISA(..), ArmISAExt(..), + ArmABI(..), target32Bit, osElfTarget @@ -41,7 +42,9 @@ data Arch | ArchSPARC | ArchARM { armISA :: ArmISA - , armISAExt :: [ArmISAExt] } + , armISAExt :: [ArmISAExt] + , armABI :: ArmABI + } deriving (Read, Show, Eq) @@ -58,9 +61,10 @@ data OS | OSOpenBSD | OSNetBSD | OSKFreeBSD + | OSHaiku deriving (Read, Show, Eq) --- | ARM Instruction Set Architecture and Extensions +-- | ARM Instruction Set Architecture, Extensions and ABI -- data ArmISA = ARMv5 @@ -76,6 +80,11 @@ data ArmISAExt | IWMMX2 deriving (Read, Show, Eq) +data ArmABI + = SOFT + | SOFTFP + | HARD + deriving (Read, Show, Eq) target32Bit :: Platform -> Bool target32Bit p = platformWordSize p == 4 @@ -91,6 +100,7 @@ osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = True osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index cc8f235f2c..abe8957966 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -1002,13 +1002,10 @@ spaces n | n <=# _ILIT(0) = "" \end{code} \begin{code} -pprCols :: Int -pprCols = opt_PprCols - -printDoc :: Mode -> Handle -> Doc -> IO () -printDoc LeftMode hdl doc +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +printDoc LeftMode _ hdl doc = do { printLeftRender hdl doc; hFlush hdl } -printDoc mode hdl doc +printDoc mode pprCols hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } where diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 4ee6e190cc..259689c454 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,7 +20,9 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index d09a1ad345..9d12946052 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -19,7 +19,7 @@ module Util ( unzipWith, mapFst, mapSnd, - mapAndUnzip, mapAndUnzip3, + mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, foldl1', foldl2, count, all2, @@ -35,6 +35,7 @@ module Util ( -- * Tuples fstOf3, sndOf3, thirdOf3, firstM, first3M, + third3, uncurry3, -- * List operations controlled by another list @@ -45,7 +46,7 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, minWith, on, + sortWith, minWith, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -74,7 +75,6 @@ module Util ( maybeRead, maybeReadFuzzy, -- * IO-ish utilities - createDirectoryHierarchy, doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, @@ -92,7 +92,10 @@ module Util ( abstractConstr, abstractDataType, mkNoRepType, -- * Utils for printing C code - charToC + charToC, + + -- * Hashing + hashString, ) where #include "HsVersions.h" @@ -109,13 +112,13 @@ import Data.List hiding (group) import FastTypes #endif -import Control.Monad ( unless, liftM ) +import Control.Monad ( liftM ) import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, createDirectory, - getModificationTime ) +import System.Directory ( doesDirectoryExist, getModificationTime ) import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) +import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits @@ -226,6 +229,9 @@ fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c \end{code} @@ -308,12 +314,7 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] --- We want to write this, but with GHC 6.4 we get a warning, so it --- doesn't validate: --- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys --- so we write this instead: -zipLazy (x:xs) zs = let y : ys = zs - in (x,y) : zipLazy xs ys +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys \end{code} @@ -355,6 +356,12 @@ mapAndUnzip3 f (x:xs) (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs \end{code} \begin{code} @@ -469,114 +476,17 @@ isn'tIn msg x ys %************************************************************************ %* * -\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} +\subsubsection{Sort utils} %* * %************************************************************************ -\begin{display} -Date: Mon, 3 May 93 20:45:23 +0200 -From: Carsten Kehler Holst <kehler@cs.chalmers.se> -To: partain@dcs.gla.ac.uk -Subject: natural merge sort beats quick sort [ and it is prettier ] - -Here is a piece of Haskell code that I'm rather fond of. See it as an -attempt to get rid of the ridiculous quick-sort routine. groupUpdown is -quite useful by itself I think it was John's idea originally though I -believe the lazy version is due to me [surprisingly complicated]. -gamma [used to be called] is called gamma because I got inspired by -the Gamma calculus. It is not very close to the calculus but does -behave less sequentially than both foldr and foldl. One could imagine -a version of gamma that took a unit element as well thereby avoiding -the problem with empty lists. - -I've tried this code against - - 1) insertion sort - as provided by haskell - 2) the normal implementation of quick sort - 3) a deforested version of quick sort due to Jan Sparud - 4) a super-optimized-quick-sort of Lennart's - -If the list is partially sorted both merge sort and in particular -natural merge sort wins. If the list is random [ average length of -rising subsequences = approx 2 ] mergesort still wins and natural -merge sort is marginally beaten by Lennart's soqs. The space -consumption of merge sort is a bit worse than Lennart's quick sort -approx a factor of 2. And a lot worse if Sparud's bug-fix [see his -fpca article ] isn't used because of groupUpdown. - -have fun -Carsten -\end{display} - \begin{code} -groupUpdown :: (a -> a -> Bool) -> [a] -> [[a]] --- Given a <= function, groupUpdown finds maximal contiguous up-runs --- or down-runs in the input list. --- It's stable, in the sense that it never re-orders equal elements --- --- Date: Mon, 12 Feb 1996 15:09:41 +0000 --- From: Andy Gill <andy@dcs.gla.ac.uk> --- Here is a `better' definition of groupUpdown. - -groupUpdown _ [] = [] -groupUpdown p (x:xs) = group' xs x x (x :) - where - group' [] _ _ s = [s []] - group' (x:xs) x_min x_max s - | x_max `p` x = group' xs x_min x (s . (x :)) - | not (x_min `p` x) = group' xs x x_max ((x :) . s) - | otherwise = s [] : group' xs x x (x :) - -- NB: the 'not' is essential for stablity - -- x `p` x_min would reverse equal elements - -generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] -generalMerge _ xs [] = xs -generalMerge _ [] ys = ys -generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) - | otherwise = y : generalMerge p (x:xs) ys - --- gamma is now called balancedFold - -balancedFold :: (a -> a -> a) -> [a] -> a -balancedFold _ [] = error "can't reduce an empty list using balancedFold" -balancedFold _ [x] = x -balancedFold f l = balancedFold f (balancedFold' f l) - -balancedFold' :: (a -> a -> a) -> [a] -> [a] -balancedFold' f (x:y:xs) = f x y : balancedFold' f xs -balancedFold' _ xs = xs - -generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a] -generalNaturalMergeSort _ [] = [] -generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . groupUpdown p) xs - -#if NOT_USED -generalMergeSort p [] = [] -generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs - -mergeSort, naturalMergeSort :: Ord a => [a] -> [a] - -mergeSort = generalMergeSort (<=) -naturalMergeSort = generalNaturalMergeSort (<=) - -mergeSortLe le = generalMergeSort le -#endif - -sortLe :: (a->a->Bool) -> [a] -> [a] -sortLe le = generalNaturalMergeSort le - sortWith :: Ord b => (a->b) -> [a] -> [a] -sortWith get_key xs = sortLe le xs - where - x `le` y = get_key x < get_key y +sortWith get_key xs = sortBy (comparing get_key) xs minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) - -on :: (a -> a -> c) -> (b -> a) -> b -> b -> c -on cmp sel = \x y -> sel x `cmp` sel y - \end{code} %************************************************************************ @@ -1018,16 +928,6 @@ maybeReadFuzzy str = case reads str of Nothing ----------------------------------------------------------------------------- --- Create a hierarchy of directories - -createDirectoryHierarchy :: FilePath -> IO () -createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack -createDirectoryHierarchy dir = do - b <- doesDirectoryExist dir - unless b $ do createDirectoryHierarchy (takeDirectory dir) - createDirectory dir - ------------------------------------------------------------------------------ -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool @@ -1153,3 +1053,70 @@ charToC w = chr (ord '0' + ord c `mod` 8)] \end{code} +%************************************************************************ +%* * +\subsection[Utils-Hashing]{Utils for hashing} +%* * +%************************************************************************ + +\begin{code} +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = 0xdeadbeef + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b +\end{code} + |