From 027a13448cc67f3fce955308efb81a6556c11598 Mon Sep 17 00:00:00 2001 From: Gershom Date: Fri, 8 Mar 2019 13:58:59 -0500 Subject: [PATCH 1/2] resp file generation --- Common.hs | 61 ++++++++++++++++++++++++++++++++++++++++++------ DirectCodegen.hs | 6 ++--- UtilsCodegen.hs | 3 +-- 3 files changed, 58 insertions(+), 12 deletions(-) diff --git a/Common.hs b/Common.hs index fefc40c..7c335ff 100644 --- a/Common.hs +++ b/Common.hs @@ -3,9 +3,11 @@ module Common where import Control.Exception ( bracket_ ) import qualified Control.Exception as Exception import Control.Monad ( when ) +import Data.Char ( isSpace ) +import Data.List ( foldl' ) import System.IO -import System.Process ( rawSystem, runProcess, waitForProcess ) +import System.Process ( createProcess, proc, runProcess, waitForProcess ) import System.Exit ( ExitCode(..), exitWith ) import System.Directory ( removeFile ) @@ -22,23 +24,25 @@ default_compiler = "gcc" writeBinaryFile :: FilePath -> String -> IO () writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str -rawSystemL :: String -> Bool -> FilePath -> [String] -> IO () -rawSystemL action flg prog args = do +rawSystemL :: FilePath -> String -> Bool -> FilePath -> [String] -> IO () +rawSystemL outDir action flg prog args = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do let cmdLine = prog++" "++unwords args when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) - exitStatus <- rawSystem prog args + (_,_,_,ph) <- createProcess (proc prog ['@':rspFile]) + exitStatus <- waitForProcess ph case exitStatus of ExitFailure exitCode -> die $ action ++ " failed " ++ "(exit code " ++ show exitCode ++ ")\n" ++ "command was: " ++ cmdLine ++ "\n" _ -> return () -rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO () -rawSystemWithStdOutL action flg prog args outFile = do + +rawSystemWithStdOutL :: FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO () +rawSystemWithStdOutL outDir action flg prog args outFile = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do let cmdLine = prog++" "++unwords args++" >"++outFile when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) hOut <- openFile outFile WriteMode - process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing + process <- runProcess prog ['@':rspFile] Nothing Nothing Nothing (Just hOut) Nothing exitStatus <- waitForProcess process hClose hOut case exitStatus of @@ -65,3 +69,46 @@ catchIO = Exception.catch onlyOne :: String -> IO a onlyOne what = die ("Only one "++what++" may be specified\n") + +-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile + +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> do hClose handle + removeFile $ name) + (uncurry action) + +withResponseFile :: + FilePath -- ^ Working directory to create response file in. + -> FilePath -- ^ Template for response file name. + -> [String] -- ^ Arguments to put into response file. + -> (FilePath -> IO a) + -> IO a +withResponseFile workDir fileNameTemplate arguments f = + withTempFile workDir fileNameTemplate $ \responseFileName hf -> do + let responseContents = unlines $ map escapeResponseFileArg arguments + hPutStr hf responseContents + hClose hf + f responseFileName + +-- Support a gcc-like response file syntax. Each separate +-- argument and its possible parameter(s), will be separated in the +-- response file by an actual newline; all other whitespace, +-- single quotes, double quotes, and the character used for escaping +-- (backslash) are escaped. The called program will need to do a similar +-- inverse operation to de-escape and re-constitute the argument list. +escapeResponseFileArg :: String -> String +escapeResponseFileArg = reverse . foldl' escape [] + where + escape :: String -> Char -> String + escape cs c = + case c of + '\\' -> c:'\\':cs + '\'' -> c:'\\':cs + '"' -> c:'\\':cs + _ | isSpace c -> c:'\\':cs + | otherwise -> c:cs diff --git a/DirectCodegen.hs b/DirectCodegen.hs index 9bfdd42..9f7785f 100644 --- a/DirectCodegen.hs +++ b/DirectCodegen.hs @@ -73,7 +73,7 @@ outputDirect config outName outDir outBase name toks = do when (cNoCompile config) $ exitWith ExitSuccess - rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config) + rawSystemL outDir ("compiling " ++ cProgName) beVerbose (cCompiler config) ( ["-c"] ++ [cProgName] ++ ["-o", oProgName] @@ -82,14 +82,14 @@ outputDirect config outName outDir outBase name toks = do possiblyRemove cProgName $ withUtilsObject config outDir outBase $ \oUtilsName -> do - rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config) + rawSystemL outDir ("linking " ++ oProgName) beVerbose (cLinker config) ( [oProgName, oUtilsName] ++ ["-o", progName] ++ [f | LinkFlag f <- flags] ) possiblyRemove oProgName $ do - rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName + rawSystemWithStdOutL outDir ("running " ++ execProgName) beVerbose execProgName [] outName possiblyRemove progName $ do when needsH $ writeBinaryFile outHName $ diff --git a/UtilsCodegen.hs b/UtilsCodegen.hs index 19befd2..67d9a7c 100644 --- a/UtilsCodegen.hs +++ b/UtilsCodegen.hs @@ -76,11 +76,10 @@ withUtilsObject config outDir outBase f = do possiblyRemove oUtilsName $ do unless (cNoCompile config) $ - rawSystemL ("compiling " ++ cUtilsName) + rawSystemL outDir ("compiling " ++ cUtilsName) beVerbose (cCompiler config) (["-c", cUtilsName, "-o", oUtilsName] ++ [cFlag | CompFlag cFlag <- flags]) f oUtilsName - From 9a49d1835f16fab3691798bcdcadee9d59fbe013 Mon Sep 17 00:00:00 2001 From: gbaz Date: Sat, 20 Jul 2019 20:13:07 -0400 Subject: [PATCH 2/2] Update Common.hs --- Common.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Common.hs b/Common.hs index aa0ec2b..1906c31 100644 --- a/Common.hs +++ b/Common.hs @@ -45,7 +45,6 @@ rawSystemWithStdOutL outDir action flg prog args outFile = withResponseFile outD let cmdLine = prog++" "++unwords args++" >"++outFile when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) hOut <- openFile outFile WriteMode - process <- runProcess prog Nothing Nothing Nothing (Just hOut) Nothing (_ ,_ ,_ , process) <- -- We use createProcess here instead of runProcess since we need to specify -- a custom CreateProcess structure to turn on use_process_jobs when