Skip to content

Commit 4e12cff

Browse files
author
Alexis Williams
committed
Fix DWARF heuristics (closes commercialhaskell#2851, commercialhaskell#2829)
1 parent 0bf8c05 commit 4e12cff

3 files changed

Lines changed: 28 additions & 27 deletions

File tree

‎src/Stack/Build.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ build :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
9494
build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
9595
bopts <- view buildOptsL
9696
let profiling = boptsLibProfile bopts || boptsExeProfile bopts
97-
let symbols = boptsLibStrip bopts || boptsExeStrip bopts
97+
let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts)
9898
menv <- getMinimalEnvOverride
9999

100100
(targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli

‎src/Stack/Build/Installed.hs‎

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -136,9 +136,8 @@ loadDatabase :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii)
136136
-> m ([LoadHelper], [DumpPackage () () ()])
137137
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
138138
wc <- view $ actualCompilerVersionL.to whichCompiler
139-
ver <- view wantedCompilerVersionL -- FIXME do we want instead actualCompilerVersionL?
140139
(lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb))
141-
$ conduitDumpPackage =$ sink ver
140+
$ conduitDumpPackage =$ sink
142141
let ghcjsHack = wc == Ghcjs && isNothing mdb
143142
lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1'
144143
let lhs = pruneDeps
@@ -161,20 +160,20 @@ loadDatabase menv opts mcache sourceMap mdb lhs0 = do
161160
-- Just an optimization to avoid calculating the haddock
162161
-- values when they aren't necessary
163162
_ -> CL.map (\dp -> dp { dpHaddock = False })
164-
conduitSymbolsCache ver =
163+
conduitSymbolsCache =
165164
case mcache of
166-
Just cache | getInstalledSymbols opts -> addSymbols cache ver
165+
Just cache | getInstalledSymbols opts -> addSymbols cache
167166
-- Just an optimization to avoid calculating the debugging
168167
-- symbol values when they aren't necessary
169168
_ -> CL.map (\dp -> dp { dpSymbols = False })
170169
mloc = fmap fst mdb
171-
sinkDP ver = conduitProfilingCache
172-
=$ conduitHaddockCache
173-
=$ conduitSymbolsCache ver
174-
=$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc)
175-
=$ CL.consume
176-
sink ver = getZipSink $ (,)
177-
<$> ZipSink (sinkDP ver)
170+
sinkDP = conduitProfilingCache
171+
=$ conduitHaddockCache
172+
=$ conduitSymbolsCache
173+
=$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc)
174+
=$ CL.consume
175+
sink = getZipSink $ (,)
176+
<$> ZipSink sinkDP
178177
<*> ZipSink CL.consume
179178

180179
processLoadResult :: MonadLogger m

‎src/Stack/PackageDump.hs‎

Lines changed: 17 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ import qualified Data.Conduit.List as CL
3939
import qualified Data.Conduit.Text as CT
4040
import Data.Either (partitionEithers)
4141
import Data.IORef
42+
import Data.List (isPrefixOf)
4243
import Data.Map (Map)
4344
import qualified Data.Map as Map
4445
import Data.Maybe (catMaybes, listToMaybe)
@@ -254,12 +255,10 @@ addHaddock (InstalledCache ref) =
254255
-- | Add debugging symbol information to the stream of @DumpPackage@s
255256
addSymbols :: MonadIO m
256257
=> InstalledCache
257-
-> CompilerVersion
258258
-> Conduit (DumpPackage a b c) m (DumpPackage a b Bool)
259-
addSymbols (InstalledCache ref) ver =
259+
addSymbols (InstalledCache ref) =
260260
CL.mapM go
261261
where
262-
ver' = versionString . getGhcVersion $ ver
263262
go dp = do
264263
InstalledCacheInner m <- liftIO $ readIORef ref
265264
let gid = dpGhcPkgId dp
@@ -268,22 +267,25 @@ addSymbols (InstalledCache ref) ver =
268267
Nothing | null (dpLibraries dp) -> return True
269268
Nothing -> do
270269
let lib = T.unpack . head $ dpLibraries dp
271-
liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols ver' dir lib) $ dpLibDirs dp
270+
liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols dir lib) $ dpLibDirs dp
272271
return dp { dpSymbols = s }
273272

274-
hasDebuggingSymbols :: String -- ^ target compiler
275-
-> FilePath -- ^ library directory
273+
hasDebuggingSymbols :: FilePath -- ^ library directory
276274
-> String -- ^ name of library
277275
-> IO Bool
278-
hasDebuggingSymbols ver dir lib = case OS.buildOS of
279-
OS.OSX -> liftM (and . fmap ((/= '0') . head) . Prelude.take 30 . lines) $
280-
readProcess "dwarfdump" [concat [dir, "/lib", lib, "-ghc", ver, ".a"]] ""
281-
OS.Linux -> liftM ((== "Contents") . head . words . (!! 2) . lines) $
282-
readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", concat [dir, "/lib", lib, "-ghc", ver, ".a"]] ""
283-
OS.FreeBSD -> liftM ((== "Contents") . head . words . (!! 2) . lines) $
284-
readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", concat [dir, "/lib", lib, "-ghc", ver, ".a"]] ""
285-
OS.Windows -> return False -- No support, so it can't be there.
286-
_ -> return False
276+
hasDebuggingSymbols dir lib = do
277+
let path = concat [dir, "/lib", lib, ".a"]
278+
exists <- doesFileExist path
279+
if not exists then return False
280+
else case OS.buildOS of
281+
OS.OSX -> liftM (any (isPrefixOf "0x") . lines) $
282+
readProcess "dwarfdump" [path] ""
283+
OS.Linux -> liftM (any (isPrefixOf "Contents") . lines) $
284+
readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] ""
285+
OS.FreeBSD -> liftM (any (isPrefixOf "Contents") . lines) $
286+
readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] ""
287+
OS.Windows -> return False -- No support, so it can't be there.
288+
_ -> return False
287289

288290

289291
-- | Dump information for a single package

0 commit comments

Comments
 (0)