.exe" to leave $topdir.
from topdir we can find package.conf, ghc-asm, etc.
SysTools.initSysProgs figures out exactly where all the auxiliary programs
are, and initialises mutable variables to make it easy to call them.
To to this, it makes use of definitions in Config.hs, which is a Haskell
file containing variables whose value is figured out by the build system.
Config.hs contains two sorts of things
cGCC, The *names* of the programs
cCPP e.g. cGCC = gcc
cUNLIT cCPP = gcc -E
etc They do *not* include paths
cUNLIT_DIR The *path* to the directory containing unlit, split etc
cSPLIT_DIR *relative* to the root of the build tree,
for use when running *in-place* in a build tree (only)
---------------------------------------------
NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
Another hair-brained scheme for simplifying the current tool location
nightmare in GHC: Simon originally suggested using another
configuration file along the lines of GCC's specs file - which is fine
except that it means adding code to read yet another configuration
file. What I didn't notice is that the current package.conf is
general enough to do this:
Package
{name = "tools", import_dirs = [], source_dirs = [],
library_dirs = [], hs_libraries = [], extra_libraries = [],
include_dirs = [], c_includes = [], package_deps = [],
extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
extra_cc_opts = [], extra_ld_opts = []}
Which would have the advantage that we get to collect together in one
place the path-specific package stuff with the path-specific tool
stuff.
End of NOTES
---------------------------------------------
%************************************************************************
%* *
\subsection{Initialisation}
%* *
%************************************************************************
\begin{code}
initSysTools :: Maybe String
-> IO Settings
initSysTools mbMinusB
= do { top_dir <- findTopDir mbMinusB
; let settingsFile = top_dir </> "settings"
installed :: FilePath -> FilePath
installed file = top_dir </> file
; settingsStr <- readFile settingsFile
; mySettings <- case maybeReadFuzzy settingsStr of
Just s ->
return s
Nothing ->
pgmError ("Can't parse " ++ show settingsFile)
; let getSetting key = case lookup key mySettings of
Just xs ->
return $ case stripPrefix "$topdir" xs of
Just [] ->
top_dir
Just xs'@(c:_)
| isPathSeparator c ->
top_dir ++ xs'
_ ->
xs
Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
readSetting key = case lookup key mySettings of
Just xs ->
case maybeRead xs of
Just v -> return v
Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
; targetArch <- readSetting "target arch"
; targetOS <- readSetting "target os"
; targetWordSize <- readSetting "target word size"
; targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
; targetHasIdentDirective <- readSetting "target has .ident directive"
; targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
; gcc_prog <- getSetting "C compiler command"
; gcc_args_str <- getSetting "C compiler flags"
; let gcc_args = map Option (words gcc_args_str)
; perl_path <- getSetting "perl command"
; let pkgconfig_path = installed "package.conf.d"
ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
unlit_path = installed cGHC_UNLIT_PGM
split_script = installed cGHC_SPLIT_PGM
; windres_path <- getSetting "windres command"
; tmpdir <- getTemporaryDirectory
; touch_path <- getSetting "touch command"
; let
(split_prog, split_args)
| isWindowsHost = (perl_path, [Option split_script])
| otherwise = (split_script, [])
; mkdll_prog <- getSetting "dllwrap command"
; let mkdll_args = []
; let cpp_prog = gcc_prog
cpp_args = Option "-E"
: map Option (words cRAWCPP_FLAGS)
++ gcc_args
; let as_prog = gcc_prog
as_args = gcc_args
ld_prog = gcc_prog
ld_args = gcc_args
; lc_prog <- getSetting "LLVM llc command"
; lo_prog <- getSetting "LLVM opt command"
; return $ Settings {
sTargetPlatform = Platform {
platformArch = targetArch,
platformOS = targetOS,
platformWordSize = targetWordSize,
platformHasGnuNonexecStack = targetHasGnuNonexecStack,
platformHasIdentDirective = targetHasIdentDirective,
platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
},
sTmpDir = normalise tmpdir,
sGhcUsagePath = ghc_usage_msg_path,
sGhciUsagePath = ghci_usage_msg_path,
sTopDir = top_dir,
sRawSettings = mySettings,
sExtraGccViaCFlags = words myExtraGccViaCFlags,
sSystemPackageConfig = pkgconfig_path,
sPgm_L = unlit_path,
sPgm_P = (cpp_prog, cpp_args),
sPgm_F = "",
sPgm_c = (gcc_prog, gcc_args),
sPgm_s = (split_prog,split_args),
sPgm_a = (as_prog, as_args),
sPgm_l = (ld_prog, ld_args),
sPgm_dll = (mkdll_prog,mkdll_args),
sPgm_T = touch_path,
sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
sPgm_windres = windres_path,
sPgm_lo = (lo_prog,[]),
sPgm_lc = (lc_prog,[]),
sOpt_L = [],
sOpt_P = (if opt_PIC
then
["-D__PIC__", "-U __PIC__"]
else []),
sOpt_F = [],
sOpt_c = [],
sOpt_a = [],
sOpt_l = [],
sOpt_windres = [],
sOpt_lo = [],
sOpt_lc = []
}
}
\end{code}
\begin{code}
findTopDir :: Maybe String
-> IO String
findTopDir (Just minusb) = return (normalise minusb)
findTopDir Nothing
= do
maybe_exec_dir <- getBaseDir
case maybe_exec_dir of
Nothing -> ghcError (InstallationError "missing -B<dir> option")
Just dir -> return dir
\end{code}
%************************************************************************
%* *
\subsection{Running an external program}
%* *
%************************************************************************
\begin{code}
runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = do
let p = pgm_L dflags
runSomething dflags "Literate pre-processor" p args
runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args = do
let (p,args0) = pgm_P dflags
args1 = args0 ++ args
args2 = if dopt Opt_WarnIsError dflags
then Option "-Werror" : args1
else args1
mb_env <- getGccEnv args2
runSomethingFiltered dflags id "C pre-processor" p args2 mb_env
runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args = do
let p = pgm_F dflags
runSomething dflags "Haskell pre-processor" p args
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
let (p,args0) = pgm_c dflags
args1 = args0 ++ args
mb_env <- getGccEnv args1
runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
where
cc_filter = unlines . doFilter . lines
doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
chunkWarnings :: [String]
-> [String]
-> [([String], [String])]
chunkWarnings loc_stack [] = [(loc_stack, [])]
chunkWarnings loc_stack xs
= case break loc_stack_start xs of
(warnings, lss:xs') ->
case span loc_start_continuation xs' of
(lsc, xs'') ->
(loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
_ -> [(loc_stack, xs)]
filterWarnings :: [([String], [String])] -> [([String], [String])]
filterWarnings [] = []
filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
[] -> filterWarnings zs
ys' -> (xs, ys') : filterWarnings zs
unChunkWarnings :: [([String], [String])] -> [String]
unChunkWarnings [] = []
unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
loc_stack_start s = "In file included from " `isPrefixOf` s
loc_start_continuation s = " from " `isPrefixOf` s
wantedWarning w
| "warning: call-clobbered register used" `isContainedIn` w = False
| otherwise = True
isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
askCc :: DynFlags -> [Option] -> IO String
askCc dflags args = do
let (p,args0) = pgm_c dflags
args1 = args0 ++ args
mb_env <- getGccEnv args1
runSomethingWith dflags "gcc" p args1 $ \real_args ->
readCreateProcess (proc p real_args){ env = mb_env }
readCreateProcess
:: CreateProcess
-> IO (ExitCode, String)
readCreateProcess proc = do
(_, Just outh, _, pid) <-
createProcess proc{ std_out = CreatePipe }
output <- hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
takeMVar outMVar
hClose outh
ex <- waitForProcess pid
return (ex, output)
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv opts =
if null b_dirs
then return Nothing
else do env <- getEnvironment
return (Just (map mangle_path env))
where
(b_dirs, _) = partitionWith get_b_opt opts
get_b_opt (Option ('-':'B':dir)) = Left dir
get_b_opt other = Right other
mangle_path (path,paths) | map toUpper path == "PATH"
= (path, '\"' : head b_dirs ++ "\";" ++ paths)
mangle_path other = other
runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do
let (p,args0) = pgm_s dflags
runSomething dflags "Splitter" p (args0++args)
runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = do
let (p,args0) = pgm_a dflags
args1 = args0 ++ args
mb_env <- getGccEnv args1
runSomethingFiltered dflags id "Assembler" p args1 mb_env
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
let (p,args0) = pgm_lo dflags
runSomething dflags "LLVM Optimiser" p (args0++args)
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = do
let (p,args0) = pgm_lc dflags
runSomething dflags "LLVM Compiler" p (args0++args)
runClang :: DynFlags -> [Option] -> IO ()
runClang dflags args = do
let clang = "clang"
Exception.catch (do
runSomething dflags "Clang (Assembler)" clang args
)
(\(err :: SomeException) -> do
errorMsg dflags $ text $ "Error running clang! you need clang installed"
++ " to use the LLVM backend"
throw err
)
figureLlvmVersion :: DynFlags -> IO (Maybe Int)
figureLlvmVersion dflags = do
let (pgm,opts) = pgm_lc dflags
args = filter notNull (map showOpt opts)
args' = args ++ ["-version"]
ver <- catchIO (do
(pin, pout, perr, _) <- runInteractiveProcess pgm args'
Nothing Nothing
hSetBinaryMode pout False
_ <- hGetLine pout
vline <- hGetLine pout
v <- case filter isDigit vline of
[] -> fail "no digits!"
[x] -> fail $ "only 1 digit! (" ++ show x ++ ")"
(x:y:_) -> return ((read [x,y]) :: Int)
hClose pin
hClose pout
hClose perr
return $ Just v
)
(\err -> do
debugTraceMsg dflags 2
(text "Error (figuring out LLVM version):" <+>
text (show err))
errorMsg dflags $ vcat
[ text "Warning:", nest 9 $
text "Couldn't figure out LLVM version!" $$
text "Make sure you have installed LLVM"]
return Nothing)
return ver
runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = do
let (p,args0) = pgm_l dflags
args1 = args0 ++ args
mb_env <- getGccEnv args1
runSomethingFiltered dflags id "Linker" p args1 mb_env
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
let (p,args0) = pgm_dll dflags
args1 = args0 ++ args
mb_env <- getGccEnv (args0++args)
runSomethingFiltered dflags id "Make DLL" p args1 mb_env
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = do
let (gcc, gcc_args) = pgm_c dflags
windres = pgm_windres dflags
quote x = "\"" ++ x ++ "\""
args' =
Option ("--preprocessor=" ++
unwords (map quote (gcc :
map showOpt gcc_args ++
["-E", "-xc", "-DRC_INVOKED"])))
: Option "--use-temp-file"
: args
mb_env <- getGccEnv gcc_args
runSomethingFiltered dflags id "Windres" windres args' mb_env
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
-> IO ()
copyWithHeader dflags purpose maybe_header from to = do
showPass dflags purpose
hout <- openBinaryFile to WriteMode
hin <- openBinaryFile from ReadMode
ls <- hGetContents hin
maybe (return ()) (header hout) maybe_header
hPutStr hout ls
hClose hout
hClose hin
where
#if __GLASGOW_HASKELL__ >= 702
header h str = do
hSetEncoding h utf8
hPutStr h str
hSetBinaryMode h True
#else
header h str = hPutStr h str
#endif
readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
readElfSection _dflags section exe = do
let
prog = "readelf"
args = [Option "-p", Option section, FileOption "" exe]
r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
case r of
(ExitSuccess, out, _err) -> return (doFilter (lines out))
_ -> return Nothing
where
doFilter [] = Nothing
doFilter (s:r) = case readP_to_S parse s of
[(p,"")] -> Just p
_r -> doFilter r
where parse = do
skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces;
munch (const True)
\end{code}
%************************************************************************
%* *
\subsection{Managing temporary files
%* *
%************************************************************************
\begin{code}
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
= unless (dopt Opt_KeepTmpFiles dflags)
$ do let ref = dirsToClean dflags
ds <- readIORef ref
removeTmpDirs dflags (Map.elems ds)
writeIORef ref Map.empty
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= unless (dopt Opt_KeepTmpFiles dflags)
$ do let ref = filesToClean dflags
fs <- readIORef ref
removeTmpFiles dflags fs
writeIORef ref []
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
= unless (dopt Opt_KeepTmpFiles dflags)
$ do let ref = filesToClean dflags
files <- readIORef ref
let (to_keep, to_delete) = partition (`elem` dont_delete) files
writeIORef ref to_keep
removeTmpFiles dflags to_delete
newTempName :: DynFlags -> Suffix -> IO FilePath
newTempName dflags extn
= do d <- getTempDir dflags
x <- getProcessID
findTempName (d </> "ghc" ++ show x ++ "_") 0
where
findTempName :: FilePath -> Integer -> IO FilePath
findTempName prefix x
= do let filename = (prefix ++ show x) <.> extn
b <- doesFileExist filename
if b then findTempName prefix (x+1)
else do
consIORef (filesToClean dflags) filename
return filename
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags
= do let ref = dirsToClean dflags
tmp_dir = tmpDir dflags
mapping <- readIORef ref
case Map.lookup tmp_dir mapping of
Nothing ->
do x <- getProcessID
let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
let
mkTempDir :: Integer -> IO FilePath
mkTempDir x
= let dirname = prefix ++ show x
in do createDirectory dirname
let mapping' = Map.insert tmp_dir dirname mapping
writeIORef ref mapping'
debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
return dirname
`catchIO` \e ->
if isAlreadyExistsError e
then mkTempDir (x+1)
else ioError e
mkTempDir 0
Just d -> return d
addFilesToClean :: DynFlags -> [FilePath] -> IO ()
addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
= traceCmd dflags "Deleting temp dirs"
("Deleting: " ++ unwords ds)
(mapM_ (removeWith dflags removeDirectory) ds)
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
= warnNon $
traceCmd dflags "Deleting temp files"
("Deleting: " ++ unwords deletees)
(mapM_ (removeWith dflags removeFile) deletees)
where
warnNon act
| null non_deletees = act
| otherwise = do
putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith dflags remover f = remover f `catchIO`
(\e ->
let msg = if isDoesNotExistError e
then ptext (sLit "Warning: deleting non-existent") <+> text f
else ptext (sLit "Warning: exception raised when deleting")
<+> text f <> colon
$$ text (show e)
in debugTraceMsg dflags 2 msg
)
runSomething :: DynFlags
-> String
-> String
-> [Option]
-> IO ()
runSomething dflags phase_name pgm args =
runSomethingFiltered dflags id phase_name pgm args Nothing
runSomethingFiltered
:: DynFlags -> (String->String) -> String -> String -> [Option]
-> Maybe [(String,String)] -> IO ()
runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
runSomethingWith dflags phase_name pgm args $ \real_args -> do
r <- builderMainLoop dflags filter_fn pgm real_args mb_env
return (r,())
runSomethingWith
:: DynFlags -> String -> String -> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith dflags phase_name pgm args io = do
let real_args = filter notNull (map showOpt args)
#if __GLASGOW_HASKELL__ >= 701
cmdLine = showCommandForUser pgm real_args
#else
cmdLine = unwords (pgm:real_args)
#endif
traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc pgm phase_name proc = do
(rc, r) <- proc `catchIO` handler
case rc of
ExitSuccess{} -> return r
ExitFailure n
| n == 127 -> does_not_exist
| otherwise -> ghcError (PhaseFailed phase_name rc)
where
handler err =
if IO.isDoesNotExistError err
then does_not_exist
else IO.ioError err
does_not_exist = ghcError (InstallationError ("could not execute: " ++ pgm))
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
-> [String] -> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop dflags filter_fn pgm real_args mb_env = do
chan <- newChan
(hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
hSetBuffering hStdOut LineBuffering
hSetBuffering hStdErr LineBuffering
_ <- forkIO (readerProc chan hStdOut filter_fn)
_ <- forkIO (readerProc chan hStdErr filter_fn)
rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
hClose hStdIn
hClose hStdOut
hClose hStdErr
return rc
where
loop _ _ 0 0 exitcode = return exitcode
loop chan hProcess t p exitcode = do
mb_code <- if p > 0
then getProcessExitCode hProcess
else return Nothing
case mb_code of
Just code -> loop chan hProcess t (p1) code
Nothing
| t > 0 -> do
msg <- readChan chan
case msg of
BuildMsg msg -> do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
loop chan hProcess t p exitcode
BuildError loc msg -> do
log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
loop chan hProcess t p exitcode
EOF ->
loop chan hProcess (t1) p exitcode
| otherwise -> loop chan hProcess t p exitcode
readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc chan hdl filter_fn =
(do str <- hGetContents hdl
loop (linesPlatform (filter_fn str)) Nothing)
`finally`
writeChan chan EOF
where
loop [] Nothing = return ()
loop [] (Just err) = writeChan chan err
loop (l:ls) in_err =
case in_err of
Just err@(BuildError srcLoc msg)
| leading_whitespace l -> do
loop ls (Just (BuildError srcLoc (msg $$ text l)))
| otherwise -> do
writeChan chan err
checkError l ls
Nothing -> do
checkError l ls
_ -> panic "readerProc/loop"
checkError l ls
= case parseError l of
Nothing -> do
writeChan chan (BuildMsg (text l))
loop ls Nothing
Just (file, lineNum, colNum, msg) -> do
let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
loop ls (Just (BuildError srcLoc (text msg)))
leading_whitespace [] = False
leading_whitespace (x:_) = isSpace x
parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 = case breakColon s0 of
Just (filename, s1) ->
case breakIntColon s1 of
Just (lineNum, s2) ->
case breakIntColon s2 of
Just (columnNum, s3) ->
Just (filename, lineNum, columnNum, s3)
Nothing ->
Just (filename, lineNum, 0, s2)
Nothing -> Nothing
Nothing -> Nothing
breakColon :: String -> Maybe (String, String)
breakColon xs = case break (':' ==) xs of
(ys, _:zs) -> Just (ys, zs)
_ -> Nothing
breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs = case break (':' ==) xs of
(ys, _:zs)
| not (null ys) && all isAscii ys && all isDigit ys ->
Just (read ys, zs)
_ -> Nothing
data BuildMessage
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
| EOF
traceCmd :: DynFlags -> String -> String -> IO a -> IO a
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
; showPass dflags phase_name
; debugTraceMsg dflags 3 (text cmd_line)
; case flushErr dflags of
FlushErr io -> io
; action `catchIO` handle_exn verb
}
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
%************************************************************************
%* *
\subsection{Support code}
%* *
%************************************************************************
\begin{code}
getBaseDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getBaseDir = try_size 2048
where
try_size size = allocaArray (fromIntegral size) $ \buf -> do
ret <- c_GetModuleFileName nullPtr buf size
case ret of
0 -> return Nothing
_ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
| otherwise -> try_size (size * 2)
rootDir s = case splitFileName $ normalise s of
(d, ghc_exe)
| lower ghc_exe `elem` ["ghc.exe",
"ghc-stage1.exe",
"ghc-stage2.exe",
"ghc-stage3.exe"] ->
case splitFileName $ takeDirectory d of
(d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
_ -> fail
_ -> fail
where fail = panic ("can't decompose ghc.exe path: " ++ show s)
lower = map toLower
foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getBaseDir = return Nothing
#endif
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "_getpid" getProcessID :: IO Int
#else
getProcessID :: IO Int
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#endif
linesPlatform :: String -> [String]
#if !defined(mingw32_HOST_OS)
linesPlatform ls = lines ls
#else
linesPlatform "" = []
linesPlatform xs =
case lineBreak xs of
(as,xs1) -> as : linesPlatform xs1
where
lineBreak "" = ("","")
lineBreak ('\r':'\n':xs) = ([],xs)
lineBreak ('\n':xs) = ([],xs)
lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
#endif
\end{code}