[Git][ghc/ghc][wip/js-staging] Linker: fix creation of directories in output paths

[Sylvain Henry (@hsyl20)]

Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC


Commits:
64cb5056 by Sylvain Henry at 2022-09-20T14:53:02+02:00
Linker: fix creation of directories in output paths

- - - - -


4 changed files:

- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/SysTools.hs
- compiler/GHC/Utils/Binary.hs


Changes:

=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -130,9 +130,7 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
         []
         input_fn output_fn
   return output_fn
-runPhase (T_Js pipe_env hsc_env mb_location js_src) = do
-  _out_path <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
-  runJsPhase pipe_env hsc_env mb_location js_src
+runPhase (T_Js pipe_env hsc_env _mb_location js_src) = runJsPhase pipe_env hsc_env js_src
 runPhase (T_Cmm pipe_env hsc_env input_fn) = do
   let dflags = hsc_dflags hsc_env
   let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
@@ -348,8 +346,8 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
         return output_fn
 
 
-runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
-runJsPhase pipe_env hsc_env _location input_fn = do
+runJsPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
+runJsPhase pipe_env hsc_env input_fn = do
         let dflags     = hsc_dflags   hsc_env
         let logger     = hsc_logger   hsc_env
         let tmpfs      = hsc_tmpfs    hsc_env
@@ -358,7 +356,7 @@ runJsPhase pipe_env hsc_env _location input_fn = do
         let header     = "//JavaScript\n"
 
         output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
-        need_cpp <- jsFileNeedsCpp hsc_env input_fn
+        need_cpp <- jsFileNeedsCpp input_fn
         tmp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
         -- if the input filename is the same as the output, then we've probably
         -- generated the object ourselves, we leave the file alone
@@ -381,8 +379,8 @@ runJsPhase pipe_env hsc_env _location input_fn = do
           else copyWithHeader header input_fn output_fn
         return output_fn
 
-jsFileNeedsCpp :: HscEnv -> FilePath -> IO Bool
-jsFileNeedsCpp _hsc_env fn = do
+jsFileNeedsCpp :: FilePath -> IO Bool
+jsFileNeedsCpp fn = do
   opts <- JSHeader.getOptionsFromJsFile fn
   pure (JSHeader.CPP `elem` opts)
 


=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -35,9 +35,11 @@ import          GHC.StgToJS.Types
 import           Prelude
 import GHC.Platform
 import Data.List (isPrefixOf)
+import System.Directory (createDirectoryIfMissing)
 
 writeBinaryFile :: FilePath -> ByteString -> IO ()
-writeBinaryFile file bs =
+writeBinaryFile file bs = do
+  createDirectoryIfMissing True (takeDirectory file)
   withBinaryFile file WriteMode $ \h -> mapM_ (B.hPut h) (chunks bs)
   where
     -- split the ByteString into a nonempty list of chunks of at most 1GiB


=====================================
compiler/GHC/SysTools.hs
=====================================
@@ -44,7 +44,8 @@ import GHC.Settings.IO
 import Control.Monad.Trans.Except (runExceptT)
 import System.IO
 import Foreign.Marshal.Alloc (allocaBytes)
-import System.Directory (copyFile)
+import System.Directory (copyFile,createDirectoryIfMissing)
+import System.FilePath
 
 {-
 Note [How GHC finds toolchain utilities]
@@ -155,7 +156,8 @@ copyHandle hin hout = do
 
 -- | Copy file after printing the given header
 copyWithHeader :: String -> FilePath -> FilePath -> IO ()
-copyWithHeader header from to =
+copyWithHeader header from to = do
+  createDirectoryIfMissing True (takeDirectory to)
   withBinaryFile to WriteMode $ \hout -> do
     -- write the header string in UTF-8.  The header is something like
     --   {-# LINE "foo.hs" #-}


=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -116,6 +116,8 @@ import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
 import Data.IntMap (IntMap)
+import System.Directory
+import System.FilePath
 import qualified Data.IntMap as IntMap
 #if MIN_VERSION_base(4,15,0)
 import GHC.ForeignPtr           ( unsafeWithForeignPtr )
@@ -277,6 +279,7 @@ seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
 
 writeBinMem :: BinHandle -> FilePath -> IO ()
 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
+  createDirectoryIfMissing True (takeDirectory fn)
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64cb5056fbb88b10323c96f133924277aeb415d0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64cb5056fbb88b10323c96f133924277aeb415d0
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220920/ec4cd7e0/attachment-0001.html>