Make GHCi & TH work when the compiler is built with -prof
[ghc.git] / testsuite / mk / ghc-config.hs
1 import System.Environment
2 import System.Process
3 import Data.Maybe
4
5 main = do
6 [ghc] <- getArgs
7
8 info <- readProcess ghc ["+RTS", "--info"] ""
9 let fields = read info :: [(String,String)]
10 getGhcFieldOrFail fields "HostOS" "Host OS"
11 getGhcFieldOrFail fields "WORDSIZE" "Word size"
12 getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
13 getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
14 getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
15
16 info <- readProcess ghc ["--info"] ""
17 let fields = read info :: [(String,String)]
18
19 getGhcFieldOrFail fields "GhcStage" "Stage"
20 getGhcFieldOrFail fields "GhcDebugged" "Debug on"
21 getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
22 getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
23 getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
24 getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
25 getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
26 getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
27 getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
28 getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
29 getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
30 getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
31
32 let pkgdb_flag = case lookup "Project version" fields of
33 Just v
34 | parseVersion v >= [7,5] -> "package-db"
35 _ -> "package-conf"
36 putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag
37
38 let minGhcVersion711 = case lookup "Project version" fields of
39 Just v
40 | parseVersion v >= [7,11] -> "YES"
41 _ -> "NO"
42 putStrLn $ "MinGhcVersion711" ++ '=':minGhcVersion711
43
44
45 getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
46 getGhcFieldOrFail fields mkvar key
47 = getGhcField fields mkvar key id (fail ("No field: " ++ key))
48
49 getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO ()
50 getGhcFieldOrDefault fields mkvar key deflt
51 = getGhcField fields mkvar key id on_fail
52 where
53 on_fail = putStrLn (mkvar ++ '=' : deflt)
54
55 getGhcFieldProgWithDefault
56 :: [(String,String)]
57 -> String -> String -> String
58 -> IO ()
59 getGhcFieldProgWithDefault fields mkvar key deflt
60 = getGhcField fields mkvar key fix on_fail
61 where
62 fix val = fixSlashes (fixTopdir topdir val)
63 topdir = fromMaybe "" (lookup "LibDir" fields)
64 on_fail = putStrLn (mkvar ++ '=' : deflt)
65
66 getGhcField
67 :: [(String,String)] -> String -> String
68 -> (String -> String)
69 -> IO ()
70 -> IO ()
71 getGhcField fields mkvar key fix on_fail =
72 case lookup key fields of
73 Nothing -> on_fail
74 Just val -> putStrLn (mkvar ++ '=' : fix val)
75
76 fixTopdir :: String -> String -> String
77 fixTopdir t "" = ""
78 fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s
79 fixTopdir t (c:s) = c : fixTopdir t s
80
81 fixSlashes :: FilePath -> FilePath
82 fixSlashes = map f
83 where f '\\' = '/'
84 f c = c
85
86 parseVersion :: String -> [Int]
87 parseVersion v = case break (== '.') v of
88 (n, rest) -> read n : case rest of
89 [] -> []
90 ('.':v') -> parseVersion v'
91 _ -> error "bug in parseVersion"