diff options
| -rw-r--r-- | compiler/cmm/CmmUtils.hs | 7 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 68 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 9 | ||||
| -rw-r--r-- | compiler/utils/Digraph.hs | 308 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs | 5 | ||||
| m--------- | libraries/process | 0 | ||||
| -rw-r--r-- | testsuite/tests/hpc/Makefile | 3 | ||||
| -rw-r--r-- | testsuite/tests/hpc/T2991.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/hpc/T2991LiterateModule.lhs | 4 | ||||
| -rw-r--r-- | testsuite/tests/hpc/all.T | 17 | ||||
| m--------- | utils/hsc2hs | 0 |
11 files changed, 150 insertions, 276 deletions
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 65d633e6b7..3ddb9ec002 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -205,13 +205,6 @@ cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] --- NB. Do *not* inspect the value of the offset in these smart constructors!!! --- because the offset is sometimes involved in a loop in the code generator --- (we don't know the real Hp offset until we've generated code for the entire --- basic block, for example). So we cannot eliminate zero offsets at this --- stage; they're eliminated later instead (either during printing or --- a later optimisation step on Cmm). --- cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr cmmOffset _ e 0 = e cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2d7ee465f6..24df3a2dc4 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -809,7 +809,8 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags let flags = [ -- The -h option passes the file name for unlit to -- put in a #line directive SysTools.Option "-h" - , SysTools.Option $ escape $ normalise input_fn + -- See Note [Don't normalise input filenames]. + , SysTools.Option $ escape input_fn , SysTools.FileOption "" input_fn , SysTools.FileOption "" output_fn ] @@ -821,7 +822,7 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags -- escape the characters \, ", and ', but don't try to escape -- Unicode or anything else (so we don't use Util.charToC -- here). If we get this wrong, then in - -- Coverage.addTicksToBinds where we check that the filename in + -- Coverage.isGoodTickSrcSpan where we check that the filename in -- a SrcLoc is the same as the source filenaame, the two will -- look bogusly different. See test: -- libraries/hpc/tests/function/subdir/tough2.hs @@ -2327,3 +2328,66 @@ getGhcVersionPathName dflags = do -- 3c: 2f 00 00 00 sethi %hi(0), %l7 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimally be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 56eba69333..aba4a1b06b 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -469,13 +469,14 @@ askCc dflags args = do args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 runSomethingWith dflags "gcc" p args2 $ \real_args -> - readCreateProcess (proc p real_args){ env = mb_env } + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } --- Version of System.Process.readProcessWithExitCode that takes an environment -readCreateProcess +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' :: CreateProcess -> IO (ExitCode, String) -- ^ stdout -readCreateProcess proc = do +readCreateProcessWithExitCode' proc = do (_, Just outh, _, pid) <- createProcess proc{ std_out = CreatePipe } diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs index 8f5df0ce05..3f6ee29443 100644 --- a/compiler/utils/Digraph.hs +++ b/compiler/utils/Digraph.hs @@ -1,6 +1,8 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, ScopedTypeVariables #-} +-- For Functor SCC. ToDo: Remove me when 7.10 is released +{-# OPTIONS_GHC -fno-warn-orphans #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, @@ -17,13 +19,6 @@ module Digraph( -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, - - -- No friendly interface yet, not used but exported to avoid warnings - tabulate, preArr, - components, undirected, - back, cross, forward, - path, - bcc, do_label, bicomps, collect ) where #include "HsVersions.h" @@ -35,6 +30,11 @@ module Digraph( -- by David King and John Launchbury -- -- Also included is some additional code for printing tree structures ... +-- +-- If you ever find yourself in need of algorithms for classifying edges, +-- or finding connected/biconnected components, consult the history; Sigbjorn +-- Finne contributed some implementations in 1997, although we've since +-- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ @@ -56,6 +56,10 @@ import Data.Array.ST import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Graph as G +import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Tree + {- ************************************************************************ * * @@ -209,32 +213,6 @@ findCycle graph {- ************************************************************************ * * -* SCC -* * -************************************************************************ --} - -data SCC vertex = AcyclicSCC vertex - | CyclicSCC [vertex] - -instance Functor SCC where - fmap f (AcyclicSCC v) = AcyclicSCC (f v) - fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs) - -flattenSCCs :: [SCC a] -> [a] -flattenSCCs = concatMap flattenSCC - -flattenSCC :: SCC a -> [a] -flattenSCC (AcyclicSCC v) = [v] -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))) - -{- -************************************************************************ -* * * Strongly Connected Component wrappers for Graph * * ************************************************************************ @@ -290,7 +268,7 @@ topologicalSortG graph = map (gr_vertex_to_node graph) result dfsTopSortG :: Graph node -> [[node]] dfsTopSortG graph = - map (map (gr_vertex_to_node graph) . flattenTree) $ dfs g (topSort g) + map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g) where g = gr_int_graph graph @@ -316,7 +294,9 @@ edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph g where v2n = gr_vertex_to_node graph transposeG :: Graph node -> Graph node -transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph) +transposeG graph = Graph (G.transposeG (gr_int_graph graph)) + (gr_vertex_to_node graph) + (gr_node_to_vertex graph) outdegreeG :: Graph node -> node -> Maybe Int outdegreeG = degreeG outdegree @@ -324,7 +304,7 @@ outdegreeG = degreeG outdegree indegreeG :: Graph node -> node -> Maybe Int indegreeG = degreeG indegree -degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int +degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int degreeG degree graph node = let table = degree (gr_int_graph graph) in fmap ((!) table) $ gr_node_to_vertex graph node @@ -336,7 +316,8 @@ emptyG :: Graph node -> Bool emptyG g = graphEmpty (gr_int_graph g) componentsG :: Graph node -> [[node]] -componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph) +componentsG graph = map (map (gr_vertex_to_node graph) . flatten) + $ components (gr_int_graph graph) {- ************************************************************************ @@ -355,261 +336,51 @@ instance Outputable node => Outputable (Graph node) where instance Outputable node => Outputable (Edge node) where ppr (Edge from to) = ppr from <+> text "->" <+> ppr to -{- -************************************************************************ -* * -* IntGraphs -* * -************************************************************************ --} - -type Vertex = Int -type Table a = Array Vertex a -type IntGraph = Table [Vertex] -type Bounds = (Vertex, Vertex) -type IntEdge = (Vertex, Vertex) - -vertices :: IntGraph -> [Vertex] -vertices = indices - -edges :: IntGraph -> [IntEdge] -edges g = [ (v, w) | v <- vertices g, w <- g!v ] - -mapT :: (Vertex -> a -> b) -> Table a -> Table b -mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ] - -buildG :: Bounds -> [IntEdge] -> IntGraph -buildG bounds edges = accumArray (flip (:)) [] bounds edges - -transpose :: IntGraph -> IntGraph -transpose g = buildG (bounds g) (reverseE g) - -reverseE :: IntGraph -> [IntEdge] -reverseE g = [ (w, v) | (v, w) <- edges g ] - -outdegree :: IntGraph -> Table Int -outdegree = mapT numEdges - where numEdges _ ws = length ws - -indegree :: IntGraph -> Table Int -indegree = outdegree . transpose - -graphEmpty :: IntGraph -> Bool +graphEmpty :: G.Graph -> Bool graphEmpty g = lo > hi where (lo, hi) = bounds g {- ************************************************************************ * * -* Trees and forests -* * -************************************************************************ --} - -data Tree a = Node a (Forest a) -type Forest a = [Tree a] - -mapTree :: (a -> b) -> (Tree a -> Tree b) -mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) - -flattenTree :: Tree a -> [a] -flattenTree (Node x ts) = x : concatMap flattenTree ts - -instance Show a => Show (Tree a) where - showsPrec _ t s = showTree t ++ s - -showTree :: Show a => Tree a -> String -showTree = drawTree . mapTree show - -drawTree :: Tree String -> String -drawTree = unlines . draw - -draw :: Tree String -> [String] -draw (Node x ts) = grp this (space (length this)) (stLoop ts) - where this = s1 ++ x ++ " " - - space n = replicate n ' ' - - stLoop [] = [""] - stLoop [t] = grp s2 " " (draw t) - stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts - - rsLoop [] = [] - rsLoop [t] = grp s5 " " (draw t) - rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts - - grp fst rst = zipWith (++) (fst:repeat rst) - - [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"] - -{- -************************************************************************ -* * -* Depth first search +* IntGraphs * * ************************************************************************ -} -type Set s = STArray s Vertex Bool - -mkEmpty :: Bounds -> ST s (Set s) -mkEmpty bnds = newArray bnds False - -contains :: Set s -> Vertex -> ST s Bool -contains m v = readArray m v - -include :: Set s -> Vertex -> ST s () -include m v = writeArray m v True - -dff :: IntGraph -> Forest Vertex -dff g = dfs g (vertices g) - -dfs :: IntGraph -> [Vertex] -> Forest Vertex -dfs g vs = prune (bounds g) (map (generate g) vs) - -generate :: IntGraph -> Vertex -> Tree Vertex -generate g v = Node v (map (generate g) (g!v)) +type IntGraph = G.Graph -prune :: Bounds -> Forest Vertex -> Forest Vertex -prune bnds ts = runST (mkEmpty bnds >>= \m -> - chop m ts) - -chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) -chop _ [] = return [] -chop m (Node v ts : us) - = contains m v >>= \visited -> - if visited then - chop m us - else - include m v >>= \_ -> - chop m ts >>= \as -> - chop m us >>= \bs -> - return (Node v as : bs) +-- Functor instance was added in 7.8, in containers 0.5.3.2 release +-- ToDo: Drop me when 7.10 is released. +#if __GLASGOW_HASKELL__ < 708 +instance Functor SCC where + fmap f (AcyclicSCC v) = AcyclicSCC (f v) + fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs) +#endif {- -************************************************************************ -* * -* Algorithms -* * -************************************************************************ - ------------------------------------------------------------ --- Algorithm 1: depth first search numbering +-- Depth first search numbering ------------------------------------------------------------ -} -preorder :: Tree a -> [a] -preorder (Node a ts) = a : preorderF ts - +-- Data.Tree has flatten for Tree, but nothing for Forest preorderF :: Forest a -> [a] -preorderF ts = concat (map preorder ts) - -tabulate :: Bounds -> [Vertex] -> Table Int -tabulate bnds vs = array bnds (zip vs [1..]) - -preArr :: Bounds -> Forest Vertex -> Table Int -preArr bnds = tabulate bnds . preorderF - -{- ------------------------------------------------------------- --- Algorithm 2: topological sorting ------------------------------------------------------------- --} - -postorder :: Tree a -> [a] -> [a] -postorder (Node a ts) = postorderF ts . (a :) - -postorderF :: Forest a -> [a] -> [a] -postorderF ts = foldr (.) id $ map postorder ts - -postOrd :: IntGraph -> [Vertex] -postOrd g = postorderF (dff g) [] - -topSort :: IntGraph -> [Vertex] -topSort = reverse . postOrd - -{- ------------------------------------------------------------- --- Algorithm 3: connected components ------------------------------------------------------------- --} - -components :: IntGraph -> Forest Vertex -components = dff . undirected - -undirected :: IntGraph -> IntGraph -undirected g = buildG (bounds g) (edges g ++ reverseE g) - -{- ------------------------------------------------------------- --- Algorithm 4: strongly connected components ------------------------------------------------------------- --} - -scc :: IntGraph -> Forest Vertex -scc g = dfs g (reverse (postOrd (transpose g))) +preorderF ts = concat (map flatten ts) {- ------------------------------------------------------------ --- Algorithm 5: Classifying edges ------------------------------------------------------------- --} - -back :: IntGraph -> Table Int -> IntGraph -back g post = mapT select g - where select v ws = [ w | w <- ws, post!v < post!w ] - -cross :: IntGraph -> Table Int -> Table Int -> IntGraph -cross g pre post = mapT select g - where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ] - -forward :: IntGraph -> IntGraph -> Table Int -> IntGraph -forward g tree pre = mapT select g - where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v - -{- ------------------------------------------------------------- --- Algorithm 6: Finding reachable vertices +-- Finding reachable vertices ------------------------------------------------------------ -} +-- This generalizes reachable which was found in Data.Graph reachable :: IntGraph -> [Vertex] -> [Vertex] reachable g vs = preorderF (dfs g vs) -path :: IntGraph -> Vertex -> Vertex -> Bool -path g v w = w `elem` (reachable g [v]) - {- ------------------------------------------------------------ --- Algorithm 7: Biconnected components ------------------------------------------------------------- --} - -bcc :: IntGraph -> Forest [Vertex] -bcc g = (concat . map bicomps . map (do_label g dnum)) forest - where forest = dff g - dnum = preArr (bounds g) forest - -do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) -do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us - where us = map (do_label g dnum) ts - lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] - ++ [lu | Node (_,_,lu) _ <- us]) - -bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex] -bicomps (Node (v,_,_) ts) - = [ Node (v:vs) us | (_,Node vs us) <- map collect ts] - -collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex]) -collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) - where collected = map collect ts - vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv] - cs = concat [ if lw<dv then us else [Node (v:ws) us] - | (lw, Node ws us) <- collected ] - -{- ------------------------------------------------------------- --- Algorithm 8: Total ordering on groups of vertices +-- Total ordering on groups of vertices ------------------------------------------------------------ The plan here is to extract a list of groups of elements of the graph @@ -625,6 +396,17 @@ and their associated edges from the graph. This probably isn't very efficient and certainly isn't very clever. -} +type Set s = STArray s Vertex Bool + +mkEmpty :: Bounds -> ST s (Set s) +mkEmpty bnds = newArray bnds False + +contains :: Set s -> Vertex -> ST s Bool +contains m v = readArray m v + +include :: Set s -> Vertex -> ST s () +include m v = writeArray m v True + vertexGroups :: IntGraph -> [[Vertex]] vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices) where next_vertices = noOutEdges g diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 6c7ae08379..c557224fc1 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -105,6 +105,7 @@ import Data.Word import System.IO ( Handle ) import System.FilePath import Text.Printf +import Data.Graph (SCC(..)) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -769,6 +770,10 @@ instance (Outputable elt) => Outputable (IM.IntMap elt) where instance Outputable Fingerprint where ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) +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))) + {- ************************************************************************ * * diff --git a/libraries/process b/libraries/process -Subproject 160bdd16722d85c2644bd2353121d8eb5e1597e +Subproject ae10a33cd16d9ac9238a193e5355c5c2e05ef0a diff --git a/testsuite/tests/hpc/Makefile b/testsuite/tests/hpc/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/hpc/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/hpc/T2991.hs b/testsuite/tests/hpc/T2991.hs new file mode 100644 index 0000000000..451e1ebc21 --- /dev/null +++ b/testsuite/tests/hpc/T2991.hs @@ -0,0 +1,5 @@ +module Main where +-- Test that there are actually entries in the .mix file for an imported +-- literate module generated with --make. +import T2991LiterateModule +main = return () diff --git a/testsuite/tests/hpc/T2991LiterateModule.lhs b/testsuite/tests/hpc/T2991LiterateModule.lhs new file mode 100644 index 0000000000..55fc31c70f --- /dev/null +++ b/testsuite/tests/hpc/T2991LiterateModule.lhs @@ -0,0 +1,4 @@ +\begin{code} +module T2991LiterateModule where +cover_me = 1 +\end{code} diff --git a/testsuite/tests/hpc/all.T b/testsuite/tests/hpc/all.T new file mode 100644 index 0000000000..d279018025 --- /dev/null +++ b/testsuite/tests/hpc/all.T @@ -0,0 +1,17 @@ +# Do not explicitly specify '-fhpc' in extra_hc_opts, unless also setting +# '-hpcdir' to a different value for each test. Only the `hpc` way does this +# automatically. This way the tests in this directory can be run concurrently +# (Main.mix might overlap otherwise). + +setTestOpts([only_compiler_types(['ghc']), + only_ways(['hpc']), + ]) + +def T2991(cmd): + # The .mix file for the literate module should have non-zero entries. + # The `grep` should exit with exit code 0. + return(cmd + " && grep -q cover_me .hpc.T2991/T2991LiterateModule.mix") +test('T2991', [cmd_wrapper(T2991), extra_clean(['T2991LiterateModule.hi', + 'T2991LiterateModule.o'])], + # Run with 'ghc --main'. Do not list other modules explicitly. + multimod_compile_and_run, ['T2991', '']) diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject 546438f93f8eb11da6b9279374552cfd8649925 +Subproject e32b4faf97833f92708a8f3f8bbb015f5d1dbcc |