Hs2lib-0.5.5: WinDll/Utils/Processes.hs
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- The main entry file for the preprocessor
-- part of the WinDll suite
--
-----------------------------------------------------------------------------
module WinDll.Utils.Processes where
import WinDll.Builder
import WinDll.Session.Hs2lib
import WinDll.Utils.Feedback
import WinDll.EntryPoint
import Control.Monad
import System.Random
import System.FilePath
import System.Directory
import System.IO
import System.IO.Error
import System.Environment
import System.Process hiding (createProcess)
import qualified System.Process as Proc
import System.Exit
import GHC.Paths
import Paths_Hs2lib
type Process = FilePath -> Exec (String,[String]) -> Component
-- | Create and run processes
createProcess :: Maybe FilePath -> Process
createProcess wd name robot =
do (outfile,args) <- robot
session <- get
let build = pipeline session
fullfile = dirPath build
args' = map (strReplace "%filepath" fullfile) args
proc' = name ++ (case platform session of
Unix -> ""
Windows -> ".exe")
inform _normal ("*** running " ++ name ++ "...")
inform _detail ("*** " ++ proc' ++ " " ++ unwords args')
(pcode) <-
liftIO $ do try $ Proc.createProcess
(proc proc' args'){ cwd = wd `mplus` Just (fullfile)
, std_out = CreatePipe
, std_err = CreatePipe
}
(code,_out) <- case pcode of
Left err -> die ("Error running process '" ++ name ++ "' \n\t" ++ show err)
Right code -> readWhileWaitForProcess code
case code of
ExitSuccess -> do inform _detail _out
inform _normal ("*** process completed successfully.")
inform _detail ("*** Writing " ++ fullfile ++ outfile)
put $ session { pipeline = build { files = outfile :(files build) } }
(ExitFailure _) -> do inform _detail _out
inform _normal ("*** process failed.")
die ("remote fault. failed to create " ++ outfile)
-- | A helper function to loop and print only the information i want out.
readWhileWaitForProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Exec (ExitCode,String)
readWhileWaitForProcess full@(_, Just hout, Just herr, proccode)
= do ret <- liftIO $ getProcessExitCode proccode
case ret of
Just c -> liftIO ( hGetContents hout >>= (\v->hClose hout>>return v) )
>>= (\val -> return (c, val))
Nothing -> do p <- liftIO $ try (hLookAhead herr)
case p of
Right '[' -> (liftIO $ putStrLn =<< hGetLine herr)
>> readWhileWaitForProcess full
Right 'L' -> (liftIO $ putStrLn =<< hGetLine herr)
>> readWhileWaitForProcess full
Right _ -> (liftIO $ hGetLine herr)
>>= inform _normal
>> readWhileWaitForProcess full
Left _ -> readWhileWaitForProcess full -- will hopefully exit
-- | Run the entire compilation pipeline.
runCompilePipeLine :: Exec ()
runCompilePipeLine = do inform _normal "Compiling..."
session <- get
env <- liftIO $ getEnvironment
let vsbin = maybe "." addTrailingPathSeparator (lookup "VSBIN" env)
createProcess Nothing "ghc" createDllMain
createProcess Nothing "hsc2hs" createHSfile
createProcess Nothing "ghc" createDLL
when (mvcpp session) $ createProcess (Just vsbin) "lib" createLIB
moveAllFiles
-- | Create the dllMain c file.
createDllMain :: Exec (String,[String])
createDllMain = do session <- get
return ("dllmain.o",["-c"]
++ (if (platform session) == Windows then [] else ["-fPIC"]) ++
["dllmain.c"])
-- | Process hsc file
createHSfile :: Exec (String,[String])
createHSfile = do session <- get
let out_ = namespace session ++ ".hs"
in_ = namespace session ++ ".hsc"
ghc_ = reverse $ dropWhile (/=pathSeparator) $ reverse libdir
odir = outputDIR session
ldir = addTrailingPathSeparator (baseDir session) ++ "Includes"
cc1 = ghc_ ++ "mingw"
++ [pathSeparator] ++ "libexec"
++ [pathSeparator] ++ "gcc"
++ [pathSeparator] ++ "mingw32"
++ [pathSeparator] ++ "3.4.5"
++ [pathSeparator] ++ "cc1.exe"
ldir2 <- liftIO $ getDataFileName "Includes"
return (out_
,["-o" ++ out_
,"-I" ++ ldir
,"-I" ++ ldir2
, in_ ]) --, "-c " ++ cc1])
-- | Create the final shared lib
createDLL :: Exec (String,[String])
createDLL = do session <- get
let output = outputFile session
name = namespace session
extra = "HS" ++ name ++ ".a"
odir = outputDIR session
build = pipeline session
fullfile = dirPath build
os = platform session
dir = baseDir session
extras = optGHC session
return (output,["-fglasgow-exts"
,"--make"
]
++ (if os == Windows then [] else ["-fPIC"]) ++
["-shared"
,"-o" ++ output
,fullfile ++ name ++ ".hs"
,"dllmain.o"
]
++ (if os == Windows then ["exports.def"] else [])
++ (if link_dynamic session then ["-dynamic"] else [])
++ (if threaded session then ["-threaded"] else [])
++ ["-fno-warn-deprecated-flags"
,"-O2"
,"-package ghc"
,"-package Hs2lib"
,"-i" ++ if ' ' `elem` dir then show dir else dir
--,"-outputdir " ++ if ' ' `elem` odir then show odir else odir
,"-optl --enable-stdcall-fixup"
--,"-optl --disable-stdcall-fixup"
,"-optl-Wl,-s"
,"-funfolding-use-threshold=16"
,"-optc-O3"
,"-optc-ffast-math"
]
++ if null extras then [] else [extras] ++
[
-- ,"-debug"
-- ,"-fno-full-laziness" -- due to calls to unsafePerformIO
-- ,"-fno-cse" -- prevent any cse to be performed.
-- ,"-prof"
-- ,"-auto-all"
-- ,"-caf-all"
])
-- | Create the MSVC++ lib
createLIB :: Exec (String,[String])
createLIB = do session <- get
let name = namespace session
odir = addTrailingPathSeparator $ outputDIR session
lib = name ++ ".lib"
def = "exports.lib"
return (lib, ["/DEF:\""++odir ++ "exports.def\""
,"/out:\"" ++ odir ++ lib ++ "\""])
-- | Move all the required files to their final destinations
moveAllFiles :: Exec ()
moveAllFiles = do session <- get
let output = outputFile session
name = namespace session
extra = "HS" ++ name ++ ".a"
header = name ++ ".h"
ffi = name ++ "_FFI.h"
csfile = name ++ ".cs"
lib = name ++ ".lib"
odir = addTrailingPathSeparator $ outputDIR session
build = pipeline session
fullfile = dirPath build
liftIO $ copyFile (fullfile++output) (odir++output)
liftIO $ copyFile (fullfile++"HSdll.dll.a") (odir++extra)
when (cpp session) $
do liftIO $ copyFile (fullfile++header) (odir++header)
liftIO $ copyFile (fullfile++ffi) (odir++ffi)
when (csharp session) $
liftIO $ copyFile (fullfile++csfile) (odir++csfile)
when (mvcpp session) $
liftIO $ copyFile (fullfile++lib) (odir++lib)
when (incDef session) $
liftIO $ copyFile (fullfile++"exports.def") (odir++name++".def")
inform _normal "Files copied."