Teo Camarasu pushed to branch wip/T26834 at Glasgow Haskell Compiler / GHC

Commits:

18 changed files:

Changes:

  • libraries/base/src/Control/Exception.hs
    ... ... @@ -124,6 +124,7 @@ module Control.Exception
    124 124
    125 125 
     import GHC.Internal.Control.Exception
    126 126 
     import GHC.Internal.Exception.Type
    127 
    +import GHC.Internal.Conc.Sync
    127 128
    128 129 
     {- $catching
    129 130

  • libraries/base/src/Control/Exception/Base.hs
    1 
    -{-# LANGUAGE Safe #-}
    1 
    +{-# LANGUAGE Trustworthy #-}
    2 2
    3 3 
     -- |
    4 4 
     --
    ... ... @@ -91,3 +91,4 @@ module Control.Exception.Base
    91 91 
          ) where
    92 92
    93 93 
     import GHC.Internal.Control.Exception.Base
    94 
    +import GHC.Internal.Conc.Sync (throwTo)

  • libraries/base/src/System/IO.hs
    ... ... @@ -185,6 +185,7 @@ module System.IO
    185 185 
          ) where
    186 186
    187 187 
     import GHC.Internal.System.IO
    188 
    +import GHC.Internal.Control.Monad.Fix (fixIO)
    188 189
    189 190 
     -- $locking
    190 191 
     -- Implementations should enforce as far as possible, at least locally to the

  • libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs
    ... ... @@ -66,6 +66,7 @@ import GHC.Internal.Foreign.C.Types
    66 66 
     import GHC.Internal.Control.Monad.Fail
    67 67 
     import GHC.Internal.Data.Either
    68 68 
     import qualified GHC.Internal.Control.Exception.Base as Exception
    69 
    +import qualified GHC.Internal.Conc.Sync as Exception
    69 70 
     import GHC.Internal.Base
    70 71 
     import GHC.Internal.Conc.Sync
    71 72 
     import GHC.Internal.IO

  • libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc
    ... ... @@ -48,7 +48,7 @@ import GHC.Internal.Foreign.Marshal.Alloc
    48 48 
     import GHC.Internal.Foreign.Ptr
    49 49 
     import GHC.Internal.Foreign.Storable
    50 50 
     import GHC.Internal.Stable
    51 
    -import GHC.Internal.Conc.IO
    51 
    +import GHC.Internal.Event.Thread
    52 52 
     import GHC.Internal.Control.Concurrent.MVar
    53 53
    54 54 
     data Handler

  • libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
    ... ... @@ -64,7 +64,6 @@ module GHC.Internal.Control.Exception (
    64 64 
             throwIO,
    65 65 
             rethrowIO,
    66 66 
             ioError,
    67 
    -        throwTo,
    68 67
    69 68 
             -- ** The @catch@ functions
    70 69 
             catch,

  • libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
    ... ... @@ -49,7 +49,6 @@ module GHC.Internal.Control.Exception.Base (
    49 49 
             rethrowIO,
    50 50 
             throw,
    51 51 
             ioError,
    52 
    -        throwTo,
    53 52
    54 53 
             -- * Catching Exceptions
    55 54
    ... ... @@ -118,7 +117,6 @@ import GHC.Internal.IO.Exception
    118 117 
     import           GHC.Internal.Exception.Type
    119 118 
     import           GHC.Internal.Show
    120 119 
     -- import GHC.Internal.Exception hiding ( Exception )
    121 
    -import           GHC.Internal.Conc.Sync
    122 120
    123 121 
     import           GHC.Internal.Data.Either
    124 122

  • libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs
    ... ... @@ -24,7 +24,8 @@
    24 24
    25 25 
     module GHC.Internal.Control.Monad.Fix (
    26 26 
             MonadFix(mfix),
    27 
    -        fix
    27 
    +        fix,
    28 
    +        fixIO
    28 29 
       ) where
    29 30
    30 31 
     import GHC.Internal.Data.Either
    ... ... @@ -34,12 +35,15 @@ import GHC.Internal.Data.Monoid ( Monoid, Dual(..), Sum(..), Product(..)
    34 35 
                        , First(..), Last(..), Alt(..), Ap(..) )
    35 36 
     import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )
    36 37 
     import GHC.Internal.Data.Tuple ( Solo(..), snd )
    37 
    -import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.) )
    38 
    +import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.), return )
    38 39 
     import GHC.Internal.List ( head, drop )
    39 40 
     import GHC.Internal.Control.Monad.ST
    40 
    -import GHC.Internal.System.IO
    41 41 
     import GHC.Internal.Data.Functor.Identity (Identity(..))
    42 42 
     import GHC.Internal.Generics
    43 
    +import GHC.Internal.IO
    44 
    +import GHC.Internal.IO.Exception
    45 
    +import GHC.Internal.IO.Unsafe ()
    46 
    +import GHC.Internal.MVar
    43 47
    44 48 
     -- | Monads having fixed points with a \'knot-tying\' semantics.
    45 49 
     -- Instances of 'MonadFix' should satisfy the following laws:
    ... ... @@ -98,6 +102,86 @@ instance MonadFix NonEmpty where
    98 102 
           neHead ~(a :| _) = a
    99 103 
           neTail ~(_ :| as) = as
    100 104
    105 
    +-- ---------------------------------------------------------------------------
    106 
    +-- fixIO
    107 
    +
    108 
    +-- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'.
    109 
    +--
    110 
    +-- This operation may fail with:
    111 
    +--
    112 
    +-- * 'FixIOException' if the function passed to 'fixIO' inspects its argument.
    113 
    +--
    114 
    +-- ==== __Examples__
    115 
    +--
    116 
    +-- the IO-action is only executed once. The recursion is only on the values.
    117 
    +--
    118 
    +-- >>> take 3 <$> fixIO (\x -> putStr ":D" >> (:x) <$> readLn @Int)
    119 
    +-- :D
    120 
    +-- 2
    121 
    +-- [2,2,2]
    122 
    +--
    123 
    +-- If we are strict in the value, just as with 'Data.Function.fix', we do not get termination:
    124 
    +--
    125 
    +-- >>> fixIO (\x -> putStr x >> pure ('x' : x))
    126 
    +-- * hangs forever *
    127 
    +--
    128 
    +-- We can tie the knot of a structure within 'IO' using 'fixIO':
    129 
    +--
    130 
    +-- @
    131 
    +-- data Node = MkNode Int (IORef Node)
    132 
    +--
    133 
    +-- foo :: IO ()
    134 
    +-- foo = do
    135 
    +--   p \<- fixIO (\p -> newIORef (MkNode 0 p))
    136 
    +--   q <- output p
    137 
    +--   r <- output q
    138 
    +--   _ <- output r
    139 
    +--   pure ()
    140 
    +--
    141 
    +-- output :: IORef Node -> IO (IORef Node)
    142 
    +-- output ref = do
    143 
    +--   MkNode x p <- readIORef ref
    144 
    +--   print x
    145 
    +--   pure p
    146 
    +-- @
    147 
    +--
    148 
    +-- >>> foo
    149 
    +-- 0
    150 
    +-- 0
    151 
    +-- 0
    152 
    +fixIO :: (a -> IO a) -> IO a
    153 
    +fixIO k = do
    154 
    +    m <- newEmptyMVar
    155 
    +    ans <- unsafeDupableInterleaveIO
    156 
    +             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
    157 
    +                                    throwIO FixIOException)
    158 
    +    result <- k ans
    159 
    +    putMVar m result
    160 
    +    return result
    161 
    +
    162 
    +-- Note [Blackholing in fixIO]
    163 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    164 
    +-- We do our own explicit black holing here, because GHC's lazy
    165 
    +-- blackholing isn't enough.  In an infinite loop, GHC may run the IO
    166 
    +-- computation a few times before it notices the loop, which is wrong.
    167 
    +--
    168 
    +-- NOTE2: the explicit black-holing with an IORef ran into trouble
    169 
    +-- with multiple threads (see #5421), so now we use an MVar. We used
    170 
    +-- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#,
    171 
    +-- which is not particularly cheap. Better to use readMVar, which can be
    172 
    +-- performed in multiple threads safely, and to use unsafeDupableInterleaveIO
    173 
    +-- to avoid the noDuplicate cost.
    174 
    +--
    175 
    +-- What we'd ideally want is probably an IVar, but we don't quite have those.
    176 
    +-- STM TVars look like an option at first, but I don't think they are:
    177 
    +-- we'd need to be able to write to the variable in an IO context, which can
    178 
    +-- only be done using 'atomically', and 'atomically' is not allowed within
    179 
    +-- unsafePerformIO. We can't know if someone will try to use the result
    180 
    +-- of fixIO with unsafePerformIO!
    181 
    +--
    182 
    +-- See also System.IO.Unsafe.unsafeFixIO.
    183 
    +--
    184 
    +
    101 185 
     -- | @since base-2.01
    102 186 
     instance MonadFix IO where
    103 187 
         mfix = fixIO

  • libraries/ghc-internal/src/GHC/Internal/Data/Either.hs
    ... ... @@ -34,7 +34,6 @@ module GHC.Internal.Data.Either (
    34 34
    35 35 
     import GHC.Internal.Base
    36 36 
     import GHC.Internal.Show
    37 
    -import GHC.Internal.Read
    38 37
    39 38 
     -- $setup
    40 39 
     -- Allow the use of some Prelude functions in doctests.
    ... ... @@ -127,7 +126,6 @@ Left "parse error"
    127 126 
     data  Either a b  =  Left a | Right b
    128 127 
       deriving ( Eq   -- ^ @since base-2.01
    129 128 
                , Ord  -- ^ @since base-2.01
    130 
    -           , Read -- ^ @since base-3.0
    131 129 
                , Show -- ^ @since base-3.0
    132 130 
                )
    133 131

  • libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs
    ... ... @@ -24,7 +24,6 @@ module GHC.Internal.Data.Proxy
    24 24
    25 25 
     import GHC.Internal.Base
    26 26 
     import GHC.Internal.Show
    27 
    -import GHC.Internal.Read
    28 27 
     import GHC.Internal.Enum
    29 28 
     import GHC.Internal.Arr
    30 29
    ... ... @@ -54,7 +53,6 @@ import GHC.Internal.Arr
    54 53 
     -- >>> Proxy :: Proxy complicatedStructure
    55 54 
     -- Proxy
    56 55 
     data Proxy t = Proxy deriving ( Bounded -- ^ @since base-4.7.0.0
    57 
    -                              , Read    -- ^ @since base-4.7.0.0
    58 56 
                                   )
    59 57
    60 58 
     -- | A concrete, promotable proxy type, for use at the kind level.

  • libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs
    ... ... @@ -36,7 +36,6 @@ import qualified GHC.Internal.Data.Type.Equality as Eq
    36 36 
     import GHC.Internal.Data.Maybe
    37 37 
     import GHC.Internal.Enum
    38 38 
     import GHC.Internal.Show
    39 
    -import GHC.Internal.Read
    40 39 
     import GHC.Internal.Base
    41 40
    42 41 
     -- | Representational equality. If @Coercion a b@ is inhabited by some terminating
    ... ... @@ -84,9 +83,6 @@ deriving instance Show (Coercion a b)
    84 83 
     -- | @since base-4.7.0.0
    85 84 
     deriving instance Ord  (Coercion a b)
    86 85
    87 
    --- | @since base-4.7.0.0
    88 
    -deriving instance Coercible a b => Read (Coercion a b)
    89 
    -
    90 86 
     -- | @since base-4.7.0.0
    91 87 
     instance Coercible a b => Enum (Coercion a b) where
    92 88 
       toEnum 0 = Coercion

  • libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs
    ... ... @@ -49,7 +49,6 @@ module GHC.Internal.Data.Type.Equality (
    49 49 
     import GHC.Internal.Data.Maybe
    50 50 
     import GHC.Internal.Enum
    51 51 
     import GHC.Internal.Show
    52 
    -import GHC.Internal.Read
    53 52 
     import GHC.Internal.Base
    54 53 
     import GHC.Internal.Data.Type.Bool
    55 54
    ... ... @@ -105,9 +104,6 @@ deriving instance Show (a :~: b)
    105 104 
     -- | @since base-4.7.0.0
    106 105 
     deriving instance Ord  (a :~: b)
    107 106
    108 
    --- | @since base-4.7.0.0
    109 
    -deriving instance a ~ b => Read (a :~: b)
    110 
    -
    111 107 
     -- | @since base-4.7.0.0
    112 108 
     instance a ~ b => Enum (a :~: b) where
    113 109 
       toEnum 0 = Refl
    ... ... @@ -133,9 +129,6 @@ deriving instance Show (a :~~: b)
    133 129 
     -- | @since base-4.10.0.0
    134 130 
     deriving instance Ord  (a :~~: b)
    135 131
    136 
    --- | @since base-4.10.0.0
    137 
    -deriving instance a ~~ b => Read (a :~~: b)
    138 
    -
    139 132 
     -- | @since base-4.10.0.0
    140 133 
     instance a ~~ b => Enum (a :~~: b) where
    141 134 
       toEnum 0 = HRefl

  • libraries/ghc-internal/src/GHC/Internal/Event/Control.hs
    ... ... @@ -8,8 +8,7 @@
    8 8 
     module GHC.Internal.Event.Control
    9 9 
         (
    10 10 
         -- * Managing the IO manager
    11 
    -      Signal
    12 
    -    , ControlMessage(..)
    11 
    +      ControlMessage(..)
    13 12 
         , Control
    14 13 
         , newControl
    15 14 
         , closeControl
    ... ... @@ -31,7 +30,6 @@ module GHC.Internal.Event.Control
    31 30
    32 31 
     import GHC.Internal.Base
    33 32 
     import GHC.Internal.IORef
    34 
    -import GHC.Internal.Conc.Signal (Signal)
    35 33 
     import GHC.Internal.Real (fromIntegral)
    36 34 
     import GHC.Internal.Show (Show)
    37 35 
     import GHC.Internal.Word (Word8)
    ... ... @@ -56,7 +54,7 @@ import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF)
    56 54 
     data ControlMessage = CMsgWakeup
    57 55 
                         | CMsgDie
    58 56 
                         | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
    59 
    -                                 {-# UNPACK #-} !Signal
    57 
    +                                 {-# UNPACK #-} !CInt -- type Signal = CInt
    60 58 
         deriving ( Eq   -- ^ @since base-4.4.0.0
    61 59 
                  , Show -- ^ @since base-4.4.0.0
    62 60 
                  )

  • libraries/ghc-internal/src/GHC/Internal/IO/Device.hs
    ... ... @@ -35,7 +35,7 @@ import GHC.Internal.Read
    35 35 
     import GHC.Internal.Show
    36 36 
     import GHC.Internal.Ptr
    37 37 
     import GHC.Internal.Num
    38 
    -import GHC.Internal.IO
    38 
    +import GHC.Internal.IO (throwIO)
    39 39 
     import {-# SOURCE #-} GHC.Internal.IO.Exception ( unsupportedOperation )
    40 40
    41 41 
     -- | A low-level I/O provider where the data is bytes in memory.

  • libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
    ... ... @@ -45,7 +45,7 @@ import GHC.Internal.IO.Buffer
    45 45 
     import GHC.Internal.IO.BufferedIO
    46 46 
     import qualified GHC.Internal.IO.Device
    47 47 
     import GHC.Internal.IO.Device (SeekMode(..), IODeviceType(..))
    48 
    -import GHC.Internal.Conc.IO
    48 
    +import GHC.Internal.Event.Thread
    49 49 
     import GHC.Internal.IO.Exception
    50 50 
     #if defined(mingw32_HOST_OS)
    51 51 
     import GHC.Internal.Windows

  • libraries/ghc-internal/src/GHC/Internal/Read.hs
    1 1 
     {-# LANGUAGE Trustworthy #-}
    2 
    -{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-}
    2 
    +{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables, TypeOperators #-}
    3 3 
     {-# OPTIONS_HADDOCK not-home #-}
    4 4
    5 5 
     -----------------------------------------------------------------------------
    ... ... @@ -74,6 +74,10 @@ import GHC.Internal.Arr
    74 74 
     import GHC.Internal.Word
    75 75 
     import GHC.Internal.List (filter)
    76 76 
     import GHC.Internal.Tuple (Solo (..))
    77 
    +import GHC.Internal.Data.Type.Equality
    78 
    +import GHC.Internal.Data.Type.Coercion
    79 
    +import GHC.Internal.Data.Either
    80 
    +import GHC.Internal.Data.Proxy
    77 81
    78 82
    79 83 
     -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with
    ... ... @@ -833,3 +837,20 @@ instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
    833 837 
                               ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
    834 838 
       readListPrec = readListPrecDefault
    835 839 
       readList     = readListDefault
    840 
    +
    841 
    +
    842 
    +-- | @since base-4.7.0.0
    843 
    +deriving instance a ~ b => Read (a :~: b)
    844 
    +
    845 
    +-- | @since base-4.10.0.0
    846 
    +deriving instance a ~~ b => Read (a :~~: b)
    847 
    +
    848 
    +-- | @since base-4.7.0.0
    849 
    +deriving instance Coercible a b => Read (Coercion a b)
    850 
    +
    851 
    +
    852 
    +-- | @since base-3.0
    853 
    +deriving instance (Read a, Read b) => Read (Either a b)
    854 
    +
    855 
    +-- | @since base-4.7.0.0
    856 
    +deriving instance Read (Proxy s)

  • libraries/ghc-internal/src/GHC/Internal/System/IO.hs
    ... ... @@ -20,7 +20,6 @@ module GHC.Internal.System.IO (
    20 20 
         -- * The IO monad
    21 21
    22 22 
         IO,
    23 
    -    fixIO,
    24 23
    25 24 
         -- * Files and handles
    26 25
    ... ... @@ -258,7 +257,6 @@ import GHC.Internal.IO.Encoding
    258 257 
     import GHC.Internal.Text.Read
    259 258 
     import GHC.Internal.IO.StdHandles
    260 259 
     import GHC.Internal.Show
    261 
    -import GHC.Internal.MVar
    262 260 
     -----------------------------------------------------------------------------
    263 261 
     -- Standard IO
    264 262
    ... ... @@ -602,87 +600,6 @@ hReady h = hWaitForInput h 0
    602 600 
     hPrint          :: Show a => Handle -> a -> IO ()
    603 601 
     hPrint hdl      =  hPutStrLn hdl . show
    604 602
    605 
    -
    606 
    --- ---------------------------------------------------------------------------
    607 
    --- fixIO
    608 
    -
    609 
    --- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'.
    610 
    ---
    611 
    --- This operation may fail with:
    612 
    ---
    613 
    --- * 'FixIOException' if the function passed to 'fixIO' inspects its argument.
    614 
    ---
    615 
    --- ==== __Examples__
    616 
    ---
    617 
    --- the IO-action is only executed once. The recursion is only on the values.
    618 
    ---
    619 
    --- >>> take 3 <$> fixIO (\x -> putStr ":D" >> (:x) <$> readLn @Int)
    620 
    --- :D
    621 
    --- 2
    622 
    --- [2,2,2]
    623 
    ---
    624 
    --- If we are strict in the value, just as with 'Data.Function.fix', we do not get termination:
    625 
    ---
    626 
    --- >>> fixIO (\x -> putStr x >> pure ('x' : x))
    627 
    --- * hangs forever *
    628 
    ---
    629 
    --- We can tie the knot of a structure within 'IO' using 'fixIO':
    630 
    ---
    631 
    --- @
    632 
    --- data Node = MkNode Int (IORef Node)
    633 
    ---
    634 
    --- foo :: IO ()
    635 
    --- foo = do
    636 
    ---   p \<- fixIO (\p -> newIORef (MkNode 0 p))
    637 
    ---   q <- output p
    638 
    ---   r <- output q
    639 
    ---   _ <- output r
    640 
    ---   pure ()
    641 
    ---
    642 
    --- output :: IORef Node -> IO (IORef Node)
    643 
    --- output ref = do
    644 
    ---   MkNode x p <- readIORef ref
    645 
    ---   print x
    646 
    ---   pure p
    647 
    --- @
    648 
    ---
    649 
    --- >>> foo
    650 
    --- 0
    651 
    --- 0
    652 
    --- 0
    653 
    -fixIO :: (a -> IO a) -> IO a
    654 
    -fixIO k = do
    655 
    -    m <- newEmptyMVar
    656 
    -    ans <- unsafeDupableInterleaveIO
    657 
    -             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
    658 
    -                                    throwIO FixIOException)
    659 
    -    result <- k ans
    660 
    -    putMVar m result
    661 
    -    return result
    662 
    -
    663 
    --- Note [Blackholing in fixIO]
    664 
    --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    665 
    --- We do our own explicit black holing here, because GHC's lazy
    666 
    --- blackholing isn't enough.  In an infinite loop, GHC may run the IO
    667 
    --- computation a few times before it notices the loop, which is wrong.
    668 
    ---
    669 
    --- NOTE2: the explicit black-holing with an IORef ran into trouble
    670 
    --- with multiple threads (see #5421), so now we use an MVar. We used
    671 
    --- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#,
    672 
    --- which is not particularly cheap. Better to use readMVar, which can be
    673 
    --- performed in multiple threads safely, and to use unsafeDupableInterleaveIO
    674 
    --- to avoid the noDuplicate cost.
    675 
    ---
    676 
    --- What we'd ideally want is probably an IVar, but we don't quite have those.
    677 
    --- STM TVars look like an option at first, but I don't think they are:
    678 
    --- we'd need to be able to write to the variable in an IO context, which can
    679 
    --- only be done using 'atomically', and 'atomically' is not allowed within
    680 
    --- unsafePerformIO. We can't know if someone will try to use the result
    681 
    --- of fixIO with unsafePerformIO!
    682 
    ---
    683 
    --- See also System.IO.Unsafe.unsafeFixIO.
    684 
    ---
    685 
    -
    686 603 
     -- | The function creates a temporary file in ReadWrite mode.
    687 604 
     -- The created file isn\'t deleted automatically, so you need to delete it manually.
    688 605 
     --

  • libraries/ghc-internal/src/GHC/Internal/TopHandler.hs
    ... ... @@ -37,6 +37,7 @@ module GHC.Internal.TopHandler (
    37 37 
     #include "HsBaseConfig.h"
    38 38
    39 39 
     import GHC.Internal.Control.Exception
    40 
    +import GHC.Internal.Conc.Sync (throwTo)
    40 41 
     import GHC.Internal.Data.Maybe
    41 42
    42 43 
     import GHC.Internal.Foreign.C.Error

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help