@@ -20,11 +20,15 @@ module Development.IDE.GHC.Util(
20
20
moduleImportPath ,
21
21
HscEnvEq , hscEnv , newHscEnvEq ,
22
22
readFileUtf8 ,
23
+ hDuplicateTo ,
23
24
cgGutsToCoreModule
24
25
) where
25
26
26
27
import Config
28
+ import Control.Concurrent
27
29
import Data.List.Extra
30
+ import Data.Maybe
31
+ import Data.Typeable
28
32
#if MIN_GHC_API_VERSION(8,6,0)
29
33
import Fingerprint
30
34
#endif
@@ -34,6 +38,12 @@ import GhcPlugins hiding (Unique)
34
38
import Data.IORef
35
39
import Control.Exception
36
40
import 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
37
47
import Platform
38
48
import Data.Unique
39
49
import Development.Shake.Classes
@@ -154,3 +164,71 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
154
164
(md_types modDetails)
155
165
(cg_binds guts)
156
166
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 )
0 commit comments