1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{- Allows linking haskell programs too big for all the files to fit in a
- command line.
-
- See https://ghc.haskell.org/trac/ghc/ticket/8596
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Main where
import Data.List.Utils
import Text.Parsec
import Text.Parsec.String
import Control.Applicative ((<$>))
import Control.Monad
import System.Directory hiding (isSymbolicLink)
import Data.Maybe
import Data.List
import Utility.Monad
import Utility.Process hiding (env)
import qualified Utility.Process
import Utility.Env
data CmdParams = CmdParams
{ cmd :: String
, opts :: String
, env :: Maybe [(String, String)]
} deriving (Show)
{- Find where ghc calls gcc to link the executable. -}
parseGhcLink :: Parser CmdParams
parseGhcLink = do
void $ many prelinkline
void linkheaderline
void $ char '"'
gcccmd <- many1 (noneOf "\"")
void $ string "\" "
gccparams <- restOfLine
return $ CmdParams gcccmd (manglepaths gccparams) Nothing
where
linkheaderline = do
void $ string "*** Linker"
restOfLine
prelinkline = do
void $ notFollowedBy linkheaderline
restOfLine
manglepaths = replace "\\" "/"
{- Find where gcc calls collect2. -}
parseGccLink :: Parser CmdParams
parseGccLink = do
cenv <- collectenv
void $ try $ char ' '
path <- manyTill anyChar (try $ string collectcmd)
void $ char ' '
collect2params <- restOfLine
return $ CmdParams (path ++ collectcmd) (escapeDosPaths collect2params) cenv
where
collectcmd = "collect2.exe"
collectgccenv = "COLLECT_GCC"
collectltoenv = "COLLECT_LTO_WRAPPER"
pathenv = "COMPILER_PATH"
libpathenv = "LIBRARY_PATH"
optenv = "COLLECT_GCC_OPTIONS"
collectenv = do
void $ many1 $ do
notFollowedBy $ string collectgccenv
restOfLine
void $ string collectgccenv
void $ char '='
g <- restOfLine
void $ string collectltoenv
void $ char '='
lt <- restOfLine
void $ many1 $ do
notFollowedBy $ string pathenv
restOfLine
void $ string pathenv
void $ char '='
p <- restOfLine
void $ string libpathenv
void $ char '='
lp <- restOfLine
void $ string optenv
void $ char '='
o <- restOfLine
return $ Just [(collectgccenv, g), (collectltoenv, lt), (pathenv, p), (libpathenv, lp), (optenv, o)]
{- Find where collect2 calls ld. -}
parseCollect2 :: Parser CmdParams
parseCollect2 = do
void $ manyTill restOfLine (try versionline)
path <- manyTill anyChar (try $ string ldcmd)
void $ char ' '
params <- restOfLine
return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing
where
ldcmd = "ld.exe"
versionline = do
void $ string "collect2 version"
restOfLine
{- Input contains something like
- c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
- and the *right* spaces must be escaped with \
-
- Argh.
-}
escapeDosPaths :: String -> String
escapeDosPaths = replace "Program Files" "Program\\ Files"
. replace "program files" "program\\ files"
. replace "Haskell Platform" "Haskell\\ Platform"
. replace "haskell platform" "haskell\\ platform"
. replace "Application Data" "Application\\ Data"
. replace "Documents and Settings" "Documents\\ and\\ Settings"
. replace "Files (x86)" "Files\\ (x86)"
. replace "files (x86)" "files\\ (x86)"
restOfLine :: Parser String
restOfLine = newline `after` many (noneOf "\n")
getOutput :: String -> [String] -> Maybe [(String, String)] -> IO (String, Bool)
getOutput c ps environ = do
putStrLn $ unwords [c, show ps]
systemenviron <- getEnvironment
let environ' = fromMaybe [] environ ++ systemenviron
out@(_, ok) <- processTranscript' (\p -> p { Utility.Process.env = Just environ' }) c ps Nothing
putStrLn $ unwords [c, "finished", show ok]
return out
atFile :: FilePath -> String
atFile f = '@':f
runAtFile :: Parser CmdParams -> String -> FilePath -> [String] -> IO (String, Bool)
runAtFile p s f extraparams = do
when (null $ opts c) $
error $ "failed to find any options for " ++ f ++ " in >>>" ++ s ++ "<<<"
writeFile f (opts c)
out <- getOutput (cmd c) (atFile f:extraparams) (env c)
removeFile f
return out
where
c = case parse p "" s of
Left e -> error $
(show e) ++
"\n<<<\n" ++ s ++ "\n>>>"
Right r -> r
main :: IO ()
main = do
ghcout <- fst <$> getOutput "cabal"
["build", "--ghc-options=-v -keep-tmp-files"] Nothing
gccout <- fst <$> runAtFile parseGhcLink ghcout "gcc.opt" ["-v"]
collect2out <- fst <$> runAtFile parseGccLink gccout "collect2.opt" ["-v"]
(out, ok) <- runAtFile parseCollect2 collect2out "ld.opt" []
unless ok $
error $ "ld failed:\n" ++ out
|
