Commit baf9da65 authored by Simon Marlow's avatar Simon Marlow
Browse files

make it optional to have DynamicByDefault, to support older GHCs

It's often useful to be able to say 'make TEST_HC=ghc' to check that a
test really fails with a different GHC.
parent 8c3dc562
......@@ -7,22 +7,22 @@ main = do
info <- readProcess ghc ["+RTS", "--info"] ""
let fields = read info :: [(String,String)]
getGhcField fields "HostOS" "Host OS"
getGhcField fields "WORDSIZE" "Word size"
getGhcField fields "TARGETPLATFORM" "Target platform"
getGhcField fields "TargetOS_CPP" "Target OS"
getGhcField fields "TargetARCH_CPP" "Target architecture"
getGhcFieldOrFail fields "HostOS" "Host OS"
getGhcFieldOrFail fields "WORDSIZE" "Word size"
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
getGhcField fields "GhcStage" "Stage"
getGhcField fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcField fields "GhcWithInterpreter" "Have interpreter"
getGhcField fields "GhcUnregisterised" "Unregisterised"
getGhcField fields "GhcWithSMP" "Support SMP"
getGhcField fields "GhcRTSWays" "RTS ways"
getGhcField fields "GhcDynamicByDefault" "Dynamic by default"
getGhcFieldOrFail fields "GhcStage" "Stage"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
let pkgdb_flag = case lookup "Project version" fields of
......@@ -32,20 +32,36 @@ main = do
putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag
getGhcField :: [(String,String)] -> String -> String -> IO ()
getGhcField fields mkvar key =
case lookup key fields of
Nothing -> fail ("No field: " ++ key)
Just val -> putStrLn (mkvar ++ '=':val)
getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
getGhcFieldOrFail fields mkvar key
= getGhcField fields mkvar key id (fail ("No field: " ++ key))
getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO ()
getGhcFieldOrDefault fields mkvar key deflt
= getGhcField fields mkvar key id on_fail
where
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcFieldProgWithDefault
:: [(String,String)]
-> String -> String -> String
-> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt
= getGhcField fields mkvar key fix on_fail
where
fix val = fixSlashes (fixTopdir topdir val)
topdir = fromMaybe "" (lookup "LibDir" fields)
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcFieldProgWithDefault :: [(String,String)]
-> String -> String -> String -> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt = do
getGhcField
:: [(String,String)] -> String -> String
-> (String -> String)
-> IO ()
-> IO ()
getGhcField fields mkvar key fix on_fail =
case lookup key fields of
Nothing -> putStrLn (mkvar ++ '=' : deflt)
Just val -> putStrLn (mkvar ++ '=' : fixSlashes (fixTopdir topdir val))
where
topdir = fromMaybe "" (lookup "LibDir" fields)
Nothing -> on_fail
Just val -> putStrLn (mkvar ++ '=' : fix val)
fixTopdir :: String -> String -> String
fixTopdir t "" = ""
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment