Commit c4ac3c9d authored by AndreasVoellmy's avatar AndreasVoellmy
Browse files

Merge branch 'master' of git://git.haskell.org/ghc

parents 74625d68 6188d0ab
......@@ -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
......
......@@ -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.
-}
......@@ -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 }
......
-- (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
{-
************************************************************************
* *
......@@ -206,32 +210,6 @@ findCycle graph
new_work :: [key] -> [payload] -> [WorkItem key payload]
new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
{-
************************************************************************
* *
* 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)))
{-
************************************************************************
* *
......@@ -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
......
......@@ -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)))
{-
************************************************************************
* *
......
Subproject commit 160bdd16722d85c2644bd2353121d8eb5e1597e4
Subproject commit ae10a33cd16d9ac9238a193e5355c5c2e05ef0a2
TOP=../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
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 ()
\begin{code}
module T2991LiterateModule where
cover_me = 1
\end{code}
# 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', ''])
Subproject commit 546438f93f8eb11da6b9279374552cfd86499253
Subproject commit e32b4faf97833f92708a8f3f8bbb015f5d1dbcc7
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment