summaryrefslogtreecommitdiff
path: root/Build/EvilLinker.hs
blob: 94e399dfe1d69c27e039540b16797f2c8d2602ba (plain)
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 Data.Maybe
import Data.List

import Utility.Monad
import Utility.Process hiding (env)
import qualified Utility.Process
import Utility.Env
import Utility.Directory

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