Ticket #5793: Main.2.hs

File Main.2.hs, 11.6 KB (added by dterei, 5 years ago)

Shake build system

Line 
1{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}
2
3module Main(main) where
4
5-- Standard libraries
6import Control.Concurrent
7import Control.Exception
8import Control.Monad
9import Data.Char
10import Data.List
11import Data.Maybe
12import Data.Time.Clock
13import qualified System.Directory as IO
14import System.Exit
15import System.Info
16import System.IO
17import System.Process
18
19-- CmdArgs - argument parsing
20import System.Console.CmdArgs
21
22-- Shake - build system
23import Development.Shake
24import Development.Shake.FilePath
25
26
27---------------------------------------------------------------------
28-- TEST CONFIGURATION - which tests are available to run
29
30-- | These are directories that contain tests.
31testRoots :: [String]
32testRoots = words "imaginary spectral real parallel spectral/hartel"
33
34
35-- | These are tests that are under testRoots, but should be skipped (all are skipped by the Makefile system)
36disabledTests :: [String]
37disabledTests = words "hartel last-piece secretary triangle ebnf2ps HMMS PolyGP rx cfd dcbm linsolv warshall"
38
39
40-- | These tests are compiled by the Makefile system, but don't work for me (mostly GHC 7.4 breaks)
41newlyDisabledTests :: [String]
42newlyDisabledTests = words "power lift fulsom fluid"
43
44
45-- | Directories containing tests that the system can run.
46allTests :: IO [FilePath]
47allTests = do
48    xs <- forM testRoots $ \x -> do
49        ys <- IO.getDirectoryContents x
50        return [x </> y | y <- ys, '.' `notElem` y, y `notElem` disabledTests, y `notElem` newlyDisabledTests]
51    fmap sort $ flip filterM (concat xs) $ \x -> do
52        b <- IO.doesDirectoryExist x
53        if not b then return False else
54            IO.doesFileExist $ x </> "Makefile"
55
56
57---------------------------------------------------------------------
58-- ARGUMENT PARSING - mostly based on CmdArgs
59
60data Nofib
61    = Clean
62    | Build
63        {clean :: Bool
64        ,tests :: [String]
65        ,way :: [String]
66        ,threads :: Int
67        ,compiler :: String
68        ,tag :: String
69        ,output :: String
70        ,run :: Maybe Speed
71        ,rts :: [String]
72        ,skip_check :: Bool
73        }
74    deriving (Data,Typeable,Show)
75
76data Speed = Fast | Norm | Slow
77    deriving (Data,Typeable,Show)
78
79
80nofibMode :: Mode (CmdArgs Nofib)
81nofibMode = cmdArgsMode $ modes
82    [Clean
83        &= help "Clean the build"
84    ,Build
85        {clean = False &= groupname "Building" &= help "Clean before building"
86        ,tests = [] &= args &= typ "TEST"
87        ,way = [] &= help "Which way to build, defaults to -O1"
88        ,threads = 1 &= name "j" &= typ "NUM" &= help "Number of threads, defaults to 1"
89        ,compiler = "ghc" &= help "Compiler to use, defaults to ghc"
90        ,tag = "" &= help "Tag to name the compiler, defaults to compiler --version"
91        ,output = "" &= help "Where to put created files under _make, defaults to tag/way"
92        ,run = Nothing &= groupname "Running" &= opt "norm" &= help "Run the results"
93        ,rts = [] &= help "Which RTS options to pass when running"
94        ,skip_check = False &= help "Skip checking the results of the tests"
95        } &= auto &= help "Build"
96        &= help "Build and run"
97    ]
98    &= summary "Nofib benchmark suite"
99
100
101-- | Create a clean set of arguments, with any defaults filled in
102nofibArgs :: IO Nofib
103nofibArgs = do
104    args <- cmdArgsRun nofibMode
105    case args of
106        Clean -> return args
107        Build{..} -> do
108            way <- return $ let xs = concatMap words way in if null xs then ["-O1"] else xs
109            tag <- if tag == "" then compilerTag compiler else return tag
110            tests <- resolveTests tests
111            output <- return $ "_make" </> (if null output then tag </> intercalate "_" way else output)
112            return Build{..}
113
114
115-- | Given the tests the user asked for, expand them out, e.g. real is the full real suite.
116resolveTests :: [String] -> IO [String]
117resolveTests [] = allTests
118resolveTests xs = do
119    let f x = "/" ++ map (\i -> if i == '\\' then '/' else i) x ++ "/"
120    xs <- return $ map f xs
121    as <- allTests
122    let res = filter (\a -> any (`isInfixOf` f a) xs) as
123    when (null res) $
124        error $ "The targets failed to match any programs: " ++ unwords xs
125    return res
126
127
128-- | Find the default compiler string, e.g. ghc-7.4.1
129compilerTag :: String -> IO String
130compilerTag compiler = do
131    (_,stdout,_) <- readProcessWithExitCode compiler ["--version"] ""
132    let ver = takeWhile (\x -> isDigit x || x == '.') $ dropWhile (not . isDigit) stdout
133    return $ if null ver then "unknown" else ver
134
135
136---------------------------------------------------------------------
137-- MAIN DRIVER
138
139-- | Main program, just interpret the arguments and dispatch the tasks.
140main = do
141    args <- nofibArgs
142    case args of
143        Clean -> removeDirectoryRecursive "_make"
144        Build{..} -> do
145            when clean $
146                removeDirectoryRecursive output
147
148            shake shakeOptions
149                {shakeThreads=threads
150                ,shakeFiles=output ++ "/"
151                ,shakeVerbosity=Development.Shake.Loud} $
152                    buildRules args
153            putStrLn "Build completed"
154
155            when (isJust run) $
156                mapM_ (runTest args) tests
157
158
159-- | Rules to build the given tests. We reuse ghc --make and ghc -M to do
160--   all the dependency checking, keeping things nice and simple. For each
161--   test, there are three files we care about:
162--
163-- * config.txt - a cleaned up version of the configuration out of Makefile,
164--   created by convertConfig. Also contains "MAIN" which points at the name
165--   of the Main module.
166--
167-- * Main.exe - the actual binary, produced by ghc --make.
168--
169-- * Main.deps - the files that Main.exe depends on, a cleaned up version of
170--   ghc -M.
171buildRules :: Nofib -> Rules ()
172buildRules Build{..} = do
173    let unoutput x = takeDirectory $ drop (length output + 1) x
174    want $ concat
175        [ [s </> "Main" <.> exe, s </> "config.txt"] | t <- tests, let s = output </> t]
176
177    "//config.txt" *> \out -> do
178        src <- readFileLines $ unoutput out </> "Makefile"
179        let dir = unoutput out
180        let poss = ["Main.hs","Main.lhs",takeFileName dir <.> "hs",takeFileName dir <.> "lhs"]
181        bs <- filterM (doesFileExist . (dir </>)) poss
182        let mainMod = case bs of
183                [] -> error $ "Could not find Main file for " ++ dir
184                x:_ -> "MAIN = " ++ x
185        writeFileLines out $ mainMod : convertConfig src
186
187    ("//Main" <.> exe) *> \out -> do
188        deps <- readFileLines $ replaceExtension out "deps"
189        need deps
190        let dir = unoutput out
191            obj = takeDirectory out
192        config <- readConfig' $ takeDirectory out </> "config.txt"
193        system' compiler $ ["--make",dir </> config "MAIN","-w","-i" ++ dir,"-rtsopts","-odir=" ++ obj,"-hidir=" ++ obj,"-o"++out] ++
194                           way ++ words (config "SRC_HC_OPTS")
195
196    "//Main.deps" *> \out -> do
197        let dir = unoutput out
198        config <- readConfig' $ takeDirectory out </> "config.txt"
199        system' compiler $ ["-w","-M",dir </> config "MAIN","-i" ++ dir,"-dep-makefile=" ++ out <.> "ghc"] ++
200                           words (config "SRC_HC_OPTS")
201        src <- liftIO $ readFile $ out <.> "ghc"
202        let deps = [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]
203        need deps
204        writeFileLines out deps
205
206
207-- | Run a test, checking stdout/stderr are as expected, and reporting time.
208runTest :: Nofib -> String -> IO ()
209runTest Build{run=Just speed,..} test = do
210    putStr $ "Running " ++ test ++ "... "
211    config <- readConfig $ output </> test </> "config.txt"
212    let args = words (config "PROG_ARGS") ++ words (config $ map toUpper (show speed) ++ "_OPTS")
213    stdin <- let s = config "STDIN_FILE" in if s == "" then grab "stdin" else readFile $ test </> s
214    start <- getCurrentTime
215    (code,stdout,stderr) <- readProcessWithExitCodeAndWorkingDirectory test (output </> test </> "Main" <.> exe) (args++"+RTS":rts) stdin
216    end <- getCurrentTime
217    stdoutWant <- grab "stdout"
218    stderrWant <- grab "stderr"
219    writeFile (output </> test </> "stdout") stdout
220    writeFile (output </> test </> "stderr") stderr
221    putStrLn $
222        if not skip_check && stderr /= stderrWant then "FAILED STDERR\nWANTED: " ++ snip stderrWant ++ "\nGOT: " ++ snip stderr
223        else if not skip_check && stdout /= stdoutWant then "FAILED STDOUT\nWANTED: " ++ snip stdoutWant ++ "\nGOT: " ++ snip stdout
224        else if not skip_check && code /= ExitSuccess then "FAILED EXIT CODE " ++ show code
225        else show (floor $ fromRational (toRational $ end `diffUTCTime` start) * 1000) ++ "ms"
226    where
227        snip x = if length x > 200 then take 200 (reverse x) ++ "..." else x
228
229        grab ext = do
230            let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
231                    ,test </> takeFileName test <.> ext]
232            ss <- filterM IO.doesFileExist s
233            maybe (return "") readFile $ listToMaybe ss
234
235
236---------------------------------------------------------------------
237-- CONFIGURATION UTILITIES
238-- The Makefile's are slurped for configuration, to produce a cleaned-up config file
239
240-- | Given the source of a Makefile, slurp out the configuration strings.
241convertConfig :: [String] -> [String]
242convertConfig xs = [remap a ++ " = " ++ b | x <- xs, let (a,b) = separate x, a `elem` keep]
243    where
244        keep = words "PROG_ARGS SRC_HC_OPTS SRC_RUNTEST_OPTS SLOW_OPTS NORM_OPTS FAST_OPTS STDIN_FILE"
245        remap "SRC_RUNTEST_OPTS" = "PROG_ARGS"
246        remap x = x
247
248        separate x = (name,rest)
249            where (name,x2) = span (\x -> isAlpha x || x == '_') x
250                  rest = dropWhile isSpace $ dropWhile (`elem` "+=") $ dropWhile isSpace x2
251
252
253-- | Read a configuration file (new format) into a function supplying options.
254readConfig :: FilePath -> IO (String -> String)
255readConfig x = do
256    src <- readFile x
257    let res = [ (reverse $ dropWhile isSpace $ reverse a, dropWhile isSpace $ drop 1 b)
258              | y <- lines src, let (a,b) = break (== '=') y]
259    return $ \x -> fromMaybe "" $ lookup x res
260
261
262-- | readConfig lifted into the Action monad.
263readConfig' :: FilePath -> Action (String -> String)
264readConfig' x = do
265    need [x]
266    liftIO $ readConfig x
267
268
269---------------------------------------------------------------------
270-- GENERAL UTILITIES
271
272-- | The executable extension on this platform.
273exe :: String
274exe = if os == "mingw32" then "exe" else ""
275
276
277-- | Like the standard removeDirectoryRecursive, but doesn't fail if the path is missing.
278removeDirectoryRecursive :: FilePath -> IO ()
279removeDirectoryRecursive x = do
280    b <- IO.doesDirectoryExist x
281    when b $ IO.removeDirectoryRecursive x
282
283
284-- | Source for readProcessWithExitCode, plus addition of cwd
285readProcessWithExitCodeAndWorkingDirectory
286    :: FilePath                 -- ^ directory to use
287    -> FilePath                 -- ^ command to run
288    -> [String]                 -- ^ any arguments
289    -> String                   -- ^ standard input
290    -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
291readProcessWithExitCodeAndWorkingDirectory cwd cmd args input = do
292    (Just inh, Just outh, Just errh, pid) <-
293        createProcess (proc cmd args){ cwd     = Just cwd,
294                                       std_in  = CreatePipe,
295                                       std_out = CreatePipe,
296                                       std_err = CreatePipe }
297    outMVar <- newEmptyMVar
298    out  <- hGetContents outh
299    _ <- forkIO $ evaluate (length out) >> putMVar outMVar ()
300    err  <- hGetContents errh
301    _ <- forkIO $ evaluate (length err) >> putMVar outMVar ()
302    when (not (null input)) $ do hPutStr inh input; hFlush inh
303    hClose inh
304    takeMVar outMVar
305    takeMVar outMVar
306    hClose outh
307    hClose errh
308    ex <- waitForProcess pid
309
310    return (ex, out, err)