@@ -20,11 +20,15 @@ module Development.IDE.GHC.Util(
2020 moduleImportPath,
2121 HscEnvEq, hscEnv, newHscEnvEq,
2222 readFileUtf8,
23+ hDuplicateTo,
2324 cgGutsToCoreModule
2425 ) where
2526
2627import Config
28+import Control.Concurrent
2729import Data.List.Extra
30+import Data.Maybe
31+import Data.Typeable
2832#if MIN_GHC_API_VERSION(8,6,0)
2933import Fingerprint
3034#endif
@@ -34,6 +38,12 @@ import GhcPlugins hiding (Unique)
3438import Data.IORef
3539import Control.Exception
3640import FileCleanup
41+import GHC.IO.BufferedIO (BufferedIO)
42+import GHC.IO.Device as IODevice
43+import GHC.IO.Encoding
44+import GHC.IO.Exception
45+import GHC.IO.Handle.Types
46+import GHC.IO.Handle.Internals
3747import Platform
3848import Data.Unique
3949import Development.Shake.Classes
@@ -154,3 +164,71 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
154164 (md_types modDetails)
155165 (cg_binds guts)
156166 safeMode
167+
168+-- This is a slightly modified version of hDuplicateTo in GHC.
169+-- See the inline comment for more details.
170+hDuplicateTo :: Handle -> Handle -> IO ()
171+hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
172+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
173+ -- The implementation in base has this call to hClose_help.
174+ -- _ <- hClose_help h2_
175+ -- hClose_help does two things:
176+ -- 1. It flushes the buffer, we replicate this here
177+ _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure ()
178+ -- 2. It closes the handle. This is redundant since dup2 takes care of that
179+ -- but even worse it is actively harmful! Once the handle has been closed
180+ -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY
181+ -- if it happens just in the right moment.
182+ withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
183+ dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
184+hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
185+ withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
186+ _ <- hClose_help w2_
187+ withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
188+ dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
189+ withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
190+ _ <- hClose_help r2_
191+ withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
192+ dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
193+hDuplicateTo h1 _ =
194+ ioe_dupHandlesNotCompatible h1
195+
196+-- | This is copied unmodified from GHC since it is not exposed.
197+dupHandleTo :: FilePath
198+ -> Handle
199+ -> Maybe (MVar Handle__)
200+ -> Handle__
201+ -> Handle__
202+ -> Maybe HandleFinalizer
203+ -> IO Handle__
204+dupHandleTo filepath h other_side
205+ _hto_@Handle__{haDevice=devTo}
206+ h_@Handle__{haDevice=dev} mb_finalizer = do
207+ flushBuffer h_
208+ case cast devTo of
209+ Nothing -> ioe_dupHandlesNotCompatible h
210+ Just dev' -> do
211+ _ <- IODevice.dup2 dev dev'
212+ FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
213+ takeMVar m
214+
215+-- | This is copied unmodified from GHC since it is not exposed.
216+-- Note the beautiful inline comment!
217+dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
218+ -> FilePath
219+ -> Maybe (MVar Handle__)
220+ -> Handle__
221+ -> Maybe HandleFinalizer
222+ -> IO Handle
223+dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do
224+ -- XXX wrong!
225+ mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
226+ mkHandle new_dev filepath haType True{-buffered-} mb_codec
227+ NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
228+ mb_finalizer other_side
229+
230+-- | This is copied unmodified from GHC since it is not exposed.
231+ioe_dupHandlesNotCompatible :: Handle -> IO a
232+ioe_dupHandlesNotCompatible h =
233+ ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
234+ "handles are incompatible" Nothing Nothing)