{-# LANGUAGE ScopedTypeVariables #-}
module GHC.SysTools (
initSysTools,
lazyInitLlvmConfig,
module GHC.SysTools.Tasks,
module GHC.SysTools.Info,
copyFile,
copyHandle,
copyWithHeader,
Option(..),
expandTopDir,
) where
import GHC.Prelude
import GHC.Settings.Utils
import GHC.Utils.Panic
import GHC.Driver.Session
import GHC.Linker.ExtraObj
import GHC.SysTools.Info
import GHC.SysTools.Tasks
import GHC.SysTools.BaseDir
import GHC.Settings.IO
import Control.Monad.Trans.Except (runExceptT)
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
import Foreign.Marshal.Alloc (allocaBytes)
import System.Directory (copyFile)
lazyInitLlvmConfig :: String
-> IO LlvmConfig
lazyInitLlvmConfig :: String -> IO LlvmConfig
lazyInitLlvmConfig String
top_dir
= IO LlvmConfig -> IO LlvmConfig
forall a. IO a -> IO a
unsafeInterleaveIO (IO LlvmConfig -> IO LlvmConfig) -> IO LlvmConfig -> IO LlvmConfig
forall a b. (a -> b) -> a -> b
$ do
[(String, (String, String, String))]
targets <- String -> IO [(String, (String, String, String))]
forall a. Read a => String -> IO a
readAndParse String
"llvm-targets"
[(Int, String)]
passes <- String -> IO [(Int, String)]
forall a. Read a => String -> IO a
readAndParse String
"llvm-passes"
LlvmConfig -> IO LlvmConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmConfig -> IO LlvmConfig) -> LlvmConfig -> IO LlvmConfig
forall a b. (a -> b) -> a -> b
$ LlvmConfig { llvmTargets :: [(String, LlvmTarget)]
llvmTargets = ((String, String, String) -> LlvmTarget)
-> (String, (String, String, String)) -> (String, LlvmTarget)
forall a b. (a -> b) -> (String, a) -> (String, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, String, String) -> LlvmTarget
mkLlvmTarget ((String, (String, String, String)) -> (String, LlvmTarget))
-> [(String, (String, String, String))] -> [(String, LlvmTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, (String, String, String))]
targets,
llvmPasses :: [(Int, String)]
llvmPasses = [(Int, String)]
passes }
where
readAndParse :: Read a => String -> IO a
readAndParse :: forall a. Read a => String -> IO a
readAndParse String
name =
do let llvmConfigFile :: String
llvmConfigFile = String
top_dir String -> String -> String
</> String
name
String
llvmConfigStr <- String -> IO String
readFile String
llvmConfigFile
case String -> Maybe a
forall a. Read a => String -> Maybe a
maybeReadFuzzy String
llvmConfigStr of
Just a
s -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
Maybe a
Nothing -> String -> IO a
forall a. String -> a
pgmError (String
"Can't parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
llvmConfigFile)
mkLlvmTarget :: (String, String, String) -> LlvmTarget
mkLlvmTarget :: (String, String, String) -> LlvmTarget
mkLlvmTarget (String
dl, String
cpu, String
attrs) = String -> String -> [String] -> LlvmTarget
LlvmTarget String
dl String
cpu (String -> [String]
words String
attrs)
initSysTools :: String
-> IO Settings
initSysTools :: String -> IO Settings
initSysTools String
top_dir = do
Either SettingsError Settings
res <- ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings))
-> ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall a b. (a -> b) -> a -> b
$ String -> ExceptT SettingsError IO Settings
forall (m :: * -> *).
MonadIO m =>
String -> ExceptT SettingsError m Settings
initSettings String
top_dir
case Either SettingsError Settings
res of
Right Settings
a -> Settings -> IO Settings
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings
a
Left (SettingsError_MissingData String
msg) -> String -> IO Settings
forall a. String -> a
pgmError String
msg
Left (SettingsError_BadData String
msg) -> String -> IO Settings
forall a. String -> a
pgmError String
msg
copyHandle :: Handle -> Handle -> IO ()
copyHandle :: Handle -> Handle -> IO ()
copyHandle Handle
hin Handle
hout = do
let buf_size :: Int
buf_size = Int
8192
Int -> (Ptr Any -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
buf_size ((Ptr Any -> IO ()) -> IO ()) -> (Ptr Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr -> do
let go :: IO ()
go = do
Int
c <- Handle -> Ptr Any -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
hin Ptr Any
ptr Int
buf_size
Handle -> Ptr Any -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hout Ptr Any
ptr Int
c
if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else IO ()
go
IO ()
go
copyWithHeader :: String -> FilePath -> FilePath -> IO ()
String
header String
from String
to =
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
to IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hout -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hout TextEncoding
utf8
Handle -> String -> IO ()
hPutStr Handle
hout String
header
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
from IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hin ->
Handle -> Handle -> IO ()
copyHandle Handle
hin Handle
hout