----------------------------------------------------------------------------- -- | -- 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 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" -- ,"-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."