diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Binary.hs | 30 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 79 | ||||
| -rw-r--r-- | compiler/utils/FastString.lhs | 2 | ||||
| -rw-r--r-- | compiler/utils/OrdList.lhs | 4 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 61 | ||||
| -rw-r--r-- | compiler/utils/Util.lhs | 6 |
6 files changed, 115 insertions, 67 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 166a94850b..0aa8c648b8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -833,18 +833,30 @@ instance Binary RecFlag where 0 -> do return Recursive _ -> do return NonRecursive -instance Binary OverlapFlag where - put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b - put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b - put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b +instance Binary OverlapMode where + put_ bh NoOverlap = putByte bh 0 + put_ bh Overlaps = putByte bh 1 + put_ bh Incoherent = putByte bh 2 + put_ bh Overlapping = putByte bh 3 + put_ bh Overlappable = putByte bh 4 get bh = do h <- getByte bh - b <- get bh case h of - 0 -> return $ NoOverlap b - 1 -> return $ OverlapOk b - 2 -> return $ Incoherent b - _ -> panic ("get OverlapFlag " ++ show h) + 0 -> return NoOverlap + 1 -> return Overlaps + 2 -> return Incoherent + 3 -> return Overlapping + 4 -> return Overlappable + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } instance Binary FixityDirection where put_ bh InfixL = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index d22380ff6e..35782bac6e 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -4,13 +4,6 @@ \begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, @@ -24,7 +17,7 @@ module Digraph( componentsG, findCycle, - + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -77,14 +70,14 @@ Note [Nodes, keys, vertices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A 'node' is a big blob of client-stuff - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n + arranged densely in 0.n \begin{code} -data Graph node = Graph { +data Graph node = Graph { gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, gr_node_to_vertex :: node -> Maybe Vertex @@ -92,12 +85,12 @@ data Graph node = Graph { data Edge node = Edge node node -type Node key payload = (payload, key, [key]) +type Node key payload = (payload, key, [key]) -- The payload is user data, just carried around in this module -- The keys are ordered - -- The [key] are the dependencies of the node; + -- The [key] are the dependencies of the node; -- it's ok to have extra keys in the dependencies that - -- are not the key of any Node in the graph + -- are not the key of any Node in the graph emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -105,7 +98,7 @@ emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) graphFromVerticesAndAdjacency :: Ord key => [(node, key)] - -> [(key, key)] -- First component is source vertex key, + -> [(key, key)] -- First component is source vertex key, -- second is target vertex key (thing depended on) -- Unlike the other interface I insist they correspond to -- actual vertices because the alternative hides bugs. I can't @@ -115,7 +108,7 @@ graphFromVerticesAndAdjacency [] _ = emptyGraph graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) where key_extractor = snd (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor - key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) reduced_edges = map key_vertex_pair edges graph = buildG bounds reduced_edges @@ -132,10 +125,10 @@ graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_ (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes] -reduceNodesIntoVertices - :: Ord key - => [node] - -> (node -> key) +reduceNodesIntoVertices + :: Ord key + => [node] + -> (node -> key) -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)]) reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes) where @@ -168,18 +161,18 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte \begin{code} type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a -- | Find a reasonably short cycle a->b->c->a, in a strongly -- connected component. The input nodes are presumed to be -- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key +findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next findCycle graph = go Set.empty (new_work root_deps []) [] where @@ -189,29 +182,29 @@ findCycle graph -- Find the node with fewest dependencies among the SCC modules -- This is just a heuristic to find some plausible root module root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) deps) + root = fst (minWith snd [ (node, count (`Map.member` env) deps) | node@(_,_,deps) <- graph ]) (root_payload,root_key,root_deps) = root -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle -- Invariant: in a call (go visited ps qs), -- visited = union (map tail (ps ++ qs)) - go _ [] [] = Nothing -- No cycles + go _ [] [] = Nothing -- No cycles go visited [] qs = go visited qs [] - go visited (((payload,key,deps), path) : ps) qs + go visited (((payload,key,deps), path) : ps) qs | key == root_key = Just (root_payload : reverse path) | key `Set.member` visited = go visited ps qs | key `Map.notMember` env = go visited ps qs | otherwise = go (Set.insert key visited) ps (new_qs ++ qs) where - new_qs = new_work deps (payload : path) + new_qs = new_work deps (payload : path) new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] @@ -250,7 +243,7 @@ instance Outputable a => Outputable (SCC a) where %************************************************************************ Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have +depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. \begin{code} @@ -311,7 +304,7 @@ reachableG graph from = map (gr_vertex_to_node graph) result reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} + where result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) vs vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] @@ -656,18 +649,18 @@ noOutEdges g = [ v | v <- vertices g, null (g!v)] vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]] vertexGroupsS provided g to_provide - = if null to_provide - then do { + = if null to_provide + then do { all_provided <- allM (provided `contains`) (vertices g) ; if all_provided then return [] - else error "vertexGroup: cyclic graph" + else error "vertexGroup: cyclic graph" } - else do { + else do { mapM_ (include provided) to_provide ; to_provide' <- filterM (vertexReady provided g) (vertices g) ; rest <- vertexGroupsS provided g to_provide' - ; return $ to_provide : rest + ; return $ to_provide : rest } vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 0396c02749..157e5f08b0 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -239,7 +239,7 @@ data FastStringTable = string_table :: FastStringTable {-# NOINLINE string_table #-} string_table = unsafePerformIO $ do - uid <- newIORef 0 + uid <- newIORef 603979776 -- ord '$' * 0x01000000 tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of (# s2#, arr# #) -> (# s2#, FastStringTable uid arr# #) diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.lhs index d1d8708dd3..42abb51696 100644 --- a/compiler/utils/OrdList.lhs +++ b/compiler/utils/OrdList.lhs @@ -15,6 +15,8 @@ module OrdList ( mapOL, fromOL, toOL, foldrOL, foldlOL ) where +import Outputable + infixl 5 `appOL` infixl 5 `snocOL` infixr 5 `consOL` @@ -28,6 +30,8 @@ data OrdList a | Two (OrdList a) -- Invariant: non-empty (OrdList a) -- Invariant: non-empty +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that nilOL :: OrdList a isNilOL :: OrdList a -> Bool diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index e32261de65..a65607a7c3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -53,15 +53,17 @@ module Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, - QualifyName(..), + QualifyName(..), queryQual, sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, + ifPprDebug, qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), @@ -76,7 +78,7 @@ import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, unsafeGlobalDynFlags ) -import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) +import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) @@ -142,12 +144,15 @@ data Depth = AllTheWay -- ----------------------------------------------------------------------------- -- Printing original names --- When printing code that contains original names, we need to map the +-- | When printing code that contains original names, we need to map the -- original names back to something the user understands. This is the --- purpose of the pair of functions that gets passed around +-- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. - -type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} -- | given an /original/ name, this function tells you which module -- name it should be qualified with when printing for the user, if @@ -161,6 +166,9 @@ type QueryQualifyName = Module -> OccName -> QualifyName -- a package name to disambiguate it. type QueryQualifyModule = Module -> Bool +-- | For a given package, we need to know whether to print it with +-- the package key to disambiguate it. +type QueryQualifyPackage = PackageKey -> Bool -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -173,6 +181,10 @@ data QualifyName -- given P:M.T -- it is not in scope at all, and M.T is already bound in the -- current scope, so we must refer to it as "P:M.T" +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName alwaysQualifyNames m _ = NameQual (moduleName m) @@ -185,9 +197,23 @@ alwaysQualifyModules _ = True neverQualifyModules :: QueryQualifyModule neverQualifyModules _ = False -alwaysQualify, neverQualify :: PrintUnqualified -alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) -neverQualify = (neverQualifyNames, neverQualifyModules) +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages defaultUserStyle, defaultDumpStyle :: PprStyle @@ -297,13 +323,22 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) mod occ = qual_name mod occ +qualName (PprUser q _) mod occ = queryQualifyName q mod occ qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule (PprUser q _) m = queryQualifyModule q m qualModule _other _m = True +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0274c590ea..2dcc73fd89 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -47,7 +47,7 @@ module Util ( nTimes, -- * Sorting - sortWith, minWith, + sortWith, minWith, nubSort, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -126,6 +126,7 @@ import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM +import qualified Data.Set as Set import Data.Time #if __GLASGOW_HASKELL__ < 705 @@ -490,6 +491,9 @@ 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) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList \end{code} %************************************************************************ |