diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -37,7 +37,7 @@ -- than 'GHC.Conc.STM'. They are appropriate for building synchronization -- primitives and performing simple interthread communication; however -- they are very simple and susceptible to race conditions, deadlocks or --- uncaught exceptions. Do not use them if you need perform larger +-- uncaught exceptions. Do not use them if you need to perform larger -- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM' -- instead. -- diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -223,7 +223,7 @@ -- handle. Similarly, closing a socket (from \"network\" package) is also -- uninterruptible under similar conditions. An example of an interruptible -- action is 'killThread'. Completion of interruptible release actions can be --- ensured by wrapping them in in 'uninterruptibleMask_', but this risks making +-- ensured by wrapping them in 'uninterruptibleMask_', but this risks making -- the program non-responsive to @Control-C@, or timeouts. Another option is to -- run the release action asynchronously in its own thread: -- diff --git a/Control/Monad.hs b/Control/Monad.hs --- a/Control/Monad.hs +++ b/Control/Monad.hs @@ -101,11 +101,11 @@ -- -- ==== __Examples__ -- --- Common uses of 'guard' include conditionally signaling an error in +-- Common uses of 'guard' include conditionally signalling an error in -- an error monad and conditionally rejecting the current choice in an -- 'Alternative'-based parser. -- --- As an example of signaling an error in the error monad 'Maybe', +-- As an example of signalling an error in the error monad 'Maybe', -- consider a safe division function @safeDiv x y@ that returns -- 'Nothing' when the denominator @y@ is zero and @'Just' (x \`div\` -- y)@ otherwise. For example: diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs --- a/Control/Monad/Fix.hs +++ b/Control/Monad/Fix.hs @@ -2,6 +2,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-} +-- For head in instance MonadFix [] +{-# OPTIONS_GHC -Wno-x-partial #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Fix @@ -32,7 +35,7 @@ import Data.Ord ( Down(..) ) import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) ) import GHC.Generics -import GHC.List ( head, tail ) +import GHC.List ( head, drop ) import GHC.Tuple (Solo (..)) import Control.Monad.ST.Imp import System.IO @@ -79,7 +82,7 @@ instance MonadFix [] where mfix f = case fix (f . head) of [] -> [] - (x:_) -> x : mfix (tail . f) + (x:_) -> x : mfix (drop 1 . f) -- | @since 4.9.0.0 instance MonadFix NonEmpty where diff --git a/Data/Array/Byte.hs b/Data/Array/Byte.hs --- a/Data/Array/Byte.hs +++ b/Data/Array/Byte.hs @@ -134,7 +134,7 @@ -- | Copy a slice from one mutable byte array to another -- or to the same mutable byte array. -- --- /Note:/ this function does not do bounds checking. +-- /Note:/ this function does not do bounds or overlap checking. unsafeCopyMutableByteArray :: MutableByteArray s -- ^ destination array -> Int -- ^ offset into destination array @@ -144,7 +144,7 @@ -> ST s () {-# INLINE unsafeCopyMutableByteArray #-} unsafeCopyMutableByteArray (MutableByteArray dst#) (I# doff#) (MutableByteArray src#) (I# soff#) (I# sz#) = - ST (\s# -> case copyMutableByteArray# src# soff# dst# doff# sz# s# of + ST (\s# -> case copyMutableByteArrayNonOverlapping# src# soff# dst# doff# sz# s# of s'# -> (# s'#, () #)) -- | @since 4.17.0.0 diff --git a/Data/Complex.hs b/Data/Complex.hs --- a/Data/Complex.hs +++ b/Data/Complex.hs @@ -50,41 +50,17 @@ -- ----------------------------------------------------------------------------- -- The Complex type --- | A data type representing complex numbers. --- --- You can read about complex numbers [on wikipedia](https://en.wikipedia.org/wiki/Complex_number). +-- | Complex numbers are an algebraic type. -- --- In haskell, complex numbers are represented as @a :+ b@ which can be thought of --- as representing \(a + bi\). For a complex number @z@, @'abs' z@ is a number with the 'magnitude' of @z@, +-- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@, -- but oriented in the positive real direction, whereas @'signum' z@ --- has the 'phase' of @z@, but unit 'magnitude'. --- Apart from the loss of precision due to IEEE754 floating point numbers, --- it holds that @z == 'abs' z * 'signum' z@. +-- has the phase of @z@, but unit magnitude. -- +-- The 'Foldable' and 'Traversable' instances traverse the real part first. +-- -- Note that `Complex`'s instances inherit the deficiencies from the type -- parameter's. For example, @Complex Float@'s 'Ord' instance has similar -- problems to `Float`'s. --- --- As can be seen in the examples, the 'Foldable' --- and 'Traversable' instances traverse the real part first. --- --- ==== __Examples__ --- --- >>> (5.0 :+ 2.5) + 6.5 --- 11.5 :+ 2.5 --- --- >>> abs (1.0 :+ 1.0) - sqrt 2.0 --- 0.0 :+ 0.0 --- --- >>> abs (signum (4.0 :+ 3.0)) --- 1.0 :+ 0.0 --- --- >>> foldr (:) [] (1 :+ 2) --- [1,2] --- --- >>> mapM print (1 :+ 2) --- 1 --- 2 data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. @@ -103,113 +79,38 @@ -- Functions over Complex -- | Extracts the real part of a complex number. --- --- ==== __Examples__ --- --- >>> realPart (5.0 :+ 3.0) --- 5.0 --- --- >>> realPart ((5.0 :+ 3.0) * (2.0 :+ 3.0)) --- 1.0 realPart :: Complex a -> a realPart (x :+ _) = x -- | Extracts the imaginary part of a complex number. --- --- ==== __Examples__ --- --- >>> imagPart (5.0 :+ 3.0) --- 3.0 --- --- >>> imagPart ((5.0 :+ 3.0) * (2.0 :+ 3.0)) --- 21.0 imagPart :: Complex a -> a imagPart (_ :+ y) = y --- | The 'conjugate' of a complex number. --- --- prop> conjugate (conjugate x) = x --- --- ==== __Examples__ --- --- >>> conjugate (3.0 :+ 3.0) --- 3.0 :+ (-3.0) --- --- >>> conjugate ((3.0 :+ 3.0) * (2.0 :+ 2.0)) --- 0.0 :+ (-12.0) +-- | The conjugate of a complex number. {-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} conjugate :: Num a => Complex a -> Complex a conjugate (x:+y) = x :+ (-y) --- | Form a complex number from 'polar' components of 'magnitude' and 'phase'. --- --- ==== __Examples__ --- --- >>> mkPolar 1 (pi / 4) --- 0.7071067811865476 :+ 0.7071067811865475 --- --- >>> mkPolar 1 0 --- 1.0 :+ 0.0 +-- | Form a complex number from polar components of magnitude and phase. {-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} mkPolar :: Floating a => a -> a -> Complex a mkPolar r theta = r * cos theta :+ r * sin theta --- | @'cis' t@ is a complex value with 'magnitude' @1@ --- and 'phase' @t@ (modulo @2*'pi'@). --- --- @ --- 'cis' = 'mkPolar' 1 --- @ --- --- ==== __Examples__ --- --- >>> cis 0 --- 1.0 :+ 0.0 --- --- The following examples are not perfectly zero due to [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754) --- --- >>> cis pi --- (-1.0) :+ 1.2246467991473532e-16 --- --- >>> cis (4 * pi) - cis (2 * pi) --- 0.0 :+ (-2.4492935982947064e-16) +-- | @'cis' t@ is a complex value with magnitude @1@ +-- and phase @t@ (modulo @2*'pi'@). {-# SPECIALISE cis :: Double -> Complex Double #-} cis :: Floating a => a -> Complex a cis theta = cos theta :+ sin theta -- | The function 'polar' takes a complex number and --- returns a ('magnitude', 'phase') pair in canonical form: --- the 'magnitude' is non-negative, and the 'phase' in the range @(-'pi', 'pi']@; --- if the 'magnitude' is zero, then so is the 'phase'. --- --- @'polar' z = ('magnitude' z, 'phase' z)@ --- --- ==== __Examples__ --- --- >>> polar (1.0 :+ 1.0) --- (1.4142135623730951,0.7853981633974483) --- --- >>> polar ((-1.0) :+ 0.0) --- (1.0,3.141592653589793) --- --- >>> polar (0.0 :+ 0.0) --- (0.0,0.0) +-- returns a (magnitude, phase) pair in canonical form: +-- the magnitude is non-negative, and the phase in the range @(-'pi', 'pi']@; +-- if the magnitude is zero, then so is the phase. {-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} polar :: (RealFloat a) => Complex a -> (a,a) polar z = (magnitude z, phase z) --- | The non-negative 'magnitude' of a complex number. --- --- ==== __Examples__ --- --- >>> magnitude (1.0 :+ 1.0) --- 1.4142135623730951 --- --- >>> magnitude (1.0 + 0.0) --- 1.0 --- --- >>> magnitude (0.0 :+ (-5.0)) --- 5.0 +-- | The non-negative magnitude of a complex number. {-# SPECIALISE magnitude :: Complex Double -> Double #-} magnitude :: (RealFloat a) => Complex a -> a magnitude (x:+y) = scaleFloat k @@ -218,16 +119,8 @@ mk = - k sqr z = z * z --- | The 'phase' of a complex number, in the range @(-'pi', 'pi']@. --- If the 'magnitude' is zero, then so is the 'phase'. --- --- ==== __Examples__ --- --- >>> phase (0.5 :+ 0.5) / pi --- 0.25 --- --- >>> phase (0 :+ 4) / pi --- 0.5 +-- | The phase of a complex number, in the range @(-'pi', 'pi']@. +-- If the magnitude is zero, then so is the phase. {-# SPECIALISE phase :: Complex Double -> Double #-} phase :: (RealFloat a) => Complex a -> a phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson diff --git a/Data/Data.hs b/Data/Data.hs --- a/Data/Data.hs +++ b/Data/Data.hs @@ -631,8 +631,6 @@ } -- | Constructs a constructor --- --- @since 4.16.0.0 mkConstrTag :: DataType -> String -> Int -> [String] -> Fixity -> Constr mkConstrTag dt str idx fields fix = Constr @@ -706,10 +704,9 @@ -- Traverse list of algebraic datatype constructors idx :: [Constr] -> Maybe Constr - idx cons = let fit = filter ((==) str . showConstr) cons - in if fit == [] - then Nothing - else Just (head fit) + idx cons = case filter ((==) str . showConstr) cons of + [] -> Nothing + hd : _ -> Just hd ffloat :: Double -> Constr ffloat = mkPrimCon dt str . FloatConstr . toRational @@ -852,17 +849,17 @@ -- drop *.*.*... before name -- tyconUQname :: String -> String -tyconUQname x = let x' = dropWhile (not . (==) '.') x - in if x' == [] then x else tyconUQname (tail x') +tyconUQname x = case dropWhile (not . (==) '.') x of + [] -> x + _ : tl -> tyconUQname tl -- | Gets the module of a type constructor: -- take *.*.*... before name tyconModule :: String -> String -tyconModule x = let (a,b) = break ((==) '.') x - in if b == "" - then b - else a ++ tyconModule' (tail b) +tyconModule x = case break ((==) '.') x of + (_, "") -> "" + (a, _ : tl) -> a ++ tyconModule' tl where tyconModule' y = let y' = tyconModule y in if y' == "" then "" else ('.':y') @@ -1139,7 +1136,10 @@ listDataType :: DataType listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] --- | @since 4.0.0.0 +-- | For historical reasons, the constructor name used for @(:)@ is +-- @"(:)"@. In a derived instance, it would be @":"@. +-- +-- @since 4.0.0.0 instance Data a => Data [a] where gfoldl _ z [] = z [] gfoldl f z (x:xs) = z (:) `f` x `f` xs diff --git a/Data/Fixed.hs b/Data/Fixed.hs --- a/Data/Fixed.hs +++ b/Data/Fixed.hs @@ -21,6 +21,13 @@ -- This module also contains generalisations of 'div', 'mod', and 'divMod' to -- work with any 'Real' instance. -- +-- Automatic conversion between different 'Fixed' can be performed through +-- 'realToFrac', bear in mind that converting to a fixed with a smaller +-- resolution will truncate the number, losing information. +-- +-- >>> realToFrac (0.123456 :: Pico) :: Milli +-- 0.123 +-- ----------------------------------------------------------------------------- module Data.Fixed @@ -163,6 +170,13 @@ enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c) -- | @since 2.01 +-- +-- Multiplication is not associative or distributive: +-- +-- >>> (0.2 * 0.6 :: Deci) * 0.9 == 0.2 * (0.6 * 0.9) +-- False +-- >>> (0.1 + 0.1 :: Deci) * 0.5 == 0.1 * 0.5 + 0.1 * 0.5 +-- False instance (HasResolution a) => Num (Fixed a) where (MkFixed a) + (MkFixed b) = MkFixed (a + b) (MkFixed a) - (MkFixed b) = MkFixed (a - b) diff --git a/Data/Foldable.hs b/Data/Foldable.hs --- a/Data/Foldable.hs +++ b/Data/Foldable.hs @@ -1363,7 +1363,9 @@ Just x -> case cmp x y of GT -> x _ -> y -{-# INLINEABLE maximumBy #-} +-- #22609 showed that maximumBy is too large to reliably inline, +-- See Note [maximumBy/minimumBy INLINE pragma] +{-# INLINE[2] maximumBy #-} -- | The least element of a non-empty structure with respect to the -- given comparison function. @@ -1378,6 +1380,7 @@ -- WARNING: This function is partial for possibly-empty structures like lists. -- See Note [maximumBy/minimumBy space usage] +-- See Note [maximumBy/minimumBy INLINE pragma] minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a minimumBy cmp = fromMaybe (errorWithoutStackTrace "minimumBy: empty structure") . foldl' min' Nothing @@ -1387,8 +1390,10 @@ Just x -> case cmp x y of GT -> y _ -> x -{-# INLINEABLE minimumBy #-} +-- See Note [maximumBy/minimumBy INLINE pragma] +{-# INLINE[2] minimumBy #-} + -- | 'notElem' is the negation of 'elem'. -- -- ==== __Examples__ @@ -1525,6 +1530,31 @@ make these functions only use O(1) stack space. As of base 4.16, we have switched to employing foldl' over foldl1, not relying on GHC's optimiser. See https://gitlab.haskell.org/ghc/ghc/-/issues/17867 for more context. + +Note [maximumBy/minimumBy INLINE pragma] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently maximumBy/minimumBy wrap the accumulator into Maybe to deal with the +empty case. Commonly one would just pass in a bottom default value alas this is +not easily done here if we want to remain strict in the accumulator. +See #17867 for why we want to be strict in the accumulator here. + +For optimal code we want the Maybe to optimize away and the accumulator to be +unpacked if possible. For this to happen we need: +* SpecConstr to eliminate the Maybe +* W/W to unpack the accumulator +This only happens if we compile the RHS with -O2 at a specific type. +There are two ways to achieve this: Using a SPECIALIZE pragma inside base for a +blessed set of types since we know base will be compiled using -O2. +Or using INLINE and counting at call sites to be compiled with -O2. + + +We've chosen to use INLINE as this guarantees optimal code at -O2 no matter what +element type is used. However this comes at the cost of less optimal code when +the call site is using -O as SpecConstr won't fire, preventing W/W from firing +as well. See #22609 and the discussion in !9565. +Sadly we can't use both SPECIALIZE and INLINE. This would result in the RHS being +inlined before the specialization rule fires. Giving the same result as if we had +only used INLINE. -} {- diff --git a/Data/Foldable1.hs b/Data/Foldable1.hs --- a/Data/Foldable1.hs +++ b/Data/Foldable1.hs @@ -86,22 +86,30 @@ -- foldMap f = foldMap f . toNonEmpty -- foldrMap1 f g = foldrMap1 f g . toNonEmpty - -- | Combine the elements of a structure using a semigroup. + -- | Given a structure with elements whose type is a 'Semigroup', combine + -- them via the semigroup's @('<>')@ operator. This fold is + -- right-associative and lazy in the accumulator. When you need a strict + -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map. + -- -- @since 4.18.0.0 fold1 :: Semigroup m => t m -> m fold1 = foldMap1 id - -- | Map each element of the structure to a semigroup, - -- and combine the results. + -- | Map each element of the structure to a semigroup, and combine the + -- results with @('<>')@. This fold is right-associative and lazy in the + -- accumulator. For strict left-associative folds consider 'foldMap1'' + -- instead. -- - -- >>> foldMap1 Sum (1 :| [2, 3, 4]) - -- Sum {getSum = 10} + -- >>> foldMap1 (:[]) (1 :| [2, 3, 4]) + -- [1,2,3,4] -- -- @since 4.18.0.0 foldMap1 :: Semigroup m => (a -> m) -> t a -> m foldMap1 f = foldrMap1 f (\a m -> f a <> m) - -- | A variant of 'foldMap1' that is strict in the accumulator. + -- | A left-associative variant of 'foldMap1' that is strict in the + -- accumulator. Use this for strict reduction when partial results are + -- merged via @('<>')@. -- -- >>> foldMap1' Sum (1 :| [2, 3, 4]) -- Sum {getSum = 10} @@ -110,7 +118,7 @@ foldMap1' :: Semigroup m => (a -> m) -> t a -> m foldMap1' f = foldlMap1' f (\m a -> m <> f a) - -- | List of elements of a structure, from left to right. + -- | 'NonEmpty' list of elements of a structure, from left to right. -- -- >>> toNonEmpty (Identity 2) -- 2 :| [] @@ -155,7 +163,24 @@ last :: t a -> a last = getLast #. foldMap1 Last - -- | Generalized 'foldr1'. + -- | Right-associative fold of a structure, lazy in the accumulator. + -- + -- In case of 'NonEmpty' lists, 'foldrMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from right to + -- left applying @f@ to the rightmost element: + -- + -- > foldrMap1 f g (x1 :| [x2, ..., xn1, xn]) == x1 `g` (x2 `g` ... (xn1 `g` (f xn))...) + -- + -- Note that since the head of the resulting expression is produced by + -- an application of @g@ to the first element of the list, if @g@ is lazy + -- in its right argument, 'foldrMap1' can produce a terminating expression + -- from an unbounded list. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@ + -- -- @since 4.18.0.0 foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b foldrMap1 f g xs = @@ -164,7 +189,19 @@ h a Nothing = f a h a (Just b) = g a b - -- | Generalized 'foldl1''. + -- | Left-associative fold of a structure but with strict application of the + -- operator. + -- + -- This ensures that each step of the fold is forced to Weak Head Normal + -- Form before being applied, avoiding the collection of thunks that would + -- otherwise occur. This is often what you want to strictly reduce a + -- finite structure to a single strict result. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@ + -- -- @since 4.18.0.0 foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b foldlMap1' f g xs = @@ -178,7 +215,33 @@ g' a x SNothing = x $! SJust (f a) g' a x (SJust b) = x $! SJust (g b a) - -- | Generalized 'foldl1'. + -- | Left-associative fold of a structure, lazy in the accumulator. This is + -- rarely what you want, but can work well for structures with efficient + -- right-to-left sequencing and an operator that is lazy in its left + -- argument. + -- + -- In case of 'NonEmpty' lists, 'foldlMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from left to + -- right applying @f@ to the leftmost element: + -- + -- > foldlMap1 f g (x1 :| [x2, ..., xn]) == (...(((f x1) `g` x2) `g`...) `g` xn + -- + -- Note that to produce the outermost application of the operator the entire + -- input list must be traversed. This means that 'foldlMap1' will diverge if + -- given an infinite list. + -- + -- If you want an efficient strict left-fold, you probably want to use + -- 'foldlMap1'' instead of 'foldlMap1'. The reason for this is that the + -- latter does not force the /inner/ results (e.g. @(f x1) \`g\` x2@ in the + -- above example) before applying them to the operator (e.g. to + -- @(\`g\` x3)@). This results in a thunk chain \(O(n)\) elements long, + -- which then must be evaluated from the outside-in. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@ + -- -- @since 4.18.0.0 foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b foldlMap1 f g xs = @@ -187,7 +250,21 @@ h a Nothing = f a h a (Just b) = g b a - -- | Generalized 'foldr1''. + -- | 'foldrMap1'' is a variant of 'foldrMap1' that performs strict reduction + -- from right to left, i.e. starting with the right-most element. The input + -- structure /must/ be finite, otherwise 'foldrMap1'' runs out of space + -- (/diverges/). + -- + -- If you want a strict right fold in constant space, you need a structure + -- that supports faster than \(O(n)\) access to the right-most element. + -- + -- This method does not run in constant space for structures such as + -- 'NonEmpty' lists that don't support efficient right-to-left iteration and + -- so require \(O(n)\) space to perform right-to-left reduction. Use of this + -- method with such a structure is a hint that the chosen structure may be a + -- poor fit for the task at hand. If the order in which the elements are + -- combined is not important, use 'foldlMap1'' instead. + -- -- @since 4.18.0.0 foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b foldrMap1' f g xs = @@ -203,77 +280,28 @@ -- Combinators ------------------------------------------------------------------------------- --- | Right-associative fold of a structure. --- --- In the case of lists, 'foldr1', when applied to a binary operator, --- and a list, reduces the list using the binary operator, --- from right to left: --- --- > foldr1 f [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn1 `f` xn )...) --- --- Note that, since the head of the resulting expression is produced by --- an application of the operator to the first element of the list, --- 'foldr1' can produce a terminating expression from an infinite list. --- --- For a general 'Foldable1' structure this should be semantically identical --- to, --- --- @foldr1 f = foldr1 f . 'toNonEmpty'@ +-- | A variant of 'foldrMap1' where the rightmost element maps to itself. -- -- @since 4.18.0.0 foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a foldr1 = foldrMap1 id {-# INLINE foldr1 #-} --- | Right-associative fold of a structure, but with strict application of --- the operator. +-- | A variant of 'foldrMap1'' where the rightmost element maps to itself. -- -- @since 4.18.0.0 foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a foldr1' = foldrMap1' id {-# INLINE foldr1' #-} --- | Left-associative fold of a structure. --- --- In the case of lists, 'foldl1', when applied to a binary --- operator, and a list, reduces the list using the binary operator, --- from left to right: --- --- > foldl1 f [x1, x2, ..., xn] == (...((x1 `f` x2) `f`...) `f` xn --- --- Note that to produce the outermost application of the operator the --- entire input list must be traversed. This means that 'foldl1' will --- diverge if given an infinite list. --- --- Also note that if you want an efficient left-fold, you probably want to --- use 'foldl1'' instead of 'foldl1'. The reason for this is that latter does --- not force the "inner" results (e.g. @x1 \`f\` x2@ in the above example) --- before applying them to the operator (e.g. to @(\`f\` x3)@). This results --- in a thunk chain \(\mathcal{O}(n)\) elements long, which then must be --- evaluated from the outside-in. --- --- For a general 'Foldable1' structure this should be semantically identical --- to, --- --- @foldl1 f z = foldl1 f . 'toNonEmpty'@ +-- | A variant of 'foldlMap1' where the leftmost element maps to itself. -- -- @since 4.18.0.0 foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a foldl1 = foldlMap1 id {-# INLINE foldl1 #-} --- | Left-associative fold of a structure but with strict application of --- the operator. --- --- This ensures that each step of the fold is forced to weak head normal --- form before being applied, avoiding the collection of thunks that would --- otherwise occur. This is often what you want to strictly reduce a finite --- list to a single, monolithic result (e.g. 'length'). --- --- For a general 'Foldable1' structure this should be semantically identical --- to, --- --- @foldl1' f z = foldl1 f . 'toNonEmpty'@ +-- | A variant of 'foldlMap1'' where the leftmost element maps to itself. -- -- @since 4.18.0.0 foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a diff --git a/Data/Function.hs b/Data/Function.hs --- a/Data/Function.hs +++ b/Data/Function.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} @@ -28,7 +30,7 @@ , applyWhen ) where -import GHC.Base ( ($), (.), id, const, flip ) +import GHC.Base ( TYPE, ($), (.), id, const, flip ) import Data.Bool ( Bool(..) ) infixl 0 `on` @@ -120,7 +122,7 @@ -- "6" -- -- @since 4.8.0.0 -(&) :: a -> (a -> b) -> b +(&) :: forall r a (b :: TYPE r). a -> (a -> b) -> b x & f = f x -- | 'applyWhen' applies a function to a value if a condition is true, diff --git a/Data/Functor.hs b/Data/Functor.hs --- a/Data/Functor.hs +++ b/Data/Functor.hs @@ -43,10 +43,12 @@ ($>), (<$>), (<&>), + unzip, void, ) where import GHC.Base ( Functor(..), flip ) +import Data.Tuple ( fst, snd ) -- $setup -- Allow the use of Prelude in doctests. @@ -158,6 +160,12 @@ -- ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) + +-- | Generalization of @Data.List.@'Data.List.unzip'. +-- +-- @since 4.19.0.0 +unzip :: Functor f => f (a, b) -> (f a, f b) +unzip xs = (fst <$> xs, snd <$> xs) -- | @'void' value@ discards or ignores the result of evaluation, such -- as the return value of an 'System.IO.IO' action. diff --git a/Data/Functor/Compose.hs b/Data/Functor/Compose.hs --- a/Data/Functor/Compose.hs +++ b/Data/Functor/Compose.hs @@ -31,6 +31,8 @@ import Control.Applicative import Data.Coerce (coerce) import Data.Data (Data) +import Data.Foldable (Foldable(..)) +import Data.Monoid (Sum(..), All(..), Any(..), Product(..)) import Data.Type.Equality (TestEquality(..), (:~:)(..)) import GHC.Generics (Generic, Generic1) import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault) @@ -111,8 +113,24 @@ -- | @since 4.9.0.0 instance (Foldable f, Foldable g) => Foldable (Compose f g) where + fold (Compose t) = foldMap fold t foldMap f (Compose t) = foldMap (foldMap f) t + foldMap' f (Compose t) = foldMap' (foldMap' f) t + foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga + foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga + foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga + foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga + null (Compose t) = null t || getAll (foldMap (All . null) t) + length (Compose t) = getSum (foldMap' (Sum . length) t) + elem x (Compose t) = getAny (foldMap (Any . elem x) t) + + minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga + maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga + + sum (Compose t) = getSum (foldMap' (Sum . sum) t) + product (Compose t) = getProduct (foldMap' (Product . product) t) + -- | @since 4.9.0.0 instance (Traversable f, Traversable g) => Traversable (Compose f g) where traverse f (Compose t) = Compose <$> traverse (traverse f) t @@ -138,3 +156,14 @@ case testEquality x y of -- :: Maybe (g x :~: g y) Just Refl -> Just Refl -- :: Maybe (x :~: y) Nothing -> Nothing + +-- | @since 4.19.0.0 +deriving instance Enum (f (g a)) => Enum (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Bounded (f (g a)) => Bounded (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Num (f (g a)) => Num (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Real (f (g a)) => Real (Compose f g a) +-- | @since 4.19.0.0 +deriving instance Integral (f (g a)) => Integral (Compose f g a) diff --git a/Data/IORef.hs b/Data/IORef.hs --- a/Data/IORef.hs +++ b/Data/IORef.hs @@ -85,21 +85,45 @@ -- is recommended that if you need to do anything more complicated -- then using 'Control.Concurrent.MVar.MVar' instead is a good idea. -- --- 'atomicModifyIORef' does not apply the function strictly. This is important --- to know even if all you are doing is replacing the value. For example, this --- will leak memory: +-- Conceptually, -- --- >ref <- newIORef '1' --- >forever $ atomicModifyIORef ref (\_ -> ('2', ())) +-- @ +-- atomicModifyIORef ref f = do +-- -- Begin atomic block +-- old <- 'readIORef' ref +-- let r = f old +-- new = fst r +-- 'writeIORef' ref new +-- -- End atomic block +-- case r of +-- (_new, res) -> pure res +-- @ -- --- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem. +-- The actions in the section labeled \"atomic block\" are not subject to +-- interference from other threads. In particular, it is impossible for the +-- value in the 'IORef' to change between the 'readIORef' and 'writeIORef' +-- invocations. -- --- This function imposes a memory barrier, preventing reordering; --- see "Data.IORef#memmodel" for details. +-- The user-supplied function is applied to the value stored in the 'IORef', +-- yielding a new value to store in the 'IORef' and a value to return. After +-- the new value is (lazily) stored in the 'IORef', @atomicModifyIORef@ forces +-- the result pair, but does not force either component of the result. To force +-- /both/ components, use 'atomicModifyIORef''. -- +-- Note that +-- +-- @atomicModifyIORef ref (\_ -> undefined)@ +-- +-- will raise an exception in the calling thread, but will /also/ +-- install the bottoming value in the 'IORef', where it may be read by +-- other threads. +-- +-- This function imposes a memory barrier, preventing reordering around the +-- \"atomic block\"; see "Data.IORef#memmodel" for details. +-- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef ref f = do - (_old, ~(_new, res)) <- atomicModifyIORef2 ref f + (_old, (_new, res)) <- atomicModifyIORef2 ref f pure res -- | Variant of 'writeIORef'. The prefix "atomic" relates to a fact that diff --git a/Data/List.hs b/Data/List.hs --- a/Data/List.hs +++ b/Data/List.hs @@ -25,6 +25,7 @@ , tail , init , uncons + , unsnoc , singleton , null , length @@ -124,9 +125,10 @@ , partition -- * Indexing lists - -- | These functions treat a list @xs@ as a indexed collection, + -- | These functions treat a list @xs@ as an indexed collection, -- with indices ranging from 0 to @'length' xs - 1@. + , (!?) , (!!) , elemIndex diff --git a/Data/List/NonEmpty.hs b/Data/List/NonEmpty.hs --- a/Data/List/NonEmpty.hs +++ b/Data/List/NonEmpty.hs @@ -243,7 +243,7 @@ -- * The only empty element of `inits xs` is the first one (by the definition of `inits`) -- * Therefore, if we take all but the first element of `inits xs` i.e. -- `tail (inits xs)`, we have a nonempty list of nonempty lists - fromList . Prelude.map fromList . List.tail . List.inits . Foldable.toList + fromList . Prelude.map fromList . List.drop 1 . List.inits . Foldable.toList -- | The 'tails' function takes a stream @xs@ and returns all the -- suffixes of @xs@, starting with the longest. The result is 'NonEmpty' diff --git a/Data/Monoid.hs b/Data/Monoid.hs --- a/Data/Monoid.hs +++ b/Data/Monoid.hs @@ -127,18 +127,14 @@ -- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it -- historically. -- +-- >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world")) +-- Just "hello" +-- -- Beware that @Data.Monoid.@'First' is different from -- @Data.Semigroup.@'Data.Semigroup.First'. The former returns the first non-'Nothing', -- so @Data.Monoid.First Nothing <> x = x@. The latter simply returns the first value, -- thus @Data.Semigroup.First Nothing <> x = Data.Semigroup.First Nothing@. -- --- ==== __Examples__ --- --- >>> First (Just "hello") <> First Nothing <> First (Just "world") --- First {getFirst = Just "hello"} --- --- >>> First Nothing <> mempty --- First {getFirst = Nothing} newtype First a = First { getFirst :: Maybe a } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -166,17 +162,14 @@ -- @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to -- @'Dual' ('Alt' 'Maybe' a)@ -- +-- >>> getLast (Last (Just "hello") <> Last Nothing <> Last (Just "world")) +-- Just "world" +-- +-- Beware that @Data.Monoid.@'Last' is different from -- @Data.Semigroup.@'Data.Semigroup.Last'. The former returns the last non-'Nothing', -- so @x <> Data.Monoid.Last Nothing = x@. The latter simply returns the last value, -- thus @x <> Data.Semigroup.Last Nothing = Data.Semigroup.Last Nothing@. -- --- ==== __Examples__ --- --- >>> Last (Just "hello") <> Last Nothing <> Last (Just "world") --- Last {getLast = Just "world"} --- --- >>> Last Nothing <> mempty --- Last {getLast = Nothing} newtype Last a = Last { getLast :: Maybe a } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -201,14 +194,6 @@ -- | This data type witnesses the lifting of a 'Monoid' into an -- 'Applicative' pointwise. --- --- ==== __Examples__ --- --- >>> Ap (Just [1, 2, 3]) <> Ap Nothing --- Ap {getAp = Nothing} --- --- >>> Ap [Sum 10, Sum 20] <> Ap [Sum 1, Sum 2] --- Ap {getAp = [Sum {getSum = 11},Sum {getSum = 12},Sum {getSum = 21},Sum {getSum = 22}]} -- -- @since 4.12.0.0 newtype Ap f a = Ap { getAp :: f a } diff --git a/Data/OldList.hs b/Data/OldList.hs --- a/Data/OldList.hs +++ b/Data/OldList.hs @@ -26,6 +26,7 @@ , tail , init , uncons + , unsnoc , singleton , null , length @@ -124,9 +125,10 @@ , partition -- * Indexing lists - -- | These functions treat a list @xs@ as a indexed collection, + -- | These functions treat a list @xs@ as an indexed collection, -- with indices ranging from 0 to @'length' xs - 1@. + , (!?) , (!!) , elemIndex @@ -232,12 +234,26 @@ -- -- >>> dropWhileEnd isSpace "foo\n" -- "foo" --- -- >>> dropWhileEnd isSpace "foo bar" -- "foo bar" --- -- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined -- +-- This function is lazy in spine, but strict in elements, +-- which makes it different from 'reverse' '.' 'dropWhile' @p@ '.' 'reverse', +-- which is strict in spine, but lazy in elements. For instance: +-- +-- >>> take 1 (dropWhileEnd (< 0) (1 : undefined)) +-- [1] +-- >>> take 1 (reverse $ dropWhile (< 0) $ reverse (1 : undefined)) +-- *** Exception: Prelude.undefined +-- +-- but on the other hand +-- +-- >>> last (dropWhileEnd (< 0) [undefined, 1]) +-- *** Exception: Prelude.undefined +-- >>> last (reverse $ dropWhile (< 0) $ reverse [undefined, 1]) +-- 1 +-- -- @since 4.5.0.0 dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] @@ -343,6 +359,11 @@ -- >>> [0..] `isPrefixOf` [0..] -- * Hangs forever * -- +-- 'isPrefixOf' shortcuts when the first argument is empty: +-- +-- >>> isPrefixOf [] undefined +-- True +-- isPrefixOf :: (Eq a) => [a] -> [a] -> Bool isPrefixOf [] _ = True isPrefixOf _ [] = False @@ -428,10 +449,16 @@ -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) @@ -599,6 +626,14 @@ -- -- >>> intersperse ',' "abcde" -- "a,b,c,d,e" +-- +-- 'intersperse' has the following laziness properties: +-- +-- >>> take 1 (intersperse undefined ('a' : undefined)) +-- "a" +-- >>> take 2 (intersperse ',' ('a' : undefined)) +-- "a*** Exception: Prelude.undefined +-- intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse sep (x:xs) = x : prependToAll sep xs @@ -618,6 +653,14 @@ -- -- >>> intercalate ", " ["Lorem", "ipsum", "dolor"] -- "Lorem, ipsum, dolor" +-- +-- 'intercalate' has the following laziness properties: +-- +-- >>> take 5 (intercalate undefined ("Lorem" : undefined)) +-- "Lorem" +-- >>> take 6 (intercalate ", " ("Lorem" : undefined)) +-- "Lorem*** Exception: Prelude.undefined +-- intercalate :: [a] -> [[a]] -> [a] intercalate xs xss = concat (intersperse xs xss) @@ -637,6 +680,11 @@ -- >>> transpose (repeat []) -- * Hangs forever * -- +-- 'transpose' is lazy: +-- +-- >>> take 1 (transpose ['a' : undefined, 'b' : undefined]) +-- ["ab"] +-- transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss @@ -707,6 +755,12 @@ -- 'foldl'; it applies a function to each element of a list, passing -- an accumulating parameter from left to right, and returning a final -- value of this accumulator together with the new list. +-- +-- 'mapAccumL' does not force accumulator if it is unused: +-- +-- >>> take 1 (snd (mapAccumL (\_ x -> (undefined, x)) undefined ('a' : undefined))) +-- "a" +-- mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list -- and accumulator, returning new -- accumulator and elt of result list @@ -1233,6 +1287,13 @@ -- >>> take 8 $ subsequences ['a'..] -- ["","a","b","ab","c","ac","bc","abc"] -- +-- 'subsequences' does not look ahead unless it must: +-- +-- >>> take 1 (subsequences undefined) +-- [[]] +-- >>> take 2 (subsequences ('a' : undefined)) +-- ["","a"] +-- subsequences :: [a] -> [[a]] subsequences xs = [] : nonEmptySubsequences xs @@ -1272,15 +1333,42 @@ -- Related discussions: -- * https://mail.haskell.org/pipermail/haskell-cafe/2021-December/134920.html -- * https://mail.haskell.org/pipermail/libraries/2007-December/008788.html +-- +-- Verification of the equivalences of the auxiliary functions with Liquid Haskell: +-- https://github.com/ucsd-progsys/liquidhaskell/blob/b86fb5b/tests/ple/pos/Permutations.hs permutations xs0 = xs0 : perms xs0 [] where + -- | @perms ts is@ is equivalent to + -- + -- > concat + -- > [ interleave {(ts!!n)} {(drop (n+1)} ts) xs [] + -- > | n <- [0..length ts - 1] + -- > , xs <- permutations (reverse (take n ts) ++ is) + -- > ] + -- + -- @{(ts!!n)}@ and @{(drop (n+1)}@ denote the values of variables @t@ and @ts@ which + -- appear free in the definition of @interleave@ and @interleave'@. perms :: forall a. [a] -> [a] -> [[a]] perms [] _ = [] perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is) where + -- @interleave {t} {ts} xs r@ is equivalent to + -- + -- > [ insertAt n t xs ++ ts | n <- [0..length xs - 1] ] ++ r + -- + -- where + -- + -- > insertAt n y xs = take n xs ++ y : drop n xs + -- interleave :: [a] -> [[a]] -> [[a]] interleave xs r = let (_,zs) = interleave' id xs r in zs + -- @interleave' f ys r@ is equivalent to + -- + -- > ( ys ++ ts + -- > , [ f (insertAt n t ys ++ ts) | n <- [0..length ys - 1] ] ++ r + -- > ) + -- interleave' :: ([a] -> b) -> [a] -> [b] -> ([a], [b]) interleave' _ [] r = (ts, r) interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r @@ -1489,7 +1577,7 @@ sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) --- | Produce singleton list. +-- | Construct a list from a single element. -- -- >>> singleton True -- [True] @@ -1521,6 +1609,11 @@ -- -- >>> unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 -- [10,9,8,7,6,5,4,3,2,1] +-- +-- Laziness: +-- +-- >>> take 1 (unfoldr (\x -> Just (x, undefined)) 'a') +-- "a" -- -- Note [INLINE unfoldr] diff --git a/Data/Semigroup.hs b/Data/Semigroup.hs --- a/Data/Semigroup.hs +++ b/Data/Semigroup.hs @@ -26,7 +26,6 @@ -- -- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller -- number: --- -- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int -- Min {getMin = 1} -- @@ -49,7 +48,6 @@ -- -- >>> sconcat (1 :| [2, 3, 4]) :: Min Int -- Min {getMin = 1} --- -- >>> sconcat (1 :| [2, 3, 4]) :: Max Int -- Max {getMax = 4} -- @@ -122,56 +120,28 @@ -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. --- --- ==== __Examples__ --- --- >>> take 10 $ cycle1 [1, 2, 3] --- [1,2,3,1,2,3,1,2,3,1] --- --- >>> cycle1 (Right 1) --- Right 1 --- --- >>> cycle1 (Left 1) --- * hangs forever * cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs' -- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. -- --- ==== __Examples__ --- --- > let hello = diff "Hello, " --- +-- === __Example:__ +-- >>> let hello = diff "Hello, " -- >>> appEndo hello "World!" -- "Hello, World!" --- -- >>> appEndo (hello <> mempty) "World!" -- "Hello, World!" --- -- >>> appEndo (mempty <> hello) "World!" -- "Hello, World!" --- --- > let world = diff "World" --- > let excl = diff "!" --- +-- >>> let world = diff "World" +-- >>> let excl = diff "!" -- >>> appEndo (hello <> (world <> excl)) mempty -- "Hello, World!" --- -- >>> appEndo ((hello <> world) <> excl) mempty -- "Hello, World!" diff :: Semigroup m => m -> Endo m diff = Endo . (<>) --- | The 'Min' 'Monoid' and 'Semigroup' always choose the smaller element as --- by the 'Ord' instance and 'min' of the contained type. --- --- ==== __Examples__ --- --- >>> Min 42 <> Min 3 --- Min 3 --- --- >>> sconcat $ Min 1 :| [ Min n | n <- [2 .. 100]] --- Min {getMin = 1} newtype Min a = Min { getMin :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -247,16 +217,6 @@ signum (Min a) = Min (signum a) fromInteger = Min . fromInteger --- | The 'Max' 'Monoid' and 'Semigroup' always choose the bigger element as --- by the 'Ord' instance and 'max' of the contained type. --- --- ==== __Examples__ --- --- >>> Max 42 <> Max 3 --- Max 42 --- --- >>> sconcat $ Max 1 :| [ Max n | n <- [2 .. 100]] --- Max {getMax = 100} newtype Max a = Max { getMax :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -334,16 +294,8 @@ -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be -- placed inside 'Min' and 'Max' to compute an arg min or arg max. -- --- ==== __Examples__ --- -- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ] -- Arg 0 0 --- --- >>> maximum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] --- Arg 3.8 4.0 --- --- >>> minimum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] --- Arg (-34.0) (-10.0) data Arg a b = Arg a -- ^ The argument used for comparisons in 'Eq' and 'Ord'. @@ -358,23 +310,13 @@ ) -- | --- ==== __Examples__ --- -- >>> Min (Arg 0 ()) <> Min (Arg 1 ()) -- Min {getMin = Arg 0 ()} --- --- >>> minimum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] --- Arg 3 "lea" type ArgMin a b = Min (Arg a b) -- | --- ==== __Examples__ --- -- >>> Max (Arg 0 ()) <> Max (Arg 1 ()) -- Max {getMax = Arg 1 ()} --- --- >>> maximum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] --- Arg 9 "violencia" type ArgMax a b = Max (Arg a b) -- | @since 4.9.0.0 @@ -422,13 +364,6 @@ -- The latter returns the first non-'Nothing', -- thus @Data.Monoid.First Nothing <> x = x@. -- --- ==== __Examples__ --- --- >>> First 0 <> First 10 --- First 0 --- --- >>> sconcat $ First 1 :| [ First n | n <- [2 ..] ] --- First 1 newtype First a = First { getFirst :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -492,13 +427,6 @@ -- The latter returns the last non-'Nothing', -- thus @x <> Data.Monoid.Last Nothing = x@. -- --- ==== __Examples__ --- --- >>> Last 0 <> Last 10 --- Last {getLast = 10} --- --- >>> sconcat $ Last 1 :| [ Last n | n <- [2..]] --- Last {getLast = * hangs forever * newtype Last a = Last { getLast :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 @@ -598,7 +526,7 @@ -- -- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times -- --- In many cases, @'stimes' 0 a@ for a `Monoid` will produce `mempty`. +-- In many cases, `stimes 0 a` for a `Monoid` will produce `mempty`. -- However, there are situations when it cannot do so. In particular, -- the following situation is fairly common: -- @@ -607,7 +535,6 @@ -- -- class Constraint1 a -- class Constraint1 a => Constraint2 a --- @ -- -- @ -- instance Constraint1 a => 'Semigroup' (T a) @@ -621,14 +548,6 @@ -- 'Semigroup' instances, @mtimesDefault@ should be used when the -- multiplier might be zero. It is implemented using 'stimes' when -- the multiplier is nonzero and 'mempty' when it is zero. --- --- ==== __Examples__ --- --- >>> mtimesDefault 0 "bark" --- [] --- --- >>> mtimesDefault 3 "meow" --- "meowmeowmeow" mtimesDefault :: (Integral b, Monoid a) => b -> a -> a mtimesDefault n x | n == 0 = mempty diff --git a/Data/Semigroup/Internal.hs b/Data/Semigroup/Internal.hs --- a/Data/Semigroup/Internal.hs +++ b/Data/Semigroup/Internal.hs @@ -40,7 +40,7 @@ -- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. -- --- When @x <> x = x@, this definition should be preferred, because it +-- When @mappend x x = x@, this definition should be preferred, because it -- works in \(\mathcal{O}(1)\) rather than \(\mathcal{O}(\log n)\) stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a stimesIdempotentMonoid n x = case compare n 0 of @@ -105,17 +105,9 @@ rep i = x ++ rep (i - 1) -- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'. --- | The dual of a 'Monoid', obtained by swapping the arguments of '(<>)'. -- --- > Dual a <> Dual b == Dual (b <> a) --- --- ==== __Examples__ --- --- >>> Dual "Hello" <> Dual "World" --- Dual {getDual = "WorldHello"} --- --- >>> Dual (Dual "Hello") <> Dual (Dual "World") --- Dual {getDual = Dual {getDual = "HelloWorld"}} +-- >>> getDual (mappend (Dual "Hello") (Dual "World")) +-- "WorldHello" newtype Dual a = Dual { getDual :: a } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -150,17 +142,9 @@ -- | The monoid of endomorphisms under composition. -- --- > Endo f <> Endo g == Endo (f . g) --- --- ==== __Examples__ --- -- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!") -- >>> appEndo computation "Haskell" -- "Hello, Haskell!" --- --- >>> let computation = Endo (*3) <> Endo (+1) --- >>> appEndo computation 1 --- 6 newtype Endo a = Endo { appEndo :: a -> a } deriving ( Generic -- ^ @since 4.7.0.0 ) @@ -174,20 +158,13 @@ instance Monoid (Endo a) where mempty = Endo id --- | Boolean monoid under conjunction '(&&)'. --- --- > All x <> All y = All (x && y) --- --- ==== __Examples__ --- --- >>> All True <> mempty <> All False) --- All {getAll = False} +-- | Boolean monoid under conjunction ('&&'). -- --- >>> mconcat (map (\x -> All (even x)) [2,4,6,7,8]) --- All {getAll = False} +-- >>> getAll (All True <> mempty <> All False) +-- False -- --- >>> All True <> mempty --- All {getAll = True} +-- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8])) +-- False newtype All = All { getAll :: Bool } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -206,20 +183,13 @@ instance Monoid All where mempty = All True --- | Boolean monoid under disjunction '(||)'. --- --- > Any x <> Any y = Any (x || y) --- --- ==== __Examples__ --- --- >>> Any True <> mempty <> Any False --- Any {getAny = True} +-- | Boolean monoid under disjunction ('||'). -- --- >>> mconcat (map (\x -> Any (even x)) [2,4,6,7,8]) --- Any {getAny = True} +-- >>> getAny (Any True <> mempty <> Any False) +-- True -- --- >>> Any False <> mempty --- Any {getAny = False} +-- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8])) +-- True newtype Any = Any { getAny :: Bool } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -240,15 +210,8 @@ -- | Monoid under addition. -- --- > Sum a <> Sum b = Sum (a + b) --- --- ==== __Examples__ --- --- >>> Sum 1 <> Sum 2 <> mempty --- Sum {getSum = 3} --- --- >>> mconcat [ Sum n | n <- [3 .. 9]] --- Sum {getSum = 42} +-- >>> getSum (Sum 1 <> Sum 2 <> mempty) +-- 3 newtype Sum a = Sum { getSum :: a } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -288,15 +251,8 @@ -- | Monoid under multiplication. -- --- > Product x <> Product y == Product (x * y) --- --- ==== __Examples__ --- --- >>> Product 3 <> Product 4 <> mempty --- Product {getProduct = 12} --- --- >>> mconcat [ Product n | n <- [2 .. 10]] --- Product {getProduct = 3628800} +-- >>> getProduct (Product 3 <> Product 4 <> mempty) +-- 12 newtype Product a = Product { getProduct :: a } deriving ( Eq -- ^ @since 2.01 , Ord -- ^ @since 2.01 @@ -338,14 +294,11 @@ -- | Monoid under '<|>'. -- --- > Alt l <> Alt r == Alt (l <|> r) --- --- ==== __Examples__ --- >>> Alt (Just 12) <> Alt (Just 24) --- Alt {getAlt = Just 12} +-- >>> getAlt (Alt (Just 12) <> Alt (Just 24)) +-- Just 12 -- --- >>> Alt Nothing <> Alt (Just 24) --- Alt {getAlt = Just 24} +-- >>> getAlt $ Alt Nothing <> Alt (Just 24) +-- Just 24 -- -- @since 4.8.0.0 newtype Alt f a = Alt {getAlt :: f a} diff --git a/Data/String.hs b/Data/String.hs --- a/Data/String.hs +++ b/Data/String.hs @@ -37,26 +37,8 @@ import Data.Functor.Identity (Identity (Identity)) import Data.List (lines, words, unlines, unwords) --- | `IsString` is used in combination with the @-XOverloadedStrings@ --- language extension to convert the literals to different string types. --- --- For example, if you use the [text](https://hackage.haskell.org/package/text) package, --- you can say --- --- @ --- {-# LANGUAGE OverloadedStrings #-} --- --- myText = "hello world" :: Text --- @ --- --- Internally, the extension will convert this to the equivalent of --- --- @ --- myText = fromString @Text ("hello world" :: String) --- @ --- --- __Note:__ You can use @fromString@ in normal code as well, --- but the usual performance/memory efficiency problems with 'String' apply. +-- | Class for string-like datastructures; used by the overloaded string +-- extension (-XOverloadedStrings in GHC). class IsString a where fromString :: String -> a diff --git a/Data/Tuple.hs b/Data/Tuple.hs --- a/Data/Tuple.hs +++ b/Data/Tuple.hs @@ -17,6 +17,7 @@ module Data.Tuple ( Solo (..) + , getSolo , fst , snd , curry @@ -25,7 +26,7 @@ ) where import GHC.Base () -- Note [Depend on GHC.Tuple] -import GHC.Tuple (Solo (..)) +import GHC.Tuple (Solo (..), getSolo) default () -- Double isn't available yet diff --git a/Data/Typeable.hs b/Data/Typeable.hs --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -58,6 +58,8 @@ , cast , eqT , heqT + , decT + , hdecT , gcast -- a generalisation of cast -- * Generalized casts for higher-order kinds @@ -99,6 +101,7 @@ import Data.Typeable.Internal (Typeable) import Data.Type.Equality +import Data.Either import Data.Maybe import Data.Proxy import GHC.Fingerprint.Type @@ -140,11 +143,28 @@ | Just HRefl <- heqT @a @b = Just Refl | otherwise = Nothing +-- | Decide an equality of two types +-- +-- @since 4.19.0.0 +decT :: forall a b. (Typeable a, Typeable b) => Either (a :~: b -> Void) (a :~: b) +decT = case hdecT @a @b of + Right HRefl -> Right Refl + Left p -> Left (\Refl -> p HRefl) + -- | Extract a witness of heterogeneous equality of two types -- -- @since 4.18.0.0 heqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~~: b) heqT = ta `I.eqTypeRep` tb + where + ta = I.typeRep :: I.TypeRep a + tb = I.typeRep :: I.TypeRep b + +-- | Decide heterogeneous equality of two types. +-- +-- @since 4.19.0.0 +hdecT :: forall a b. (Typeable a, Typeable b) => Either (a :~~: b -> Void) (a :~~: b) +hdecT = ta `I.decTypeRep` tb where ta = I.typeRep :: I.TypeRep a tb = I.typeRep :: I.TypeRep b diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs --- a/Data/Typeable/Internal.hs +++ b/Data/Typeable/Internal.hs @@ -66,6 +66,7 @@ typeRepFingerprint, rnfTypeRep, eqTypeRep, + decTypeRep, typeRepKind, splitApps, @@ -88,8 +89,11 @@ import GHC.Base import qualified GHC.Arr as A +import Data.Either (Either (..)) import Data.Type.Equality -import GHC.List ( splitAt, foldl', elem ) +import GHC.List ( splitAt, foldl', elem, replicate ) +import GHC.Unicode (isDigit) +import GHC.Num ((-), (+), (*)) import GHC.Word import GHC.Show import GHC.TypeLits ( KnownChar, charVal', KnownSymbol, symbolVal' @@ -268,6 +272,7 @@ pattern TypeRep :: forall {k :: Type} (a :: k). () => Typeable @k a => TypeRep @k a pattern TypeRep <- (typeableInstance -> TypeableInstance) where TypeRep = typeRep +{-# COMPLETE TypeRep #-} {- Note [TypeRep fingerprints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -611,15 +616,49 @@ -- @since 4.10 eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~~: b) -eqTypeRep a b - | sameTypeRep a b = Just (unsafeCoerce HRefl) - | otherwise = Nothing --- We want GHC to inline eqTypeRep to get rid of the Maybe --- in the usual case that it is scrutinized immediately. We --- split eqTypeRep into a worker and wrapper because otherwise --- it's much larger than anything we'd want to inline. -{-# INLINABLE eqTypeRep #-} +eqTypeRep a b = case inline decTypeRep a b of + -- inline: see wrinkle (I1) in Note [Inlining eqTypeRep/decTypeRep] + Right p -> Just p + Left _ -> Nothing +-- | Type equality decision +-- +-- @since 4.19.0.0 +decTypeRep :: forall k1 k2 (a :: k1) (b :: k2). + TypeRep a -> TypeRep b -> Either (a :~~: b -> Void) (a :~~: b) +decTypeRep a b + | sameTypeRep a b = Right (unsafeCoerce HRefl) + | otherwise = Left (\HRefl -> errorWithoutStackTrace ("decTypeRep: Impossible equality proof " ++ show a ++ " :~: " ++ show b)) + +{-# INLINEABLE eqTypeRep #-} +{-# INLINEABLE decTypeRep #-} + +{- +Note [Inlining eqTypeRep/decTypeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We want GHC to inline eqTypeRep and decTypeRep to get rid of the Maybe +and Either in the usual case that it is scrutinized immediately. We +split them into a worker (sameTypeRep) and wrappers because otherwise +it's much larger than anything we'd want to inline. + +We need INLINEABLE on the eqTypeRep and decTypeRep as GHC +seems to want to inline sameTypeRep here, making tham bigger. +By exposing exact RHS, they stay small and other optimizations may +fire first, so GHC can realise that inlining sameTypeRep is often +(but not always) a bad idea. + +Wrinkle I1: + +`inline decTypeRep` in eqTypeRep implementation is to ensure that `decTypeRep` +is inlined, even it's somewhat big of expression, but we know that big Left +branch will be optimized away. + +See discussion in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9524 +and also https://gitlab.haskell.org/ghc/ghc/-/issues/22635 + +-} + sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Bool sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b @@ -843,9 +882,12 @@ -- Take care only to render saturated tuple tycon applications -- with tuple notation (#14341). - | isTupleTyCon tc, + | Just _ <- isTupleTyCon tc, Just _ <- TrType `eqTypeRep` typeRepKind rep = showChar '(' . showArgs (showChar ',') tys . showChar ')' + -- Print (,,,) instead of Tuple4 + | Just n <- isTupleTyCon tc, [] <- tys = + showChar '(' . showString (replicate (n-1) ',') . showChar ')' where (tc, tys) = splitApps rep showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []}) = showTyCon tycon @@ -934,10 +976,26 @@ isListTyCon :: TyCon -> Bool isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep []) -isTupleTyCon :: TyCon -> Bool +isTupleTyCon :: TyCon -> Maybe Int isTupleTyCon tc - | ('(':',':_) <- tyConName tc = True - | otherwise = False + | tyConPackage tc == "ghc-prim" + , tyConModule tc == "GHC.Tuple.Prim" + = case tyConName tc of + "Unit" -> Just 0 + 'T' : 'u' : 'p' : 'l' : 'e' : arity -> readTwoDigits arity + _ -> Nothing + | otherwise = Nothing + +-- | See Note [Small Ints parsing] in GHC.Builtin.Types +readTwoDigits :: String -> Maybe Int +readTwoDigits s = case s of + [c] | isDigit c -> Just (digit_to_int c) + [c1, c2] | isDigit c1, isDigit c2 + -> Just (digit_to_int c1 * 10 + digit_to_int c2) + _ -> Nothing + where + digit_to_int :: Char -> Int + digit_to_int c = ord c - ord '0' -- This is only an approximation. We don't have the general -- character-classification machinery here, so we just do our best. diff --git a/Foreign/Marshal/Utils.hs b/Foreign/Marshal/Utils.hs --- a/Foreign/Marshal/Utils.hs +++ b/Foreign/Marshal/Utils.hs @@ -1,6 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Utils @@ -50,13 +53,11 @@ ) where import Data.Maybe -import Foreign.Ptr ( Ptr, nullPtr ) +import GHC.Ptr ( Ptr(..), nullPtr ) import Foreign.Storable ( Storable(poke) ) -import Foreign.C.Types ( CSize(..), CInt(..) ) import Foreign.Marshal.Alloc ( malloc, alloca ) -import Data.Word ( Word8 ) +import GHC.Word ( Word8(..) ) -import GHC.Real ( fromIntegral ) import GHC.Num import GHC.Base @@ -158,9 +159,8 @@ -> Ptr a -- ^ Source -> Int -- ^ Size in bytes -> IO () -copyBytes dest src size = do - _ <- memcpy dest src (fromIntegral size) - return () +copyBytes = coerce $ \(Ptr dest#) (Ptr src#) (I# size#) s + -> (# copyAddrToAddrNonOverlapping# src# dest# size# s, () #) -- |Copies the given number of bytes from the second area (source) into the -- first (destination); the copied areas /may/ overlap @@ -170,9 +170,8 @@ -> Ptr a -- ^ Source -> Int -- ^ Size in bytes -> IO () -moveBytes dest src size = do - _ <- memmove dest src (fromIntegral size) - return () +moveBytes = coerce $ \(Ptr dest#) (Ptr src#) (I# size#) s + -> (# copyAddrToAddr# src# dest# size# s, () #) -- Filling up memory area with required values -- ------------------------------------------- @@ -180,16 +179,6 @@ -- |Fill a given number of bytes in memory area with a byte value. -- -- @since 4.8.0.0 -fillBytes :: Ptr a -> Word8 -> Int -> IO () -fillBytes dest char size = do - _ <- memset dest (fromIntegral char) (fromIntegral size) - return () - --- auxiliary routines --- ------------------- - --- |Basic C routines needed for memory copying --- -foreign import ccall unsafe "string.h" memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) -foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) +fillBytes :: Ptr a -> Word8 -> Int -> IO () +fillBytes = coerce $ \(Ptr dest#) (W8# byte#) (I# size#) s + -> (# setAddrRange# dest# size# (word2Int# (word8ToWord# byte#)) s, () #) diff --git a/GHC/Base.hs b/GHC/Base.hs --- a/GHC/Base.hs +++ b/GHC/Base.hs @@ -250,16 +250,8 @@ class Semigroup a where -- | An associative operation. -- - -- ==== __Examples__ - -- -- >>> [1,2,3] <> [4,5,6] -- [1,2,3,4,5,6] - -- - -- >>> Just [1, 2, 3] <> Just [4, 5, 6] - -- Just [1,2,3,4,5,6] - -- - -- >>> putStr "Hello, " <> putStrLn "World!" - -- Hello, World! (<>) :: a -> a -> a a <> b = sconcat (a :| [ b ]) @@ -268,20 +260,9 @@ -- The default definition should be sufficient, but this can be -- overridden for efficiency. -- - -- ==== __Examples__ - -- - -- For the following examples, we will assume that we have: - -- -- >>> import Data.List.NonEmpty (NonEmpty (..)) - -- -- >>> sconcat $ "Hello" :| [" ", "Haskell", "!"] -- "Hello Haskell!" - -- - -- >>> sconcat $ Just [1, 2, 3] :| [Nothing, Just [4, 5, 6]] - -- Just [1,2,3,4,5,6] - -- - -- >>> sconcat $ Left 1 :| [Right 2, Left 3, Right 4] - -- Right 2 sconcat :: NonEmpty a -> a sconcat (a :| as) = go a as where go b (c:cs) = b <> go c cs @@ -289,25 +270,17 @@ -- | Repeat a value @n@ times. -- - -- The default definition will raise an exception for a multiplier that is @<= 0@. - -- This may be overridden with an implementation that is total. For monoids - -- it is preferred to use 'stimesMonoid'. + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. -- -- By making this a member of the class, idempotent semigroups -- and monoids can upgrade this to execute in \(\mathcal{O}(1)\) by -- picking @stimes = 'Data.Semigroup.stimesIdempotent'@ or @stimes = - -- 'Data.Semigroup.stimesIdempotentMonoid'@ respectively. - -- - -- ==== __Examples__ + -- 'stimesIdempotentMonoid'@ respectively. -- -- >>> stimes 4 [1] -- [1,1,1,1] - -- - -- >>> stimes 5 (putStr "hi!") - -- hi!hi!hi!hi!hi! - -- - -- >>> stimes 3 (Right ":)") - -- Right ":)" stimes :: Integral b => b -> a -> a stimes = stimesDefault @@ -341,12 +314,8 @@ class Semigroup a => Monoid a where -- | Identity of 'mappend' -- - -- ==== __Examples__ -- >>> "Hello world" <> mempty -- "Hello world" - -- - -- >>> mempty <> [1, 2, 3] - -- [1,2,3] mempty :: a mempty = mconcat [] {-# INLINE mempty #-} @@ -837,11 +806,21 @@ (<*) :: f a -> f b -> f a (<*) = liftA2 const --- | A variant of '<*>' with the arguments reversed. +-- | A variant of '<*>' with the types of the arguments reversed. It differs from +-- @`flip` `(<*>)`@ in that the effects are resolved in the order the arguments are +-- presented. -- +-- ==== __Examples__ +-- >>> (<**>) (print 1) (id <$ print 2) +-- 1 +-- 2 +-- +-- >>> flip (<*>) (print 1) (id <$ print 2) +-- 2 +-- 1 + (<**>) :: Applicative f => f a -> f (a -> b) -> f b (<**>) = liftA2 (\a f -> f a) --- Don't use $ here, see the note at the top of the page -- | Lift a function to actions. -- Equivalent to Functor's `fmap` but implemented using only `Applicative`'s methods: @@ -1492,8 +1471,13 @@ -- -- If the first list is not finite, the result is the first list. -- --- WARNING: This function takes linear time in the number of elements of the --- first list. +-- This function takes linear time in the number of elements of the +-- __first__ list. Thus it is better to associate repeated +-- applications of '(++)' to the right (which is the default behaviour): +-- @xs ++ (ys ++ zs)@ or simply @xs ++ ys ++ zs@, but not @(xs ++ ys) ++ zs@. +-- For the same reason 'Data.List.concat' @=@ 'Data.List.foldr' '(++)' @[]@ +-- has linear performance, while 'Data.List.foldl' '(++)' @[]@ is prone +-- to quadratic slowdown. (++) :: [a] -> [a] -> [a] {-# NOINLINE [2] (++) #-} @@ -1524,42 +1508,10 @@ -- Type Char and String ---------------------------------------------- --- | 'String' is an alias for a list of characters. --- --- String constants in Haskell are values of type 'String'. --- That means if you write a string literal like @"hello world"@, --- it will have the type @[Char]@, which is the same as @String@. --- --- __Note:__ You can ask the compiler to automatically infer different types --- with the @-XOverloadedStrings@ language extension, for example --- @"hello world" :: Text@. See t'Data.String.IsString' for more information. --- --- Because @String@ is just a list of characters, you can use normal list functions --- to do basic string manipulation. See "Data.List" for operations on lists. --- --- === __Performance considerations__ --- --- @[Char]@ is a relatively memory-inefficient type. --- It is a linked list of boxed word-size characters, internally it looks something like: --- --- > ╭─────┬───┬──╮ ╭─────┬───┬──╮ ╭─────┬───┬──╮ ╭────╮ --- > │ (:) │ │ ─┼─>│ (:) │ │ ─┼─>│ (:) │ │ ─┼─>│ [] │ --- > ╰─────┴─┼─┴──╯ ╰─────┴─┼─┴──╯ ╰─────┴─┼─┴──╯ ╰────╯ --- > v v v --- > 'a' 'b' 'c' --- --- The @String@ "abc" will use @5*3+1 = 16@ (in general @5n+1@) --- words of space in memory. --- --- Furthermore, operations like '(++)' (string concatenation) are @O(n)@ --- (in the left argument). +-- | A 'String' is a list of characters. String constants in Haskell are values +-- of type 'String'. -- --- For historical reasons, the @base@ library uses @String@ in a lot of places --- for the conceptual simplicity, but library code dealing with user-data --- should use the [text](https://hackage.haskell.org/package/text) --- package for Unicode text, or the the --- [bytestring](https://hackage.haskell.org/package/bytestring) package --- for binary data. +-- See "Data.List" for operations on lists. type String = [Char] unsafeChr :: Int -> Char @@ -1661,21 +1613,80 @@ flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x --- | Application operator. This operator is redundant, since ordinary --- application @(f x)@ means the same as @(f '$' x)@. However, '$' has --- low, right-associative binding precedence, so it sometimes allows --- parentheses to be omitted; for example: --- --- > f $ g $ h x = f (g (h x)) --- --- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@, --- or @'Data.List.zipWith' ('$') fs xs@. --- --- Note that @('$')@ is representation-polymorphic in its result type, so that --- @foo '$' True@ where @foo :: Bool -> Int#@ is well-typed. +-- Note: Before base-4.19, ($) was not representation polymorphic +-- in both type parameters but only in the return type. +-- The generalization forced a change to the implementation, +-- changing its laziness, affecting expressions like (($) undefined): before +-- base-4.19 the expression (($) undefined) `seq` () was equivalent to +-- (\x -> undefined x) `seq` () and thus would just evaluate to (), but now +-- it is equivalent to undefined `seq` () which diverges. + +{- | @($)@ is the __function application__ operator. + +Applying @($)@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this: + +@ +($) :: (a -> b) -> a -> b +($) f x = f x +@ + +On the face of it, this may appear pointless! But it's actually one of the most useful and important operators in Haskell. + +The order of operations is very different between @($)@ and normal function application. Normal function application has precedence 10 - higher than any operator - and associates to the left. So these two definitions are equivalent: + +@ +expr = min 5 1 + 5 +expr = ((min 5) 1) + 5 +@ + +@($)@ has precedence 0 (the lowest) and associates to the right, so these are equivalent: + +@ +expr = min 5 $ 1 + 5 +expr = (min 5) (1 + 5) +@ + +=== Uses + +A common use cases of @($)@ is to avoid parentheses in complex expressions. + +For example, instead of using nested parentheses in the following + Haskell function: + +@ +-- | Sum numbers in a string: strSum "100 5 -7" == 98 +strSum :: 'String' -> 'Int' +strSum s = 'sum' ('Data.Maybe.mapMaybe' 'Text.Read.readMaybe' ('words' s)) +@ + +we can deploy the function application operator: + +@ +-- | Sum numbers in a string: strSum "100 5 -7" == 98 +strSum :: 'String' -> 'Int' +strSum s = 'sum' '$' 'Data.Maybe.mapMaybe' 'Text.Read.readMaybe' '$' 'words' s +@ + +@($)@ is also used as a section (a partially applied operator), in order to indicate that we wish to apply some yet-unspecified function to a given value. For example, to apply the argument @5@ to a list of functions: + +@ +applyFive :: [Int] +applyFive = map ($ 5) [(+1), (2^)] +>>> [6, 32] +@ + +=== Technical Remark (Representation Polymorphism) + +@($)@ is fully representation-polymorphic. This allows it to also be used with arguments of unlifted and even unboxed kinds, such as unboxed integers: + +@ +fastMod :: Int -> Int -> Int +fastMod (I# x) (I# m) = I# $ remInt# x m +@ +-} {-# INLINE ($) #-} -($) :: forall r a (b :: TYPE r). (a -> b) -> a -> b -f $ x = f x +($) :: forall repa repb (a :: TYPE repa) (b :: TYPE repb). (a -> b) -> a -> b +($) f = f -- | Strict (call-by-value) application operator. It takes a function and an -- argument, evaluates the argument to weak head normal form (WHNF), then calls diff --git a/GHC/Clock.hsc b/GHC/Clock.hsc --- a/GHC/Clock.hsc +++ b/GHC/Clock.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -9,17 +10,36 @@ import GHC.Base import GHC.Real import Data.Word +#if defined(javascript_HOST_ARCH) +import GHC.Num +#endif -- | Return monotonic time in seconds, since some unspecified starting point -- -- @since 4.11.0.0 getMonotonicTime :: IO Double -getMonotonicTime = do w <- getMonotonicTimeNSec - return (fromIntegral w / 1000000000) +getMonotonicTime = do +#if defined(javascript_HOST_ARCH) + w <- getMonotonicTimeMSec + return (w / 1000) +#else + w <- getMonotonicTimeNSec + return (fromIntegral w / 1000000000) +#endif -- | Return monotonic time in nanoseconds, since some unspecified starting point -- -- @since 4.11.0.0 +#if defined(javascript_HOST_ARCH) +getMonotonicTimeNSec :: IO Word64 +getMonotonicTimeNSec = do + w <- getMonotonicTimeMSec + return (floor w * 1000000) + +foreign import javascript unsafe "performance.now" getMonotonicTimeMSec:: IO Double + + +#else foreign import ccall unsafe "getMonotonicNSec" getMonotonicTimeNSec :: IO Word64 - +#endif diff --git a/GHC/Conc/POSIX.hs b/GHC/Conc/POSIX.hs --- a/GHC/Conc/POSIX.hs +++ b/GHC/Conc/POSIX.hs @@ -49,6 +49,7 @@ import Data.Bits (shiftR) import GHC.Base +import GHC.Clock import GHC.Conc.Sync import GHC.Conc.POSIX.Const import GHC.Event.Windows.ConsoleEvent @@ -209,13 +210,9 @@ delayTime (DelaySTM t _) = t type USecs = Word64 -type NSecs = Word64 -foreign import ccall unsafe "getMonotonicNSec" - getMonotonicNSec :: IO NSecs - getMonotonicUSec :: IO USecs -getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec +getMonotonicUSec = fmap (`div` 1000) getMonotonicTimeNSec {-# NOINLINE prodding #-} prodding :: IORef Bool diff --git a/GHC/Conc/Sync.hs b/GHC/Conc/Sync.hs --- a/GHC/Conc/Sync.hs +++ b/GHC/Conc/Sync.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} @@ -32,6 +33,7 @@ ( -- * Threads ThreadId(..) + , fromThreadId , showThreadId , myThreadId , killThread @@ -132,9 +134,6 @@ ----------------------------------------------------------------------------- data ThreadId = ThreadId ThreadId# --- ToDo: data ThreadId = ThreadId (Weak ThreadId#) --- But since ThreadId# is unlifted, the Weak type must use open --- type variables. {- ^ A 'ThreadId' is an abstract type representing a handle to a thread. 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where @@ -145,17 +144,23 @@ program. /Note/: in GHC, if you have a 'ThreadId', you essentially have -a pointer to the thread itself. This means the thread itself can\'t be -garbage collected until you drop the 'ThreadId'. -This misfeature will hopefully be corrected at a later date. - +a pointer to the thread itself. This means the thread itself can\'t be +garbage collected until you drop the 'ThreadId'. This misfeature would +be difficult to correct while continuing to support 'threadStatus'. -} +-- | Map a thread to an integer identifier which is unique within the +-- current process. +-- +-- @since 4.19.0.0 +fromThreadId :: ThreadId -> Word64 +fromThreadId tid = fromIntegral $ getThreadId (id2TSO tid) + -- | @since 4.2.0.0 instance Show ThreadId where showsPrec d t = showParen (d >= 11) $ showString "ThreadId " . - showsPrec d (getThreadId (id2TSO t)) + showsPrec d (fromThreadId t) showThreadId :: ThreadId -> String showThreadId = show @@ -391,14 +396,13 @@ getNumProcessors = fmap fromIntegral c_getNumberOfProcessors foreign import ccall unsafe "getNumberOfProcessors" - c_getNumberOfProcessors :: IO Word32 + c_getNumberOfProcessors :: IO CUInt -- | Returns the number of sparks currently in the local spark pool numSparks :: IO Int numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #) -foreign import ccall "&enabled_capabilities" - enabled_capabilities :: Ptr Word32 +foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt childHandler :: SomeException -> IO () childHandler err = catch (real_handler err) childHandler diff --git a/GHC/Event/Control.hs b/GHC/Event/Control.hs --- a/GHC/Event/Control.hs +++ b/GHC/Event/Control.hs @@ -50,7 +50,7 @@ import Foreign.C.Error (throwErrnoIfMinus1, eBADF) import Foreign.C.Types (CULLong(..)) #else -import Foreign.C.Error (eAGAIN, eWOULDBLOCK) +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF) #endif data ControlMessage = CMsgWakeup @@ -211,8 +211,15 @@ _ | n /= -1 -> return () | otherwise -> do errno <- getErrno - when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ - throwErrno "sendWakeup" + isDead <- readIORef (controlIsDead c) + case () of + _ -- Someone else has beat us to waking it up + | errno == eAGAIN -> return () + | errno == eWOULDBLOCK -> return () + -- we are shutting down + | errno == eBADF && isDead -> return () + -- something bad happened + | otherwise -> throwErrno "sendWakeup" #endif sendDie :: Control -> IO () diff --git a/GHC/Event/KQueue.hsc b/GHC/Event/KQueue.hsc --- a/GHC/Event/KQueue.hsc +++ b/GHC/Event/KQueue.hsc @@ -44,8 +44,8 @@ import GHC.Real (quotRem, fromIntegral) import GHC.Show (Show(show)) import GHC.Event.Internal (Timeout(..)) -import System.Posix.Internals (c_close, c_getpid) -import System.Posix.Types (Fd(..), CPid) +import System.Posix.Internals (c_close) +import System.Posix.Types (Fd(..)) import qualified GHC.Event.Array as A #if defined(netbsd_HOST_OS) @@ -73,26 +73,19 @@ data KQueue = KQueue { kqueueFd :: {-# UNPACK #-} !KQueueFd , kqueueEvents :: {-# UNPACK #-} !(A.Array Event) - , kqueuePid :: {-# UNPACK #-} !CPid -- ^ pid, used to detect forks } new :: IO E.Backend new = do kqfd <- kqueue events <- A.new 64 - pid <- c_getpid - let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events pid) + let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events) return be delete :: KQueue -> IO () delete kq = do - -- detect forks: the queue isn't inherited by a child process created with - -- fork. Hence we mustn't try to close the old fd or we might close a random - -- one (e.g. the one used by timerfd, cf #24672). - pid <- c_getpid - when (pid == kqueuePid kq) $ do - _ <- c_close . fromKQueueFd . kqueueFd $ kq - return () + _ <- c_close . fromKQueueFd . kqueueFd $ kq + return () modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool modifyFd kq fd oevt nevt = do diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -467,7 +467,7 @@ IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl) forM_ fdds $ \(FdData reg _ cb) -> cb reg evs where - -- | Here we look through the list of registrations for the fd of interest + -- Here we look through the list of registrations for the fd of interest -- and sort out which match the events that were triggered. We, -- -- 1. re-arm the fd as appropriate diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs --- a/GHC/Event/TimerManager.hs +++ b/GHC/Event/TimerManager.hs @@ -175,7 +175,7 @@ state `seq` return (state == Running) where - -- | Call all expired timer callbacks and return the time to the + -- Call all expired timer callbacks and return the time to the -- next timeout. mkTimeout :: IO Timeout mkTimeout = do diff --git a/GHC/Exts.hs b/GHC/Exts.hs --- a/GHC/Exts.hs +++ b/GHC/Exts.hs @@ -203,8 +203,11 @@ * * ********************************************************************** -} --- Annotating a type with NoSpecConstr will make SpecConstr --- not specialise for arguments of that type. +-- | Deprecated, use 'SPEC' directly instead. +-- +-- Annotating a type with 'NoSpecConstr' will make @SpecConstr@ +-- not specialise for arguments of that type, +-- e. g., @{-# ANN type SPEC ForceSpecConstr #-}@. -- This data type is defined here, rather than in the SpecConstr module -- itself, so that importing it doesn't force stupidly linking the diff --git a/GHC/Fingerprint.hs b/GHC/Fingerprint.hs --- a/GHC/Fingerprint.hs +++ b/GHC/Fingerprint.hs @@ -84,7 +84,7 @@ where _BUFSIZE = 4096 - -- | Loop over _BUFSIZE sized chunks read from the handle, + -- Loop over _BUFSIZE sized chunks read from the handle, -- passing the callback a block of bytes and its size. processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> diff --git a/GHC/Fingerprint/Type.hs b/GHC/Fingerprint/Type.hs --- a/GHC/Fingerprint/Type.hs +++ b/GHC/Fingerprint/Type.hs @@ -30,7 +30,7 @@ instance Show Fingerprint where show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2 where - -- | Formats a 64 bit number as 16 digits hex. + -- Formats a 64 bit number as 16 digits hex. hex16 :: Word64 -> String hex16 i = let hex = showHex i "" in replicate (16 - length hex) '0' ++ hex diff --git a/GHC/Float.hs b/GHC/Float.hs --- a/GHC/Float.hs +++ b/GHC/Float.hs @@ -276,17 +276,18 @@ ------------------------------------------------------------------------ -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Float' have an --- additive inverse. -- --- >>> 0/0 + (negate 0/0 :: Float) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- Neither addition nor multiplication are associative or distributive: -- --- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't --- have an additive identity +-- >>> (0.1 + 0.1 :: Float) + 0.5 == 0.1 + (0.1 + 0.5) +-- False +-- >>> (0.1 + 0.2 :: Float) * 0.9 == 0.1 * 0.9 + 0.2 * 0.9 +-- False +-- >>> (0.1 * 0.1 :: Float) * 0.9 == 0.1 * (0.1 * 0.9) +-- False -- --- >>> 0 + (-0 :: Float) --- 0.0 instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y @@ -317,6 +318,14 @@ F# x -> x -- | @since 2.01 +-- +-- Beware that 'toRational' generates garbage for non-finite arguments: +-- +-- >>> toRational (1/0 :: Float) +-- 340282366920938463463374607431768211456 % 1 +-- >>> toRational (0/0 :: Float) +-- 510423550381407695195061911147652317184 % 1 +-- instance Real Float where toRational (F# x#) = case decodeFloat_Int# x# of @@ -330,14 +339,19 @@ IS m# :% integerShiftL# 1 (int2Word# (negateInt# e#)) -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Float' have an --- multiplicative inverse. -- --- >>> 0/0 * (recip 0/0 :: Float) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. -- --- Additionally, because of @NaN@ this instance does not obey the left-inverse --- law for 'toRational'/'fromRational'. +-- >>> 0 == (-0 :: Float) +-- True +-- >>> recip 0 == recip (-0 :: Float) +-- False +-- >>> map (/ 0) [-1, 0, 1 :: Float] +-- [-Infinity,NaN,Infinity] +-- >>> map (* 0) $ map (/ 0) [-1, 0, 1 :: Float] +-- [NaN,NaN,NaN] +-- instance Fractional Float where (/) x y = divideFloat x y {-# INLINE fromRational #-} @@ -360,6 +374,15 @@ mantDigs = FLT_MANT_DIG -- | @since 2.01 +-- +-- Beware that results for non-finite arguments are garbage: +-- +-- >>> [ f x | f <- [round, floor, ceiling], x <- [-1/0, 0/0, 1/0 :: Float] ] :: [Int] +-- [0,0,0,0,0,0,0,0,0] +-- >>> map properFraction [-1/0, 0/0, 1/0] :: [(Int, Float)] +-- [(0,0.0),(0,0.0),(0,0.0)] +-- +-- and get even more non-sensical if you ask for 'Integer' instead of 'Int'. instance RealFrac Float where properFraction = properFractionFloat @@ -507,17 +530,18 @@ ------------------------------------------------------------------------ -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Double' have an --- additive inverse. -- --- >>> 0/0 + (negate 0/0 :: Double) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- Neither addition nor multiplication are associative or distributive: -- --- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't --- have an additive identity +-- >>> (0.1 + 0.1) + 0.4 == 0.1 + (0.1 + 0.4) +-- False +-- >>> (0.1 + 0.2) * 0.3 == 0.1 * 0.3 + 0.2 * 0.3 +-- False +-- >>> (0.1 * 0.1) * 0.3 == 0.1 * (0.1 * 0.3) +-- False -- --- >>> 0 + (-0 :: Double) --- 0.0 instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -550,6 +574,14 @@ -- | @since 2.01 +-- +-- Beware that 'toRational' generates garbage for non-finite arguments: +-- +-- >>> toRational (1/0) +-- 179769313 (and 300 more digits...) % 1 +-- >>> toRational (0/0) +-- 269653970 (and 300 more digits...) % 1 +-- instance Real Double where toRational (D# x#) = case integerDecodeDouble# x# of @@ -563,14 +595,19 @@ m :% integerShiftL# 1 (int2Word# (negateInt# e#)) -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Double' have an --- multiplicative inverse. -- --- >>> 0/0 * (recip 0/0 :: Double) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. -- --- Additionally, because of @NaN@ this instance does not obey the left-inverse --- law for 'toRational'/'fromRational'. +-- >>> 0 == (-0 :: Double) +-- True +-- >>> recip 0 == recip (-0 :: Double) +-- False +-- >>> map (/ 0) [-1, 0, 1] +-- [-Infinity,NaN,Infinity] +-- >>> map (* 0) $ map (/ 0) [-1, 0, 1] +-- [NaN,NaN,NaN] +-- instance Fractional Double where (/) x y = divideDouble x y {-# INLINE fromRational #-} @@ -626,6 +663,15 @@ {-# INLINE log1pexp #-} -- | @since 2.01 +-- +-- Beware that results for non-finite arguments are garbage: +-- +-- >>> [ f x | f <- [round, floor, ceiling], x <- [-1/0, 0/0, 1/0] ] :: [Int] +-- [0,0,0,0,0,0,0,0,0] +-- >>> map properFraction [-1/0, 0/0, 1/0] :: [(Int, Double)] +-- [(0,0.0),(0,0.0),(0,0.0)] +-- +-- and get even more non-sensical if you ask for 'Integer' instead of 'Int'. instance RealFrac Double where properFraction = properFractionDouble truncate = truncateDouble @@ -796,6 +842,14 @@ -} -- | @since 2.01 +-- +-- 'fromEnum' just truncates its argument, beware of all sorts of overflows. +-- +-- List generators have extremely peculiar behavior, mandated by +-- [Haskell Report 2010](https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#x13-1310006.3.4): +-- +-- >>> [0..1.5 :: Float] +-- [0.0,1.0,2.0] instance Enum Float where succ x = x + 1 pred x = x - 1 @@ -807,6 +861,14 @@ enumFromThenTo = numericEnumFromThenTo -- | @since 2.01 +-- +-- 'fromEnum' just truncates its argument, beware of all sorts of overflows. +-- +-- List generators have extremely peculiar behavior, mandated by +-- [Haskell Report 2010](https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#x13-1310006.3.4): +-- +-- >>> [0..1.5] +-- [0.0,1.0,2.0] instance Enum Double where succ x = x + 1 pred x = x - 1 diff --git a/GHC/Foreign.hs b/GHC/Foreign.hs --- a/GHC/Foreign.hs +++ b/GHC/Foreign.hs @@ -21,312 +21,22 @@ -- * C strings with a configurable encoding CString, CStringLen, - -- conversion of C strings into Haskell strings - -- + -- * Conversion of C strings into Haskell strings peekCString, peekCStringLen, - -- conversion of Haskell strings into C strings - -- + -- * Conversion of Haskell strings into C strings newCString, newCStringLen, + newCStringLen0, - -- conversion of Haskell strings into C strings using temporary storage - -- + -- * Conversion of Haskell strings into C strings using temporary storage withCString, withCStringLen, + withCStringLen0, withCStringsLen, charIsRepresentable, ) where -import Foreign.Marshal.Array -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable - -import Data.Word - --- Imports for the locale-encoding version of marshallers - -import Data.Tuple (fst) - -import GHC.Show ( show ) - -import Foreign.Marshal.Alloc -import Foreign.ForeignPtr - -import GHC.Debug -import GHC.List -import GHC.Num -import GHC.Base - -import GHC.IO -import GHC.IO.Exception -import GHC.IO.Buffer -import GHC.IO.Encoding.Types - - -c_DEBUG_DUMP :: Bool -c_DEBUG_DUMP = False - -putDebugMsg :: String -> IO () -putDebugMsg | c_DEBUG_DUMP = debugLn - | otherwise = const (return ()) - - --- | A C string is a reference to an array of C characters terminated by NUL. -type CString = Ptr CChar - --- | A string with explicit length information in bytes instead of a --- terminating NUL (allowing NUL characters in the middle of the string). -type CStringLen = (Ptr CChar, Int) - --- exported functions --- ------------------ - --- | Marshal a NUL terminated C string into a Haskell string. --- -peekCString :: TextEncoding -> CString -> IO String -peekCString enc cp = do - sz <- lengthArray0 nUL cp - peekEncodedCString enc (cp, sz * cCharSize) - --- | Marshal a C string with explicit length into a Haskell string. --- -peekCStringLen :: TextEncoding -> CStringLen -> IO String -peekCStringLen = peekEncodedCString - --- | Marshal a Haskell string into a NUL terminated C string. --- --- * the Haskell string may /not/ contain any NUL characters --- --- * new storage is allocated for the C string and must be --- explicitly freed using 'Foreign.Marshal.Alloc.free' or --- 'Foreign.Marshal.Alloc.finalizerFree'. --- -newCString :: TextEncoding -> String -> IO CString -newCString enc = liftM fst . newEncodedCString enc True - --- | Marshal a Haskell string into a C string (ie, character array) with --- explicit length information. --- --- * new storage is allocated for the C string and must be --- explicitly freed using 'Foreign.Marshal.Alloc.free' or --- 'Foreign.Marshal.Alloc.finalizerFree'. --- -newCStringLen :: TextEncoding -> String -> IO CStringLen -newCStringLen enc = newEncodedCString enc False - --- | Marshal a Haskell string into a NUL terminated C string using temporary --- storage. --- --- * the Haskell string may /not/ contain any NUL characters --- --- * the memory is freed when the subcomputation terminates (either --- normally or via an exception), so the pointer to the temporary --- storage must /not/ be used after this. --- -withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a -withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp - --- | Marshal a Haskell string into a C string (ie, character array) --- in temporary storage, with explicit length information. --- --- * the memory is freed when the subcomputation terminates (either --- normally or via an exception), so the pointer to the temporary --- storage must /not/ be used after this. --- -withCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a -withCStringLen enc = withEncodedCString enc False - --- | Marshal a list of Haskell strings into an array of NUL terminated C strings --- using temporary storage. --- --- * the Haskell strings may /not/ contain any NUL characters --- --- * the memory is freed when the subcomputation terminates (either --- normally or via an exception), so the pointer to the temporary --- storage must /not/ be used after this. --- -withCStringsLen :: TextEncoding - -> [String] - -> (Int -> Ptr CString -> IO a) - -> IO a -withCStringsLen enc strs f = go [] strs - where - go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss - go cs [] = withArrayLen (reverse cs) f - --- | Determines whether a character can be accurately encoded in a --- 'Foreign.C.String.CString'. --- --- Pretty much anyone who uses this function is in a state of sin because --- whether or not a character is encodable will, in general, depend on the --- context in which it occurs. -charIsRepresentable :: TextEncoding -> Char -> IO Bool --- We force enc explicitly because `catch` is lazy in its --- first argument. We would probably like to force c as well, --- but unfortunately worker/wrapper produces very bad code for --- that. --- --- TODO If this function is performance-critical, it would probably --- pay to use a single-character specialization of withCString. That --- would allow worker/wrapper to actually eliminate Char boxes, and --- would also get rid of the completely unnecessary cons allocation. -charIsRepresentable !enc c = - withCString enc [c] - (\cstr -> do str <- peekCString enc cstr - case str of - [ch] | ch == c -> pure True - _ -> pure False) - `catch` - \(_ :: IOException) -> pure False - --- auxiliary definitions --- ---------------------- - --- C's end of string character -nUL :: CChar -nUL = 0 - --- Size of a CChar in bytes -cCharSize :: Int -cCharSize = sizeOf (undefined :: CChar) - - -{-# INLINE peekEncodedCString #-} -peekEncodedCString :: TextEncoding -- ^ Encoding of CString - -> CStringLen - -> IO String -- ^ String in Haskell terms -peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes) - = bracket mk_decoder close $ \decoder -> do - let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII - from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p) - to <- newCharBuffer chunk_size WriteBuffer - - let go !iteration from = do - (why, from', to') <- encode decoder from to - if isEmptyBuffer from' - then - -- No input remaining: @why@ will be InputUnderflow, but we don't care - withBuffer to' $ peekArray (bufferElems to') - else do - -- Input remaining: what went wrong? - putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why) - (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because - InputUnderflow -> recover decoder from' to' -- they indicate malformed/truncated input - OutputUnderflow -> return (from', to') -- We will have more space next time round - putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'') - putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'') - to_chars <- withBuffer to'' $ peekArray (bufferElems to'') - fmap (to_chars++) $ go (iteration + 1) from'' - - go (0 :: Int) from0 - -{-# INLINE withEncodedCString #-} -withEncodedCString :: TextEncoding -- ^ Encoding of CString to create - -> Bool -- ^ Null-terminate? - -> String -- ^ String to encode - -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory - -> IO a -withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act - = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do - from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - - let go !iteration to_sz_bytes = do - putDebugMsg ("withEncodedCString: " ++ show iteration) - allocaBytes to_sz_bytes $ \to_p -> do - -- See Note [Check *before* fill in withEncodedCString] about why - -- this is subtle. - mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes - case mb_res of - Nothing -> go (iteration + 1) (to_sz_bytes * 2) - Just to_buf -> withCStringBuffer to_buf null_terminate act - - -- If the input string is ASCII, this value will ensure we only allocate once - go (0 :: Int) (cCharSize * (sz + 1)) - -withCStringBuffer :: Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r -withCStringBuffer to_buf null_terminate act = do - let bytes = bufferElems to_buf - withBuffer to_buf $ \to_ptr -> do - when null_terminate $ pokeElemOff to_ptr (bufR to_buf) 0 - act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes* - -{-# INLINE newEncodedCString #-} -newEncodedCString :: TextEncoding -- ^ Encoding of CString to create - -> Bool -- ^ Null-terminate? - -> String -- ^ String to encode - -> IO CStringLen -newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s - = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do - from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - - let go !iteration to_p to_sz_bytes = do - putDebugMsg ("newEncodedCString: " ++ show iteration) - mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes - case mb_res of - Nothing -> do - let to_sz_bytes' = to_sz_bytes * 2 - to_p' <- reallocBytes to_p to_sz_bytes' - go (iteration + 1) to_p' to_sz_bytes' - Just to_buf -> withCStringBuffer to_buf null_terminate return - - -- If the input string is ASCII, this value will ensure we only allocate once - let to_sz_bytes = cCharSize * (sz + 1) - to_p <- mallocBytes to_sz_bytes - go (0 :: Int) to_p to_sz_bytes - - -tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int - -> IO (Maybe (Buffer Word8)) -tryFillBuffer encoder null_terminate from0 to_p to_sz_bytes = do - to_fp <- newForeignPtr_ to_p - go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer) - where - go !iteration (from, to) = do - (why, from', to') <- encode encoder from to - putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from') - if isEmptyBuffer from' - then if null_terminate && bufferAvailable to' == 0 - then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer - else return (Just to') - else case why of -- We didn't consume all of the input - InputUnderflow -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad - InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid - OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more -{- -Note [Check *before* fill in withEncodedCString] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important that the size check and readjustment peformed by tryFillBuffer -happens before the continuation is called. The size check is the part which can -fail, the call to the continuation never fails and so the caller should respond -first to the size check failing and *then* call the continuation. Making this evident -to the compiler avoids historic space leaks. - -In a previous iteration of this code we had a pattern that, somewhat simplified, -looked like this: - -go :: State -> (State -> IO a) -> IO a -go state action = - case tryFillBufferAndCall state action of - Left state' -> go state' action - Right result -> result - -`tryFillBufferAndCall` performed some checks, and then we either called action, -or we modified the state and tried again. -This went wrong because `action` can be a function closure containing a reference to -a lazy data structure. If we call action directly, without retaining any references -to action, that is fine. The data structure is consumed as it is produced and we operate -in constant space. - -However the failure branch `go state' action` *does* capture a reference to action. -This went wrong because the reference to action in the failure branch only becomes -unreachable *after* action returns. This means we keep alive the function closure -for `action` until `action` returns. Which in turn keeps alive the *whole* lazy list -via `action` until the action has fully run. -This went wrong in #20107, where the continuation kept an entire lazy bytestring alive -rather than allowing it to be incrementally consumed and collected. --} - +import GHC.Foreign.Internal diff --git a/GHC/Foreign/Internal.hs b/GHC/Foreign/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Foreign/Internal.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Foreign.Internal +-- Copyright : (c) The University of Glasgow, 2008-2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Foreign marshalling support for CStrings with configurable encodings +-- +----------------------------------------------------------------------------- + +module GHC.Foreign.Internal ( + -- * C strings with a configurable encoding + CString, CStringLen, + + -- * Conversion of C strings into Haskell strings + peekCString, + peekCStringLen, + + -- * Conversion of Haskell strings into C strings + newCString, + newCStringLen, + newCStringLen0, + + -- * Conversion of Haskell strings into C strings using temporary storage + withCString, + withCStringLen, + withCStringLen0, + withCStringsLen, + + charIsRepresentable, + ) where + +import Foreign.Marshal.Array +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable + +import Data.Word + +-- Imports for the locale-encoding version of marshallers + +import Data.Tuple (fst) + +import GHC.Show ( show ) + +import Foreign.Marshal.Alloc +import Foreign.ForeignPtr + +import GHC.Debug +import GHC.List +import GHC.Num +import GHC.Base + +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types + + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + +putDebugMsg :: String -> IO () +putDebugMsg | c_DEBUG_DUMP = debugLn + | otherwise = const (return ()) + + +-- | A C string is a reference to an array of C characters terminated by NUL. +type CString = Ptr CChar + +-- | A string with explicit length information in bytes instead of a +-- terminating NUL (allowing NUL characters in the middle of the string). +type CStringLen = (Ptr CChar, Int) + +-- exported functions +-- ------------------ + +-- | Marshal a NUL terminated C string into a Haskell string. +-- +peekCString :: TextEncoding -> CString -> IO String +peekCString enc cp = do + sz <- lengthArray0 nUL cp + peekEncodedCString enc (cp, sz * cCharSize) + +-- | Marshal a C string with explicit length into a Haskell string. +-- +peekCStringLen :: TextEncoding -> CStringLen -> IO String +peekCStringLen = peekEncodedCString + +-- | Marshal a Haskell string into a NUL terminated C string. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCString :: TextEncoding -> String -> IO CString +newCString enc = liftM fst . newEncodedCString enc True + +-- | Marshal a Haskell string into a C string (ie, character array) with +-- explicit length information. +-- +-- Note that this does not NUL terminate the resulting string. +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCStringLen :: TextEncoding -> String -> IO CStringLen +newCStringLen enc = newEncodedCString enc False + +-- | Marshal a Haskell string into a NUL terminated C string using temporary +-- storage. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a +withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp + +-- | Marshal a Haskell string into a C string (ie, character array) +-- in temporary storage, with explicit length information. +-- +-- Note that this does not NUL terminate the resulting string. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a +withCStringLen enc = withEncodedCString enc False + +-- | Marshal a Haskell string into a NUL-terminated C string (ie, character array) +-- with explicit length information. +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +-- @since 4.19.0.0 +newCStringLen0 :: TextEncoding -> String -> IO CStringLen +newCStringLen0 enc = newEncodedCString enc True + +-- | Marshal a Haskell string into a NUL-terminated C string (ie, character array) +-- in temporary storage, with explicit length information. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +-- @since 4.19.0.0 +withCStringLen0 :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a +withCStringLen0 enc = withEncodedCString enc True + +-- | Marshal a list of Haskell strings into an array of NUL terminated C strings +-- using temporary storage. +-- +-- * the Haskell strings may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCStringsLen :: TextEncoding + -> [String] + -> (Int -> Ptr CString -> IO a) + -> IO a +withCStringsLen enc strs f = go [] strs + where + go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss + go cs [] = withArrayLen (reverse cs) f + +-- | Determines whether a character can be accurately encoded in a +-- 'Foreign.C.String.CString'. +-- +-- Pretty much anyone who uses this function is in a state of sin because +-- whether or not a character is encodable will, in general, depend on the +-- context in which it occurs. +charIsRepresentable :: TextEncoding -> Char -> IO Bool +-- We force enc explicitly because `catch` is lazy in its +-- first argument. We would probably like to force c as well, +-- but unfortunately worker/wrapper produces very bad code for +-- that. +-- +-- TODO If this function is performance-critical, it would probably +-- pay to use a single-character specialization of withCString. That +-- would allow worker/wrapper to actually eliminate Char boxes, and +-- would also get rid of the completely unnecessary cons allocation. +charIsRepresentable !enc c = + withCString enc [c] + (\cstr -> do str <- peekCString enc cstr + case str of + [ch] | ch == c -> pure True + _ -> pure False) + `catch` + \(_ :: IOException) -> pure False + +-- auxiliary definitions +-- ---------------------- + +-- C's end of string character +nUL :: CChar +nUL = 0 + +-- Size of a CChar in bytes +cCharSize :: Int +cCharSize = sizeOf (undefined :: CChar) + + +{-# INLINE peekEncodedCString #-} +peekEncodedCString :: TextEncoding -- ^ Encoding of CString + -> CStringLen + -> IO String -- ^ String in Haskell terms +peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes) + = bracket mk_decoder close $ \decoder -> do + let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII + !from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p) + !to <- newCharBuffer chunk_size WriteBuffer + + let go !iteration !from = do + (why, from', !to') <- encode decoder from to + if isEmptyBuffer from' + then + -- No input remaining: @why@ will be InputUnderflow, but we don't care + withBuffer to' $ peekArray (bufferElems to') + else do + -- Input remaining: what went wrong? + putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why) + (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because + InputUnderflow -> recover decoder from' to' -- they indicate malformed/truncated input + OutputUnderflow -> return (from', to') -- We will have more space next time round + putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'') + putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'') + to_chars <- withBuffer to'' $ peekArray (bufferElems to'') + fmap (to_chars++) $ go (iteration + 1) from'' + + go (0 :: Int) from0 + +{-# INLINE withEncodedCString #-} +withEncodedCString :: TextEncoding -- ^ Encoding of CString to create + -> Bool -- ^ Null-terminate? + -> String -- ^ String to encode + -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory + -> IO a +withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act + = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do + from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p + + let go !iteration to_sz_bytes = do + putDebugMsg ("withEncodedCString: " ++ show iteration) + allocaBytes to_sz_bytes $ \to_p -> do + -- See Note [Check *before* fill in withEncodedCString] about why + -- this is subtle. + mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes + case mb_res of + Nothing -> go (iteration + 1) (to_sz_bytes * 2) + Just to_buf -> withCStringBuffer to_buf null_terminate act + + -- If the input string is ASCII, this value will ensure we only allocate once + go (0 :: Int) (cCharSize * (sz + 1)) + +withCStringBuffer :: Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r +withCStringBuffer to_buf null_terminate act = do + let bytes = bufferElems to_buf + withBuffer to_buf $ \to_ptr -> do + when null_terminate $ pokeElemOff to_ptr (bufR to_buf) 0 + act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes* + +{-# INLINE newEncodedCString #-} +newEncodedCString :: TextEncoding -- ^ Encoding of CString to create + -> Bool -- ^ Null-terminate? + -> String -- ^ String to encode + -> IO CStringLen +newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s + = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do + from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p + + let go !iteration to_p to_sz_bytes = do + putDebugMsg ("newEncodedCString: " ++ show iteration) + mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes + case mb_res of + Nothing -> do + let to_sz_bytes' = to_sz_bytes * 2 + to_p' <- reallocBytes to_p to_sz_bytes' + go (iteration + 1) to_p' to_sz_bytes' + Just to_buf -> withCStringBuffer to_buf null_terminate return + + -- If the input string is ASCII, this value will ensure we only allocate once + let to_sz_bytes = cCharSize * (sz + 1) + to_p <- mallocBytes to_sz_bytes + go (0 :: Int) to_p to_sz_bytes + + +tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int + -> IO (Maybe (Buffer Word8)) +tryFillBuffer encoder null_terminate from0 to_p !to_sz_bytes = do + !to_fp <- newForeignPtr_ to_p + go (0 :: Int) from0 (emptyBuffer to_fp to_sz_bytes WriteBuffer) + where + go !iteration !from !to = do + (why, from', to') <- encode encoder from to + putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from') + if isEmptyBuffer from' + then if null_terminate && bufferAvailable to' == 0 + then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer + else return (Just to') + else case why of -- We didn't consume all of the input + InputUnderflow -> recover encoder from' to' >>= \(a,b) -> go (iteration + 1) a b -- These conditions are equally bad + InvalidSequence -> recover encoder from' to' >>= \(a,b) -> go (iteration + 1) a b -- since the input was truncated/invalid + OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more +{- +Note [Check *before* fill in withEncodedCString] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important that the size check and readjustment peformed by tryFillBuffer +happens before the continuation is called. The size check is the part which can +fail, the call to the continuation never fails and so the caller should respond +first to the size check failing and *then* call the continuation. Making this evident +to the compiler avoids historic space leaks. + +In a previous iteration of this code we had a pattern that, somewhat simplified, +looked like this: + +go :: State -> (State -> IO a) -> IO a +go state action = + case tryFillBufferAndCall state action of + Left state' -> go state' action + Right result -> result + +`tryFillBufferAndCall` performed some checks, and then we either called action, +or we modified the state and tried again. +This went wrong because `action` can be a function closure containing a reference to +a lazy data structure. If we call action directly, without retaining any references +to action, that is fine. The data structure is consumed as it is produced and we operate +in constant space. + +However the failure branch `go state' action` *does* capture a reference to action. +This went wrong because the reference to action in the failure branch only becomes +unreachable *after* action returns. This means we keep alive the function closure +for `action` until `action` returns. Which in turn keeps alive the *whole* lazy list +via `action` until the action has fully run. +This went wrong in #20107, where the continuation kept an entire lazy bytestring alive +rather than allowing it to be incrementally consumed and collected. +-} + diff --git a/GHC/IO/Device.hs b/GHC/IO/Device.hs --- a/GHC/IO/Device.hs +++ b/GHC/IO/Device.hs @@ -35,7 +35,7 @@ -- | A low-level I/O provider where the data is bytes in memory. -- The Word64 offsets currently have no effect on POSIX system or consoles --- where the implicit behaviour of the C runtime is assume to move the file +-- where the implicit behaviour of the C runtime is assumed to move the file -- pointer on every read/write without needing an explicit seek. class RawIO a where -- | Read up to the specified number of bytes starting from a specified @@ -107,7 +107,7 @@ -- | some devices (e.g. terminals) support a "raw" mode where -- characters entered are immediately made available to the program. - -- If available, this operations enables raw mode. + -- If available, this operation enables raw mode. setRaw :: a -> Bool -> IO () setRaw _ _ = ioe_unsupportedOperation diff --git a/GHC/IO/Encoding.hs b/GHC/IO/Encoding.hs --- a/GHC/IO/Encoding.hs +++ b/GHC/IO/Encoding.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- @@ -268,7 +269,7 @@ -- -- 2. If the underlying encoding is not itself roundtrippable, this mechanism -- can fail. Roundtrippable encodings are those which have an injective mapping --- into Unicode. Almost all encodings meet this criteria, but some do not. Notably, +-- into Unicode. Almost all encodings meet this criterion, but some do not. Notably, -- Shift-JIS (CP932) and Big5 contain several different encodings of the same -- Unicode codepoint. -- @@ -336,11 +337,13 @@ latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) -latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8 +latin1_encode input output = IO $ \st -> case Latin1.latin1_encode input output st of + (# st', _why, input', output' #) -> (# st', (input', output') #) -- unchecked, used for char8 --latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) -latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output +latin1_decode input output = IO $ \st -> case Latin1.latin1_decode input output st of + (# st', _why, input', output' #) -> (# st', (input',output') #) --latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode unknownEncodingErr :: String -> IO a diff --git a/GHC/IO/Encoding/CodePage/API.hs b/GHC/IO/Encoding/CodePage/API.hs --- a/GHC/IO/Encoding/CodePage/API.hs +++ b/GHC/IO/Encoding/CodePage/API.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, NondecreasingIndentation, - RecordWildCards, ScopedTypeVariables #-} + RecordWildCards, ScopedTypeVariables, + UnboxedTuples #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module GHC.IO.Encoding.CodePage.API ( @@ -157,11 +158,15 @@ utf16_native_encode' :: EncodeBuffer utf16_native_decode' :: DecodeBuffer #if defined(WORDS_BIGENDIAN) -utf16_native_encode' = utf16be_encode -utf16_native_decode' = utf16be_decode +utf16_native_encode' i o = IO $ \st -> case utf16be_encode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) +utf16_native_decode' i o = IO $ \st -> case utf16be_decode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) #else -utf16_native_encode' = utf16le_encode -utf16_native_decode' = utf16le_decode +utf16_native_encode' i o = IO $ \st -> case utf16le_encode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) +utf16_native_decode' i o = IO $ \st -> case utf16le_decode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) #endif saner :: CodeBuffer from to diff --git a/GHC/IO/Encoding/Failure.hs b/GHC/IO/Encoding/Failure.hs --- a/GHC/IO/Encoding/Failure.hs +++ b/GHC/IO/Encoding/Failure.hs @@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -18,7 +21,8 @@ module GHC.IO.Encoding.Failure ( CodingFailureMode(..), codingFailureModeSuffix, isSurrogate, - recoverDecode, recoverEncode + recoverDecode, recoverEncode, + recoverDecode#, recoverEncode#, ) where import GHC.IO @@ -142,6 +146,12 @@ | otherwise = Nothing where x = ord c +recoverDecode# :: CodingFailureMode -> Buffer Word8 -> Buffer Char + -> State# RealWorld -> (# State# RealWorld, Buffer Word8, Buffer Char #) +recoverDecode# cfm input output st = + let !(# st', (bIn, bOut) #) = unIO (recoverDecode cfm input output) st + in (# st', bIn, bOut #) + recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char) recoverDecode cfm input@Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } @@ -159,6 +169,12 @@ b <- readWord8Buf iraw ir ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b) return (input { bufL=ir+1 }, output { bufR=ow' }) + +recoverEncode# :: CodingFailureMode -> Buffer Char -> Buffer Word8 + -> State# RealWorld -> (# State# RealWorld, Buffer Char, Buffer Word8 #) +recoverEncode# cfm input output st = + let !(# st', (bIn, bOut) #) = unIO (recoverEncode cfm input output) st + in (# st', bIn, bOut #) recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8) diff --git a/GHC/IO/Encoding/Iconv.hs b/GHC/IO/Encoding/Iconv.hs --- a/GHC/IO/Encoding/Iconv.hs +++ b/GHC/IO/Encoding/Iconv.hs @@ -2,6 +2,8 @@ {-# LANGUAGE CPP , NoImplicitPrelude , NondecreasingIndentation + , UnboxedTuples + , MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} @@ -133,19 +135,24 @@ withCAString to $ \ to_str -> do iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt - return BufferCodec{ - encode = fn iconvt, - recover = rec, - close = iclose, + fn_iconvt ibuf obuf st = case unIO (fn iconvt ibuf obuf) st of + (# st', (prog, ibuf', obuf') #) -> (# st', prog, ibuf', obuf' #) + return BufferCodec# { + encode# = fn_iconvt, + recover# = rec#, + close# = iclose, -- iconv doesn't supply a way to save/restore the state - getState = return (), - setState = const $ return () + getState# = return (), + setState# = const $ return () } + where + rec# ibuf obuf st = case unIO (rec ibuf obuf) st of + (# st', (ibuf', obuf') #) -> (# st', ibuf', obuf' #) -iconvDecode :: IConv -> DecodeBuffer +iconvDecode :: IConv -> Buffer Word8 -> Buffer Char -> IO (CodingProgress, Buffer Word8, Buffer Char) iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift -iconvEncode :: IConv -> EncodeBuffer +iconvEncode :: IConv -> Buffer Char -> Buffer Word8 -> IO (CodingProgress, Buffer Char, Buffer Word8) iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int diff --git a/GHC/IO/Encoding/Latin1.hs b/GHC/IO/Encoding/Latin1.hs --- a/GHC/IO/Encoding/Latin1.hs +++ b/GHC/IO/Encoding/Latin1.hs @@ -2,6 +2,8 @@ {-# LANGUAGE NoImplicitPrelude , BangPatterns , NondecreasingIndentation + , UnboxedTuples + , MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -56,22 +58,22 @@ latin1_DF :: CodingFailureMode -> IO (TextDecoder ()) latin1_DF cfm = - return (BufferCodec { - encode = latin1_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) latin1_EF :: CodingFailureMode -> IO (TextEncoder ()) latin1_EF cfm = - return (BufferCodec { - encode = latin1_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) latin1_checked :: TextEncoding @@ -85,12 +87,12 @@ latin1_checked_EF :: CodingFailureMode -> IO (TextEncoder ()) latin1_checked_EF cfm = - return (BufferCodec { - encode = latin1_checked_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_checked_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -- ----------------------------------------------------------------------------- @@ -108,22 +110,22 @@ ascii_DF :: CodingFailureMode -> IO (TextDecoder ()) ascii_DF cfm = - return (BufferCodec { - encode = ascii_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = ascii_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) ascii_EF :: CodingFailureMode -> IO (TextEncoder ()) ascii_EF cfm = - return (BufferCodec { - encode = ascii_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = ascii_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) @@ -134,97 +136,115 @@ -- TODO: Eliminate code duplication between the checked and unchecked -- versions of the decoder or encoder (but don't change the Core!) -latin1_decode :: DecodeBuffer +latin1_decode :: DecodeBuffer# latin1_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 + !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -ascii_decode :: DecodeBuffer +ascii_decode :: DecodeBuffer# ascii_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - if c0 > 0x7f then invalid else do - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 + if c0 > 0x7f then invalid st1 else do + let !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -latin1_encode :: EncodeBuffer +latin1_encode :: EncodeBuffer# latin1_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - writeWord8Buf oraw ow (fromIntegral (ord c)) - loop ir' (ow+1) + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (ord c))) st1 + loop ir' (ow+1) st2 in - loop ir0 ow0 + loop ir0 ow0 st -latin1_checked_encode :: EncodeBuffer +latin1_checked_encode :: EncodeBuffer# latin1_checked_encode input output = single_byte_checked_encode 0xff input output -ascii_encode :: EncodeBuffer +ascii_encode :: EncodeBuffer# ascii_encode input output = single_byte_checked_encode 0x7f input output -single_byte_checked_encode :: Int -> EncodeBuffer +single_byte_checked_encode :: Int -> EncodeBuffer# single_byte_checked_encode max_legal_char input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if ord c > max_legal_char then invalid else do - writeWord8Buf oraw ow (fromIntegral (ord c)) - loop ir' (ow+1) + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if ord c > max_legal_char then invalid st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (ord c))) st1 + loop ir' (ow+1) st2 where - invalid = done InvalidSequence ir ow + invalid :: EncodingBuffer# + invalid st' = done InvalidSequence ir ow st' in - loop ir0 ow0 + loop ir0 ow0 st {-# INLINE single_byte_checked_encode #-} diff --git a/GHC/IO/Encoding/Types.hs b/GHC/IO/Encoding/Types.hs --- a/GHC/IO/Encoding/Types.hs +++ b/GHC/IO/Encoding/Types.hs @@ -1,6 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-} {-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE UnboxedTuples, MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -17,11 +20,13 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding.Types ( - BufferCodec(..), + BufferCodec(.., BufferCodec, encode, recover, close, getState, setState), TextEncoding(..), TextEncoder, TextDecoder, CodeBuffer, EncodeBuffer, DecodeBuffer, - CodingProgress(..) + CodingProgress(..), + DecodeBuffer#, EncodeBuffer#, + DecodingBuffer#, EncodingBuffer# ) where import GHC.Base @@ -33,8 +38,8 @@ -- ----------------------------------------------------------------------------- -- Text encoders/decoders -data BufferCodec from to state = BufferCodec { - encode :: CodeBuffer from to, +data BufferCodec from to state = BufferCodec# { + encode# :: CodeBuffer# from to, -- ^ The @encode@ function translates elements of the buffer @from@ -- to the buffer @to@. It should translate as many elements as possible -- given the sizes of the buffers, including translating zero elements @@ -50,7 +55,7 @@ -- library in order to report translation errors at the point they -- actually occur, rather than when the buffer is translated. - recover :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to), + recover# :: Buffer from -> Buffer to -> State# RealWorld -> (# State# RealWorld, Buffer from, Buffer to #), -- ^ The @recover@ function is used to continue decoding -- in the presence of invalid or unrepresentable sequences. This includes -- both those detected by @encode@ returning @InvalidSequence@ and those @@ -69,12 +74,12 @@ -- -- @since 4.4.0.0 - close :: IO (), + close# :: IO (), -- ^ Resources associated with the encoding may now be released. -- The @encode@ function may not be called again after calling -- @close@. - getState :: IO state, + getState# :: IO state, -- ^ Return the current state of the codec. -- -- Many codecs are not stateful, and in these case the state can be @@ -87,15 +92,23 @@ -- beginning), and if not, whether to use the big or little-endian -- encoding. - setState :: state -> IO () + setState# :: state -> IO () -- restore the state of the codec using the state from a previous -- call to 'getState'. } -type CodeBuffer from to = Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to) -type DecodeBuffer = CodeBuffer Word8 Char -type EncodeBuffer = CodeBuffer Char Word8 +type CodeBuffer from to = Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to) +type DecodeBuffer = CodeBuffer Word8 Char +type EncodeBuffer = CodeBuffer Char Word8 +type CodeBuffer# from to = Buffer from -> Buffer to -> State# RealWorld -> (# State# RealWorld, CodingProgress, Buffer from, Buffer to #) +type DecodeBuffer# = CodeBuffer# Word8 Char +type EncodeBuffer# = CodeBuffer# Char Word8 + +type CodingBuffer# from to = State# RealWorld -> (# State# RealWorld, CodingProgress, Buffer from, Buffer to #) +type DecodingBuffer# = CodingBuffer# Word8 Char +type EncodingBuffer# = CodingBuffer# Char Word8 + type TextDecoder state = BufferCodec Word8 CharBufElem state type TextEncoder state = BufferCodec CharBufElem Word8 state @@ -119,7 +132,6 @@ -- | @since 4.3.0.0 instance Show TextEncoding where - -- | Returns the value of 'textEncodingName' show te = textEncodingName te -- | @since 4.4.0.0 @@ -133,3 +145,30 @@ , Show -- ^ @since 4.4.0.0 ) +{-# COMPLETE BufferCodec #-} +pattern BufferCodec :: CodeBuffer from to + -> (Buffer from -> Buffer to -> IO (Buffer from, Buffer to)) + -> IO () + -> IO state + -> (state -> IO ()) + -> BufferCodec from to state +pattern BufferCodec{encode, recover, close, getState, setState} <- + BufferCodec# (getEncode -> encode) (getRecover -> recover) close getState setState + where + BufferCodec e r c g s = BufferCodec# (mkEncode e) (mkRecover r) c g s + +getEncode :: CodeBuffer# from to -> CodeBuffer from to +getEncode e i o = IO $ \st -> + let !(# st', prog, i', o' #) = e i o st in (# st', (prog, i', o') #) + +getRecover :: (Buffer from -> Buffer to -> State# RealWorld -> (# State# RealWorld, Buffer from, Buffer to #)) + -> (Buffer from -> Buffer to -> IO (Buffer from, Buffer to)) +getRecover r i o = IO $ \st -> + let !(# st', i', o' #) = r i o st in (# st', (i', o') #) + +mkEncode :: CodeBuffer from to -> CodeBuffer# from to +mkEncode e i o st = let !(# st', (prog, i', o') #) = unIO (e i o) st in (# st', prog, i', o' #) + +mkRecover :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to)) + -> (Buffer from -> Buffer to -> State# RealWorld -> (# State# RealWorld, Buffer from, Buffer to #)) +mkRecover r i o st = let !(# st', (i', o') #) = unIO (r i o) st in (# st', i', o' #) diff --git a/GHC/IO/Encoding/UTF16.hs b/GHC/IO/Encoding/UTF16.hs --- a/GHC/IO/Encoding/UTF16.hs +++ b/GHC/IO/Encoding/UTF16.hs @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -61,64 +62,66 @@ mkTextDecoder = utf16_DF cfm, mkTextEncoder = utf16_EF cfm } -utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer#)) utf16_DF cfm = do seen_bom <- newIORef Nothing - return (BufferCodec { - encode = utf16_decode seen_bom, - recover = recoverDecode cfm, - close = return (), - getState = readIORef seen_bom, - setState = writeIORef seen_bom + return (BufferCodec# { + encode# = utf16_decode seen_bom, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef seen_bom, + setState# = writeIORef seen_bom }) utf16_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf16_EF cfm = do done_bom <- newIORef False - return (BufferCodec { - encode = utf16_encode done_bom, - recover = recoverEncode cfm, - close = return (), - getState = readIORef done_bom, - setState = writeIORef done_bom + return (BufferCodec# { + encode# = utf16_encode done_bom, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef done_bom, + setState# = writeIORef done_bom }) -utf16_encode :: IORef Bool -> EncodeBuffer +utf16_encode :: IORef Bool -> EncodeBuffer# utf16_encode done_bom input output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef done_bom - if b then utf16_native_encode input output + let !(# st1, b #) = unIO (readIORef done_bom) st0 + if b then utf16_native_encode input output st1 else if os - ow < 2 - then return (OutputUnderflow,input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef done_bom True - writeWord8Buf oraw ow bom1 - writeWord8Buf oraw (ow+1) bom2 - utf16_native_encode input output{ bufR = ow+2 } + let !(# st2, () #) = unIO (writeIORef done_bom True) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom2) st3 + utf16_native_encode input output{ bufR = ow+2 } st4 -utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf16_decode :: IORef (Maybe DecodeBuffer#) -> DecodeBuffer# utf16_decode seen_bom input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - mb <- readIORef seen_bom + let !(# st1, mb #) = unIO (readIORef seen_bom) st0 case mb of - Just decode -> decode input output + Just decode -> decode input output st1 Nothing -> - if iw - ir < 2 then return (InputUnderflow,input,output) else do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) + if iw - ir < 2 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir ) st1 + !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 case () of - _ | c0 == bomB && c1 == bomL -> do - writeIORef seen_bom (Just utf16be_decode) - utf16be_decode input{ bufL= ir+2 } output - | c0 == bomL && c1 == bomB -> do - writeIORef seen_bom (Just utf16le_decode) - utf16le_decode input{ bufL= ir+2 } output - | otherwise -> do - writeIORef seen_bom (Just utf16_native_decode) - utf16_native_decode input output + _ | c0 == bomB && c1 == bomL -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16be_decode)) st3 + in utf16be_decode input{ bufL= ir+2 } output st4 + | c0 == bomL && c1 == bomB -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16le_decode)) st3 + in utf16le_decode input{ bufL= ir+2 } output st4 + | otherwise -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16_native_decode)) st3 + in utf16_native_decode input output st4 bomB, bomL, bom1, bom2 :: Word8 @@ -126,10 +129,10 @@ bomL = 0xff -- choose UTF-16BE by default for UTF-16 output -utf16_native_decode :: DecodeBuffer +utf16_native_decode :: DecodeBuffer# utf16_native_decode = utf16be_decode -utf16_native_encode :: EncodeBuffer +utf16_native_encode :: EncodeBuffer# utf16_native_encode = utf16be_encode bom1 = bomB @@ -149,22 +152,22 @@ utf16be_DF :: CodingFailureMode -> IO (TextDecoder ()) utf16be_DF cfm = - return (BufferCodec { - encode = utf16be_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16be_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16be_EF :: CodingFailureMode -> IO (TextEncoder ()) utf16be_EF cfm = - return (BufferCodec { - encode = utf16be_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16be_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16le :: TextEncoding @@ -178,114 +181,127 @@ utf16le_DF :: CodingFailureMode -> IO (TextDecoder ()) utf16le_DF cfm = - return (BufferCodec { - encode = utf16le_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16le_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16le_EF :: CodingFailureMode -> IO (TextEncoder ()) utf16le_EF cfm = - return (BufferCodec { - encode = utf16le_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16le_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -utf16be_decode :: DecodeBuffer +utf16be_decode :: DecodeBuffer# utf16be_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | ir + 1 == iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1 if validate1 x1 - then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) - loop (ir+2) ow' - else if iw - ir < 4 then done InputUnderflow ir ow else do - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 - if not (validate2 x1 x2) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 x1 x2) - loop (ir+4) ow' + then let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral x1))) st2 + in loop (ir+2) ow' st3 + else if iw - ir < 4 then done InputUnderflow ir ow st2 else do + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 + if not (validate2 x1 x2) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr2 x1 x2)) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input { bufL = 0, bufR = 0 } else input { bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf16le_decode :: DecodeBuffer +utf16le_decode :: DecodeBuffer# utf16le_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | ir + 1 == iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 if validate1 x1 - then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) - loop (ir+2) ow' - else if iw - ir < 4 then done InputUnderflow ir ow else do - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 - if not (validate2 x1 x2) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 x1 x2) - loop (ir+4) ow' + then let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral x1))) st2 + in loop (ir+2) ow' st3 + else if iw - ir < 4 then done InputUnderflow ir ow st2 else do + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 + if not (validate2 x1 x2) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr2 x1 x2)) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf16be_encode :: EncodeBuffer +utf16be_encode :: EncodeBuffer# utf16be_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 2 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of - x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do - writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8)) - writeWord8Buf oraw (ow+1) (fromIntegral x) - loop ir' (ow+2) + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8))) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) (fromIntegral x)) st2 + loop ir' (ow+2) st3 | otherwise -> do - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) @@ -294,35 +310,39 @@ c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) c4 = fromIntegral n2 -- - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - writeWord8Buf oraw (ow+3) c4 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c4) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -utf16le_encode :: EncodeBuffer +utf16le_encode :: EncodeBuffer# utf16le_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 2 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of - x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do - writeWord8Buf oraw ow (fromIntegral x) - writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) - loop ir' (ow+2) + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral x)) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))) st2 + loop ir' (ow+2) st3 | otherwise -> - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) @@ -331,13 +351,13 @@ c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) c4 = fromIntegral n2 -- - writeWord8Buf oraw ow c2 - writeWord8Buf oraw (ow+1) c1 - writeWord8Buf oraw (ow+2) c4 - writeWord8Buf oraw (ow+3) c3 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c2) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c4) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c3) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st chr2 :: Word16 -> Word16 -> Char chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) diff --git a/GHC/IO/Encoding/UTF32.hs b/GHC/IO/Encoding/UTF32.hs --- a/GHC/IO/Encoding/UTF32.hs +++ b/GHC/IO/Encoding/UTF32.hs @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -61,68 +62,70 @@ mkTextDecoder = utf32_DF cfm, mkTextEncoder = utf32_EF cfm } -utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer#)) utf32_DF cfm = do seen_bom <- newIORef Nothing - return (BufferCodec { - encode = utf32_decode seen_bom, - recover = recoverDecode cfm, - close = return (), - getState = readIORef seen_bom, - setState = writeIORef seen_bom + return (BufferCodec# { + encode# = utf32_decode seen_bom, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef seen_bom, + setState# = writeIORef seen_bom }) utf32_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf32_EF cfm = do done_bom <- newIORef False - return (BufferCodec { - encode = utf32_encode done_bom, - recover = recoverEncode cfm, - close = return (), - getState = readIORef done_bom, - setState = writeIORef done_bom + return (BufferCodec# { + encode# = utf32_encode done_bom, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef done_bom, + setState# = writeIORef done_bom }) -utf32_encode :: IORef Bool -> EncodeBuffer +utf32_encode :: IORef Bool -> EncodeBuffer# utf32_encode done_bom input output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef done_bom - if b then utf32_native_encode input output + let !(# st1, b #) = unIO (readIORef done_bom) st0 + if b then utf32_native_encode input output st1 else if os - ow < 4 - then return (OutputUnderflow, input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef done_bom True - writeWord8Buf oraw ow bom0 - writeWord8Buf oraw (ow+1) bom1 - writeWord8Buf oraw (ow+2) bom2 - writeWord8Buf oraw (ow+3) bom3 - utf32_native_encode input output{ bufR = ow+4 } + let !(# st2, () #) = unIO (writeIORef done_bom True) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom0) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+2) bom2) st4 + !(# st6, () #) = unIO (writeWord8Buf oraw (ow+3) bom3) st5 + utf32_native_encode input output{ bufR = ow+4 } st6 -utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf32_decode :: IORef (Maybe DecodeBuffer#) -> DecodeBuffer# utf32_decode seen_bom input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - mb <- readIORef seen_bom + let !(# st1, mb #) = unIO (readIORef seen_bom) st0 case mb of - Just decode -> decode input output + Just decode -> decode input output st1 Nothing -> - if iw - ir < 4 then return (InputUnderflow, input,output) else do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + if iw - ir < 4 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir ) st1 + !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 + !(# st4, c2 #) = unIO (readWord8Buf iraw (ir+2)) st3 + !(# st5, c3 #) = unIO (readWord8Buf iraw (ir+3)) st4 case () of - _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do - writeIORef seen_bom (Just utf32be_decode) - utf32be_decode input{ bufL= ir+4 } output - _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do - writeIORef seen_bom (Just utf32le_decode) - utf32le_decode input{ bufL= ir+4 } output - | otherwise -> do - writeIORef seen_bom (Just utf32_native_decode) - utf32_native_decode input output + _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32be_decode)) st5 + in utf32be_decode input{ bufL= ir+4 } output st6 + _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32le_decode)) st5 + in utf32le_decode input{ bufL= ir+4 } output st6 + | otherwise -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32_native_decode)) st5 + in utf32_native_decode input output st6 bom0, bom1, bom2, bom3 :: Word8 @@ -132,10 +135,10 @@ bom3 = 0xff -- choose UTF-32BE by default for UTF-32 output -utf32_native_decode :: DecodeBuffer +utf32_native_decode :: DecodeBuffer# utf32_native_decode = utf32be_decode -utf32_native_encode :: EncodeBuffer +utf32_native_encode :: EncodeBuffer# utf32_native_encode = utf32be_encode -- ----------------------------------------------------------------------------- @@ -152,22 +155,22 @@ utf32be_DF :: CodingFailureMode -> IO (TextDecoder ()) utf32be_DF cfm = - return (BufferCodec { - encode = utf32be_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32be_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf32be_EF :: CodingFailureMode -> IO (TextEncoder ()) utf32be_EF cfm = - return (BufferCodec { - encode = utf32be_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32be_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) @@ -182,128 +185,145 @@ utf32le_DF :: CodingFailureMode -> IO (TextDecoder ()) utf32le_DF cfm = - return (BufferCodec { - encode = utf32le_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32le_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf32le_EF :: CodingFailureMode -> IO (TextEncoder ()) utf32le_EF cfm = - return (BufferCodec { - encode = utf32le_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32le_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -utf32be_decode :: DecodeBuffer +utf32be_decode :: DecodeBuffer# utf32be_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | iw - ir < 4 = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | iw - ir < 4 = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 let x1 = chr4 c0 c1 c2 c3 - if not (validate x1) then invalid else do - ow' <- writeCharBuf oraw ow x1 - loop (ir+4) ow' + if not (validate x1) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow x1) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf32le_decode :: DecodeBuffer +utf32le_decode :: DecodeBuffer# utf32le_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | iw - ir < 4 = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | iw - ir < 4 = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 let x1 = chr4 c3 c2 c1 c0 - if not (validate x1) then invalid else do - ow' <- writeCharBuf oraw ow x1 - loop (ir+4) ow' + if not (validate x1) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow x1) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf32be_encode :: EncodeBuffer +utf32be_encode :: EncodeBuffer# utf32be_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 4 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 4 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if isSurrogate c then done InvalidSequence ir ow else do + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if isSurrogate c then done InvalidSequence ir ow st1 else do let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c0 - writeWord8Buf oraw (ow+1) c1 - writeWord8Buf oraw (ow+2) c2 - writeWord8Buf oraw (ow+3) c3 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c0) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c2) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c3) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -utf32le_encode :: EncodeBuffer +utf32le_encode :: EncodeBuffer# utf32le_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 4 = done OutputUnderflow ir ow + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 4 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if isSurrogate c then done InvalidSequence ir ow else do + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if isSurrogate c then done InvalidSequence ir ow st1 else do let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c3 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c1 - writeWord8Buf oraw (ow+3) c0 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c3) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c0) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = diff --git a/GHC/IO/Encoding/UTF8.hs b/GHC/IO/Encoding/UTF8.hs --- a/GHC/IO/Encoding/UTF8.hs +++ b/GHC/IO/Encoding/UTF8.hs @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -56,22 +57,22 @@ utf8_DF :: CodingFailureMode -> IO (TextDecoder ()) utf8_DF cfm = - return (BufferCodec { - encode = utf8_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf8_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf8_EF :: CodingFailureMode -> IO (TextEncoder ()) utf8_EF cfm = - return (BufferCodec { - encode = utf8_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf8_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf8_bom :: TextEncoding @@ -85,177 +86,188 @@ utf8_bom_DF :: CodingFailureMode -> IO (TextDecoder Bool) utf8_bom_DF cfm = do ref <- newIORef True - return (BufferCodec { - encode = utf8_bom_decode ref, - recover = recoverDecode cfm, - close = return (), - getState = readIORef ref, - setState = writeIORef ref + return (BufferCodec# { + encode# = utf8_bom_decode ref, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef ref, + setState# = writeIORef ref }) utf8_bom_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf8_bom_EF cfm = do ref <- newIORef True - return (BufferCodec { - encode = utf8_bom_encode ref, - recover = recoverEncode cfm, - close = return (), - getState = readIORef ref, - setState = writeIORef ref + return (BufferCodec# { + encode# = utf8_bom_encode ref, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef ref, + setState# = writeIORef ref }) -utf8_bom_decode :: IORef Bool -> DecodeBuffer +utf8_bom_decode :: IORef Bool -> DecodeBuffer# utf8_bom_decode ref input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - first <- readIORef ref + let !(# st1, first #) = unIO (readIORef ref) st0 if not first - then utf8_decode input output + then utf8_decode input output st1 else do - let no_bom = do writeIORef ref False; utf8_decode input output - if iw - ir < 1 then return (InputUnderflow,input,output) else do - c0 <- readWord8Buf iraw ir + let no_bom = let !(# st', () #) = unIO (writeIORef ref False) st1 in utf8_decode input output st' + if iw - ir < 1 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir) st1 if (c0 /= bom0) then no_bom else do - if iw - ir < 2 then return (InputUnderflow,input,output) else do - c1 <- readWord8Buf iraw (ir+1) + if iw - ir < 2 then (# st2,InputUnderflow,input,output #) else do + let !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 if (c1 /= bom1) then no_bom else do - if iw - ir < 3 then return (InputUnderflow,input,output) else do - c2 <- readWord8Buf iraw (ir+2) + if iw - ir < 3 then (# st3,InputUnderflow,input,output #) else do + let !(# st4, c2 #) = unIO (readWord8Buf iraw (ir+2)) st3 if (c2 /= bom2) then no_bom else do -- found a BOM, ignore it and carry on - writeIORef ref False - utf8_decode input{ bufL = ir + 3 } output + let !(# st5, () #) = unIO (writeIORef ref False) st4 + utf8_decode input{ bufL = ir + 3 } output st5 -utf8_bom_encode :: IORef Bool -> EncodeBuffer +utf8_bom_encode :: IORef Bool -> EncodeBuffer# utf8_bom_encode ref input output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef ref - if not b then utf8_encode input output + let !(# st1, b #) = unIO (readIORef ref) st0 + if not b then utf8_encode input output st1 else if os - ow < 3 - then return (OutputUnderflow,input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef ref False - writeWord8Buf oraw ow bom0 - writeWord8Buf oraw (ow+1) bom1 - writeWord8Buf oraw (ow+2) bom2 - utf8_encode input output{ bufR = ow+3 } + let !(# st2, () #) = unIO (writeIORef ref False) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom0) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+2) bom2) st4 + utf8_encode input output{ bufR = ow+3 } st5 bom0, bom1, bom2 :: Word8 bom0 = 0xef bom1 = 0xbb bom2 = 0xbf -utf8_decode :: DecodeBuffer +utf8_decode :: DecodeBuffer# utf8_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 case c0 of _ | c0 <= 0x7f -> do - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' - | c0 >= 0xc0 && c0 <= 0xc1 -> invalid -- Overlong forms + let !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 + | c0 >= 0xc0 && c0 <= 0xc1 -> invalid st1 -- Overlong forms | c0 >= 0xc2 && c0 <= 0xdf -> - if iw - ir < 2 then done InputUnderflow ir ow else do - c1 <- readWord8Buf iraw (ir+1) - if (c1 < 0x80 || c1 >= 0xc0) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 c0 c1) - loop (ir+2) ow' + if iw - ir < 2 then done InputUnderflow ir ow st1 else do + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + if (c1 < 0x80 || c1 >= 0xc0) then invalid st2 else do + let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (chr2 c0 c1)) st2 + loop (ir+2) ow' st3 | c0 >= 0xe0 && c0 <= 0xef -> case iw - ir of - 1 -> done InputUnderflow ir ow + 1 -> done InputUnderflow ir ow st1 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) - c1 <- readWord8Buf iraw (ir+1) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 if not (validate3 c0 c1 0x80) - then invalid else done InputUnderflow ir ow + then invalid st2 else done InputUnderflow ir ow st2 _ -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - if not (validate3 c0 c1 c2) then invalid else do - ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2) - loop (ir+3) ow' + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + if not (validate3 c0 c1 c2) then invalid st3 else do + let !(# st4, ow' #) = unIO (writeCharBuf oraw ow (chr3 c0 c1 c2)) st3 + loop (ir+3) ow' st4 | c0 >= 0xf0 -> case iw - ir of - 1 -> done InputUnderflow ir ow + 1 -> done InputUnderflow ir ow st1 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) - c1 <- readWord8Buf iraw (ir+1) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 if not (validate4 c0 c1 0x80 0x80) - then invalid else done InputUnderflow ir ow + then invalid st2 else done InputUnderflow ir ow st2 3 -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 if not (validate4 c0 c1 c2 0x80) - then invalid else done InputUnderflow ir ow + then invalid st3 else done InputUnderflow ir ow st3 _ -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - if not (validate4 c0 c1 c2 c3) then invalid else do - ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3) - loop (ir+4) ow' + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + if not (validate4 c0 c1 c2 c3) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr4 c0 c1 c2 c3)) st4 + loop (ir+4) ow' st5 | otherwise -> - invalid + invalid st1 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0} else input{ bufL = ir } + !ro = output { bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf8_encode :: EncodeBuffer +utf8_encode :: EncodeBuffer# utf8_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of x | x <= 0x7F -> do - writeWord8Buf oraw ow (fromIntegral x) - loop ir' (ow+1) + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral x)) st1 + loop ir' (ow+1) st2 | x <= 0x07FF -> - if os - ow < 2 then done OutputUnderflow ir ow else do + if os - ow < 2 then done OutputUnderflow ir ow st1 else do let (c1,c2) = ord2 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - loop ir' (ow+2) - | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow else do - if os - ow < 3 then done OutputUnderflow ir ow else do + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + loop ir' (ow+2) st3 + | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow st1 else do + if os - ow < 3 then done OutputUnderflow ir ow st1 else do let (c1,c2,c3) = ord3 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - loop ir' (ow+3) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + loop ir' (ow+3) st4 | otherwise -> do - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let (c1,c2,c3,c4) = ord4 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - writeWord8Buf oraw (ow+3) c4 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c4) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -- ----------------------------------------------------------------------------- -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8 diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -571,7 +571,7 @@ readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtr loc !fd !buf !off !len #if defined(javascript_HOST_ARCH) - = fmap fromIntegral . uninterruptibleMask_ $ + = fmap fromIntegral . mask_ $ throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len) #else | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block @@ -593,7 +593,7 @@ readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtrNoBlock loc !fd !buf !off !len #if defined(javascript_HOST_ARCH) - = uninterruptibleMask_ $ do + = mask_ $ do r <- throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len) case r of (-1) -> return 0 @@ -618,7 +618,7 @@ writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr loc !fd !buf !off !len #if defined(javascript_HOST_ARCH) - = fmap fromIntegral . uninterruptibleMask_ $ + = fmap fromIntegral . mask_ $ throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len) #else | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block @@ -638,7 +638,7 @@ writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtrNoBlock loc !fd !buf !off !len #if defined(javascript_HOST_ARCH) - = uninterruptibleMask_ $ do + = mask_ $ do r <- throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len) case r of (-1) -> return 0 diff --git a/GHC/IO/Handle.hs b/GHC/IO/Handle.hs --- a/GHC/IO/Handle.hs +++ b/GHC/IO/Handle.hs @@ -193,7 +193,7 @@ -- -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; -- --- * if @hdl@ is not writable, the contents of the buffer is discarded. +-- * if @hdl@ is not writable, the contents of the buffer are discarded. -- -- This operation may fail with: -- @@ -296,7 +296,7 @@ -- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@, -- including any buffered read data. Buffered read data is flushed --- by seeking the file position back to the point before the bufferred +-- by seeking the file position back to the point before the buffered -- data was read, and hence only works if @hdl@ is seekable (see -- 'hIsSeekable'). -- diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs --- a/GHC/IO/Handle/Text.hs +++ b/GHC/IO/Handle/Text.hs @@ -174,28 +174,16 @@ -- | Computation 'hGetLine' @hdl@ reads a line from the file or -- channel managed by @hdl@. --- 'hGetLine' does not return the newline as part of the result. -- --- A line is separated by the newline --- set with 'System.IO.hSetNewlineMode' or 'nativeNewline' by default. --- The read newline character(s) are not returned as part of the result. --- --- If 'hGetLine' encounters end-of-file at any point while reading --- in the middle of a line, it is treated as a line terminator and the (partial) --- line is returned. --- -- This operation may fail with: -- -- * 'isEOFError' if the end of file is encountered when reading -- the /first/ character of the line. -- --- ==== __Examples__ --- --- >>> withFile "/home/user/foo" ReadMode hGetLine >>= putStrLn --- this is the first line of the file :O --- --- >>> withFile "/home/user/bar" ReadMode (replicateM 3 . hGetLine) --- ["this is the first line","this is the second line","this is the third line"] +-- If 'hGetLine' encounters end-of-file at any other point while reading +-- in a line, it is treated as a line terminator and the (partial) +-- line is returned. + hGetLine :: Handle -> IO String hGetLine h = wantReadableHandle_ "hGetLine" h $ \ handle_ -> diff --git a/GHC/IO/Handle/Text.hs-boot b/GHC/IO/Handle/Text.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/IO/Handle/Text.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.IO.Handle.Text ( hPutStrLn ) where + +import GHC.Base (String, IO) +import {-# SOURCE #-} GHC.IO.Handle.Types (Handle) + +hPutStrLn :: Handle -> String -> IO () diff --git a/GHC/IO/Handle/Types.hs b/GHC/IO/Handle/Types.hs --- a/GHC/IO/Handle/Types.hs +++ b/GHC/IO/Handle/Types.hs @@ -124,11 +124,11 @@ Handle__ { haDevice :: !dev, haType :: HandleType, -- type (read/write/append etc.) - haByteBuffer :: !(IORef (Buffer Word8)), -- See [note Buffering Implementation] + haByteBuffer :: !(IORef (Buffer Word8)), -- See Note [Buffering Implementation] haBufferMode :: BufferMode, haLastDecode :: !(IORef (dec_state, Buffer Word8)), -- ^ The byte buffer just before we did our last batch of decoding. - haCharBuffer :: !(IORef (Buffer CharBufElem)), -- See [note Buffering Implementation] + haCharBuffer :: !(IORef (Buffer CharBufElem)), -- See Note [Buffering Implementation] haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers haEncoder :: Maybe (TextEncoder enc_state), haDecoder :: Maybe (TextDecoder dec_state), @@ -261,13 +261,13 @@ ) {- -[note Buffering Implementation] - +Note [Buffering Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each Handle has two buffers: a byte buffer (haByteBuffer) and a Char buffer (haCharBuffer). -[note Buffered Reading] - +Note [Buffered Reading] +~~~~~~~~~~~~~~~~~~~~~~~ For read Handles, bytes are read into the byte buffer, and immediately decoded into the Char buffer (see GHC.IO.Handle.Internals.readTextDevice). The only way there might be @@ -279,8 +279,8 @@ the data there is available without blocking, decode it into the Char buffer, and then provide it immediately to the caller. -[note Buffered Writing] - +Note [Buffered Writing] +~~~~~~~~~~~~~~~~~~~~~~~ Characters are written into the Char buffer by e.g. hPutStr. At the end of the operation, or when the char buffer is full, the buffer is decoded to the byte buffer (see writeCharBuffer). This is so that we @@ -288,8 +288,8 @@ Hence, the Char buffer is always empty between Handle operations. -[note Buffer Sizing] - +Note [Buffer Sizing] +~~~~~~~~~~~~~~~~~~~~ The char buffer is always a default size (dEFAULT_CHAR_BUFFER_SIZE). The byte buffer size is chosen by the underlying device (via its IODevice.newBuffer). Hence the size of these buffers is not under @@ -322,8 +322,8 @@ according to the current buffering mode. Additionally, we look for newlines and flush if the mode is LineBuffering. -[note Buffer Flushing] - +Note [Buffer Flushing] +~~~~~~~~~~~~~~~~~~~~~~ ** Flushing the Char buffer We must be able to flush the Char buffer, in order to implement diff --git a/GHC/IO/Handle/Types.hs-boot b/GHC/IO/Handle/Types.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/IO/Handle/Types.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.IO.Handle.Types ( Handle ) where + +-- See Note [Depend on GHC.Num.Integer] in GHC.Base +import GHC.Types () + +data Handle diff --git a/GHC/IO/SubSystem.hs b/GHC/IO/SubSystem.hs --- a/GHC/IO/SubSystem.hs +++ b/GHC/IO/SubSystem.hs @@ -39,7 +39,7 @@ -- | Conditionally execute an action depending on the configured I/O subsystem. -- On POSIX systems always execute the first action. --- On windows execute the second action if WINIO as active, otherwise fall back to +-- On Windows execute the second action if WINIO as active, otherwise fall back to -- the first action. conditional :: a -> a -> a #if defined(mingw32_HOST_OS) diff --git a/GHC/IORef.hs b/GHC/IORef.hs --- a/GHC/IORef.hs +++ b/GHC/IORef.hs @@ -127,16 +127,30 @@ -- | Atomically replace the contents of an 'IORef', returning -- the old contents. atomicSwapIORef :: IORef a -> a -> IO a --- Bad implementation! This will be a primop shortly. -atomicSwapIORef (IORef (STRef ref)) new = IO $ \s -> - case atomicModifyMutVar2# ref (\_old -> Box new) s of - (# s', old, Box _new #) -> (# s', old #) - -data Box a = Box a +atomicSwapIORef (IORef (STRef ref)) new = IO (atomicSwapMutVar# ref new) --- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both --- the value stored in the 'IORef' and the value returned. The new value --- is installed in the 'IORef' before the returned value is forced. +-- | A strict version of 'Data.IORef.atomicModifyIORef'. This forces both the +-- value stored in the 'IORef' and the value returned. +-- +-- Conceptually, +-- +-- @ +-- atomicModifyIORef' ref f = do +-- -- Begin atomic block +-- old <- 'readIORef' ref +-- let r = f old +-- new = fst r +-- 'writeIORef' ref new +-- -- End atomic block +-- case r of +-- (!_new, !res) -> pure res +-- @ +-- +-- The actions in the \"atomic block\" are not subject to interference +-- by other threads. In particular, the value in the 'IORef' cannot +-- change between the 'readIORef' and 'writeIORef' invocations. +-- +-- The new value is installed in the 'IORef' before either value is forced. -- So -- -- @atomicModifyIORef' ref (\x -> (x+1, undefined))@ @@ -144,8 +158,18 @@ -- will increment the 'IORef' and then throw an exception in the calling -- thread. -- --- This function imposes a memory barrier, preventing reordering; --- see "Data.IORef#memmodel" for details. +-- @atomicModifyIORef' ref (\x -> (undefined, x))@ +-- +-- and +-- +-- @atomicModifyIORef' ref (\_ -> undefined)@ +-- +-- will each raise an exception in the calling thread, but will /also/ +-- install the bottoming value in the 'IORef', where it may be read by +-- other threads. +-- +-- This function imposes a memory barrier, preventing reordering around +-- the \"atomic block\"; see "Data.IORef#memmodel" for details. -- -- @since 4.6.0.0 atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b diff --git a/GHC/JS/Foreign/Callback.hs b/GHC/JS/Foreign/Callback.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Foreign/Callback.hs @@ -0,0 +1,149 @@ +module GHC.JS.Foreign.Callback + ( Callback + , OnBlocked(..) + , releaseCallback + -- * asynchronous callbacks + , asyncCallback + , asyncCallback1 + , asyncCallback2 + , asyncCallback3 + -- * synchronous callbacks + , syncCallback + , syncCallback1 + , syncCallback2 + , syncCallback3 + -- * synchronous callbacks that return a value + , syncCallback' + , syncCallback1' + , syncCallback2' + , syncCallback3' + ) where + +import GHC.JS.Prim + +import qualified GHC.Exts as Exts + +import Data.Typeable + +import Unsafe.Coerce + +data OnBlocked = ContinueAsync | ThrowWouldBlock deriving (Eq) + +newtype Callback a = Callback JSVal deriving Typeable + +{- | + When you create a callback, the Haskell runtime stores a reference to + the exported IO action or function. This means that all data referenced by the + exported value stays in memory, even if nothing outside the Haskell runtime + holds a reference to to callback. + Use 'releaseCallback' to free the reference. Subsequent calls from JavaScript + to the callback will result in an exception. + -} +releaseCallback :: Callback a -> IO () +releaseCallback x = js_release x + +{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous + thread when called. + Call 'releaseCallback' when done with the callback, freeing memory referenced + by the IO action. + -} +syncCallback :: OnBlocked -- ^ what to do when the thread blocks + -> IO () -- ^ the Haskell action + -> IO (Callback (IO ())) -- ^ the callback +syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeCoerce x) + + +{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous + thread when called. The callback takes one argument that it passes as a JSVal value to + the Haskell function. + Call 'releaseCallback' when done with the callback, freeing data referenced + by the function. + -} +syncCallback1 :: OnBlocked -- ^ what to do when the thread blocks + -> (JSVal -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSVal -> IO ())) -- ^ the callback +syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 (unsafeCoerce x) + + +{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous + thread when called. The callback takes two arguments that it passes as JSVal values to + the Haskell function. + Call 'releaseCallback' when done with the callback, freeing data referenced + by the function. + -} +syncCallback2 :: OnBlocked -- ^ what to do when the thread blocks + -> (JSVal -> JSVal -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback +syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x) + +{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous + thread when called. The callback takes three arguments that it passes as JSVal values to + the Haskell function. + Call 'releaseCallback' when done with the callback, freeing data referenced + by the function. + -} +syncCallback3 :: OnBlocked -- ^ what to do when the thread blocks + -> (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback +syncCallback3 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 3 (unsafeCoerce x) + +{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous + thread when called. + Call 'releaseCallback' when done with the callback, freeing memory referenced + by the IO action. + -} +syncCallback' :: IO JSVal + -> IO (Callback (IO JSVal)) +syncCallback' x = js_syncCallbackReturn (unsafeCoerce x) + +syncCallback1' :: (JSVal -> IO JSVal) + -> IO (Callback (JSVal -> IO JSVal)) +syncCallback1' x = js_syncCallbackApplyReturn 1 (unsafeCoerce x) + +syncCallback2' :: (JSVal -> JSVal -> IO JSVal) + -> IO (Callback (JSVal -> JSVal -> IO JSVal)) +syncCallback2' x = js_syncCallbackApplyReturn 2 (unsafeCoerce x) + +syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal) + -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal)) +syncCallback3' x = js_syncCallbackApplyReturn 3 (unsafeCoerce x) + +{- | Make a callback (JavaScript function) that runs the supplied IO action in an asynchronous + thread when called. + Call 'releaseCallback' when done with the callback, freeing data referenced + by the IO action. + -} +asyncCallback :: IO () -- ^ the action that the callback runs + -> IO (Callback (IO ())) -- ^ the callback +asyncCallback x = js_asyncCallback (unsafeCoerce x) + +asyncCallback1 :: (JSVal -> IO ()) -- ^ the function that the callback calls + -> IO (Callback (JSVal -> IO ())) -- ^ the calback +asyncCallback1 x = js_asyncCallbackApply 1 (unsafeCoerce x) + +asyncCallback2 :: (JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls + -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback +asyncCallback2 x = js_asyncCallbackApply 2 (unsafeCoerce x) + +asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls + -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback +asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x) + +-- ---------------------------------------------------------------------------- + +foreign import javascript unsafe "(($1, $2) => { return h$makeCallback(h$runSync, [$1], $2); })" + js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b)) +foreign import javascript unsafe "(($1) => { return h$makeCallback(h$run, [], $1); })" + js_asyncCallback :: Exts.Any -> IO (Callback (IO b)) +foreign import javascript unsafe "(($1) => { return h$makeCallback(h$runSyncReturn, [false], $1); })" + js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal)) + +foreign import javascript unsafe "(($1, $2, $3) => { return h$makeCallbackApply($2, h$runSync, [$1], $3); })" + js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b) +foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$run, [], $2); })" + js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b) +foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$runSyncReturn, [false], $2); })" + js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b) + +foreign import javascript unsafe "(($1) => { return h$release($1); })" + js_release :: Callback a -> IO () diff --git a/GHC/List.hs b/GHC/List.hs --- a/GHC/List.hs +++ b/GHC/List.hs @@ -31,7 +31,7 @@ -- Other functions foldl1', concat, concatMap, map, (++), filter, lookup, - head, last, tail, init, uncons, (!!), + head, last, tail, init, uncons, unsnoc, (!?), (!!), scanl, scanl1, scanl', scanr, scanr1, iterate, iterate', repeat, replicate, cycle, take, drop, splitAt, takeWhile, dropWhile, span, break, reverse, @@ -49,7 +49,7 @@ import GHC.Num.Integer (Integer) import GHC.Stack.Types (HasCallStack) -infixl 9 !! +infixl 9 !?, !! infix 4 `elem`, `notElem` -- $setup @@ -83,6 +83,8 @@ head [] = badHead {-# NOINLINE [1] head #-} +{-# WARNING in "x-partial" head "This is a partial function, it throws an error on empty lists. Use pattern matching or Data.List.uncons instead. Consider refactoring to use Data.List.NonEmpty." #-} + badHead :: HasCallStack => a badHead = errorEmptyList "head" @@ -95,11 +97,11 @@ head (augment g xs) = g (\x _ -> x) (head xs) #-} --- | \(\mathcal{O}(1)\). Decompose a list into its head and tail. +-- | \(\mathcal{O}(1)\). Decompose a list into its 'head' and 'tail'. -- -- * If the list is empty, returns 'Nothing'. -- * If the list is non-empty, returns @'Just' (x, xs)@, --- where @x@ is the head of the list and @xs@ its tail. +-- where @x@ is the 'head' of the list and @xs@ its 'tail'. -- -- @since 4.8.0.0 -- @@ -113,6 +115,41 @@ uncons [] = Nothing uncons (x:xs) = Just (x, xs) +-- | \(\mathcal{O}(n)\). Decompose a list into 'init' and 'last'. +-- +-- * If the list is empty, returns 'Nothing'. +-- * If the list is non-empty, returns @'Just' (xs, x)@, +-- where @xs@ is the 'init'ial part of the list and @x@ is its 'last' element. +-- +-- @since 4.19.0.0 +-- +-- >>> unsnoc [] +-- Nothing +-- >>> unsnoc [1] +-- Just ([],1) +-- >>> unsnoc [1, 2, 3] +-- Just ([1,2],3) +-- +-- Laziness: +-- +-- >>> fst <$> unsnoc [undefined] +-- Just [] +-- >>> head . fst <$> unsnoc (1 : undefined) +-- Just *** Exception: Prelude.undefined +-- >>> head . fst <$> unsnoc (1 : 2 : undefined) +-- Just 1 +-- +-- 'unsnoc' is dual to 'uncons': for a finite list @xs@ +-- +-- > unsnoc xs = (\(hd, tl) -> (reverse tl, hd)) <$> uncons (reverse xs) +-- +unsnoc :: [a] -> Maybe ([a], a) +-- The lazy pattern ~(a, b) is important to be productive on infinite lists +-- and not to be prone to stack overflows. +-- Expressing the recursion via 'foldr' provides for list fusion. +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +{-# INLINABLE unsnoc #-} + -- | \(\mathcal{O}(1)\). Extract the elements after the head of a list, which -- must be non-empty. -- @@ -129,6 +166,8 @@ tail (_:xs) = xs tail [] = errorEmptyList "tail" +{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with drop 1, or use pattern matching or Data.List.uncons instead. Consider refactoring to use Data.List.NonEmpty." #-} + -- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be -- finite and non-empty. -- @@ -139,8 +178,7 @@ -- >>> last [] -- *** Exception: Prelude.last: empty list -- --- WARNING: This function is partial. You can use 'reverse' with case-matching, --- 'uncons' or 'listToMaybe' instead. +-- WARNING: This function is partial. Consider using 'unsnoc' instead. last :: HasCallStack => [a] -> a #if defined(USE_REPORT_PRELUDE) last [x] = x @@ -168,8 +206,7 @@ -- >>> init [] -- *** Exception: Prelude.init: empty list -- --- WARNING: This function is partial. You can use 'reverse' with case-matching --- or 'uncons' instead. +-- WARNING: This function is partial. Consider using 'unsnoc' instead. init :: HasCallStack => [a] -> [a] #if defined(USE_REPORT_PRELUDE) init [x] = [] @@ -449,8 +486,10 @@ -- [100,99,97,94,90] -- >>> scanl (\reversedString nextChar -> nextChar : reversedString) "foo" ['a', 'b', 'c', 'd'] -- ["foo","afoo","bafoo","cbafoo","dcbafoo"] --- >>> scanl (+) 0 [1..] --- * Hangs forever * +-- >>> take 10 (scanl (+) 0 [1..]) +-- [0,1,3,6,10,15,21,28,36,45] +-- >>> take 1 (scanl undefined 'a' undefined) +-- "a" -- This peculiar arrangement is necessary to prevent scanl being rewritten in -- its own right-hand side. @@ -496,8 +535,10 @@ -- [True,False,False,False] -- >>> scanl1 (||) [False, False, True, True] -- [False,False,True,True] --- >>> scanl1 (+) [1..] --- * Hangs forever * +-- >>> take 10 (scanl1 (+) [1..]) +-- [1,3,6,10,15,21,28,36,45,55] +-- >>> take 1 (scanl1 undefined ('a' : undefined)) +-- "a" scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 f (x:xs) = scanl f x xs scanl1 _ [] = [] @@ -753,9 +794,12 @@ -- variant of this function. -- -- >>> take 10 $ iterate not True --- [True,False,True,False... +-- [True,False,True,False,True,False,True,False,True,False] -- >>> take 10 $ iterate (+3) 42 --- [42,45,48,51,54,57,60,63... +-- [42,45,48,51,54,57,60,63,66,69] +-- >>> take 1 $ iterate undefined 42 +-- [42] +-- {-# NOINLINE [1] iterate #-} iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) @@ -776,6 +820,10 @@ -- It forces the result of each application of the function to weak head normal -- form (WHNF) -- before proceeding. +-- +-- >>> take 1 $ iterate' undefined 42 +-- *** Exception: Prelude.undefined +-- {-# NOINLINE [1] iterate' #-} iterate' :: (a -> a) -> a -> [a] iterate' f x = @@ -835,10 +883,13 @@ -- -- >>> cycle [] -- *** Exception: Prelude.cycle: empty list --- >>> cycle [42] --- [42,42,42,42,42,42,42,42,42,42... --- >>> cycle [2, 5, 7] --- [2,5,7,2,5,7,2,5,7,2,5,7... +-- >>> take 10 (cycle [42]) +-- [42,42,42,42,42,42,42,42,42,42] +-- >>> take 10 (cycle [2, 5, 7]) +-- [2,5,7,2,5,7,2,5,7,2] +-- >>> take 1 (cycle (42 : undefined)) +-- [42] +-- cycle :: HasCallStack => [a] -> [a] cycle [] = errorEmptyList "cycle" cycle xs = xs' where xs' = xs ++ xs' @@ -852,6 +903,16 @@ -- [1,2,3] -- >>> takeWhile (< 0) [1,2,3] -- [] +-- +-- Laziness: +-- +-- >>> takeWhile (const False) undefined +-- *** Exception: Prelude.undefined +-- >>> takeWhile (const False) (undefined : undefined) +-- [] +-- >>> take 1 (takeWhile (const True) (1 : undefined)) +-- [1] +-- {-# NOINLINE [1] takeWhile #-} takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile _ [] = [] @@ -908,6 +969,13 @@ -- >>> take 0 [1,2] -- [] -- +-- Laziness: +-- +-- >>> take 0 undefined +-- [] +-- >>> take 1 (1 : undefined) +-- [1] +-- -- It is an instance of the more general 'Data.List.genericTake', -- in which @n@ may be of any integral type. take :: Int -> [a] -> [a] @@ -1018,8 +1086,17 @@ -- >>> splitAt (-1) [1,2,3] -- ([],[1,2,3]) -- --- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@ --- (@splitAt _|_ xs = _|_@). +-- It is equivalent to @('take' n xs, 'drop' n xs)@ +-- unless @n@ is @_|_@: +-- @splitAt _|_ xs = _|_@, not @(_|_, _|_)@). +-- +-- The first component of the tuple is produced lazily: +-- +-- >>> fst (splitAt 0 undefined) +-- [] +-- >>> take 1 (fst (splitAt 10 (1 : undefined))) +-- [1] +-- -- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt', -- in which @n@ may be of any integral type. splitAt :: Int -> [a] -> ([a],[a]) @@ -1040,7 +1117,7 @@ #endif /* USE_REPORT_PRELUDE */ -- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where --- first element is longest prefix (possibly empty) of @xs@ of elements that +-- first element is the longest prefix (possibly empty) of @xs@ of elements that -- satisfy @p@ and second element is the remainder of the list: -- -- >>> span (< 3) [1,2,3,4,1,2,3,4] @@ -1050,7 +1127,24 @@ -- >>> span (< 0) [1,2,3] -- ([],[1,2,3]) -- --- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@, even if @p@ is @_|_@. +-- +-- Laziness: +-- +-- >>> span undefined [] +-- ([],[]) +-- >>> fst (span (const False) undefined) +-- *** Exception: Prelude.undefined +-- >>> fst (span (const False) (undefined : undefined)) +-- [] +-- >>> take 1 (fst (span (const True) (1 : undefined))) +-- [1] +-- +-- 'span' produces the first component of the tuple lazily: +-- +-- >>> take 10 (fst (span (const True) [1..])) +-- [1,2,3,4,5,6,7,8,9,10] +-- span :: (a -> Bool) -> [a] -> ([a],[a]) span _ xs@[] = (xs, xs) span p xs@(x:xs') @@ -1068,7 +1162,26 @@ -- >>> break (> 9) [1,2,3] -- ([1,2,3],[]) -- --- 'break' @p@ is equivalent to @'span' ('not' . p)@. +-- 'break' @p@ is equivalent to @'span' ('not' . p)@ +-- and consequently to @('takeWhile' ('not' . p) xs, 'dropWhile' ('not' . p) xs)@, +-- even if @p@ is @_|_@. +-- +-- Laziness: +-- +-- >>> break undefined [] +-- ([],[]) +-- >>> fst (break (const True) undefined) +-- *** Exception: Prelude.undefined +-- >>> fst (break (const True) (undefined : undefined)) +-- [] +-- >>> take 1 (fst (break (const False) (1 : undefined))) +-- [1] +-- +-- 'break' produces the first component of the tuple lazily: +-- +-- >>> take 10 (fst (break (const False) [1..])) +-- [1,2,3,4,5,6,7,8,9,10] +-- break :: (a -> Bool) -> [a] -> ([a],[a]) #if defined(USE_REPORT_PRELUDE) break p = span (not . p) @@ -1345,9 +1458,10 @@ -- >>> ['a', 'b', 'c'] !! (-1) -- *** Exception: Prelude.!!: negative index -- --- WARNING: This function is partial. You can use --- --- instead. +-- WARNING: This function is partial, and should only be used if you are +-- sure that the indexing will not fail. Otherwise, use 'Data.List.!?'. +-- +-- WARNING: This function takes linear time in the index. #if defined(USE_REPORT_PRELUDE) (!!) :: [a] -> Int -> a xs !! n | n < 0 = errorWithoutStackTrace "Prelude.!!: negative index" @@ -1375,6 +1489,30 @@ 0 -> x _ -> r (k-1)) tooLarge xs n #endif + +-- | List index (subscript) operator, starting from 0. Returns 'Nothing' +-- if the index is out of bounds +-- +-- >>> ['a', 'b', 'c'] !? 0 +-- Just 'a' +-- >>> ['a', 'b', 'c'] !? 2 +-- Just 'c' +-- >>> ['a', 'b', 'c'] !? 3 +-- Nothing +-- >>> ['a', 'b', 'c'] !? (-1) +-- Nothing +-- +-- This is the total variant of the partial '!!' operator. +-- +-- WARNING: This function takes linear time in the index. +(!?) :: [a] -> Int -> Maybe a + +{-# INLINABLE (!?) #-} +xs !? n + | n < 0 = Nothing + | otherwise = foldr (\x r k -> case k of + 0 -> Just x + _ -> r (k-1)) (const Nothing) xs n -------------------------------------------------------------- -- The zip family diff --git a/GHC/Read.hs b/GHC/Read.hs --- a/GHC/Read.hs +++ b/GHC/Read.hs @@ -205,8 +205,8 @@ -- | The method 'readList' is provided to allow the programmer to -- give a specialised way of parsing lists of values. -- For example, this is used by the predefined 'Read' instance of - -- the 'Char' type, where values of type 'String' should be are - -- expected to use double quotes, rather than square brackets. + -- the 'Char' type, where values of type 'String' are expected to + -- use double quotes, rather than square brackets. readList :: ReadS [a] -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only). diff --git a/GHC/Real.hs b/GHC/Real.hs --- a/GHC/Real.hs +++ b/GHC/Real.hs @@ -142,6 +142,10 @@ -- -- [__Coherence with 'fromRational'__]: if the type also implements 'Fractional', -- then 'fromRational' is a left inverse for 'toRational', i.e. @fromRational (toRational i) = i@ +-- +-- The law does not hold for 'Float', 'Double', 'Foreign.C.Types.CFloat', +-- 'Foreign.C.Types.CDouble', etc., because these types contain non-finite values, +-- which cannot be roundtripped through 'Rational'. class (Num a, Ord a) => Real a where -- | the rational equivalent of its real argument with full precision toRational :: a -> Rational diff --git a/GHC/ST.hs b/GHC/ST.hs --- a/GHC/ST.hs +++ b/GHC/ST.hs @@ -131,4 +131,4 @@ -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a runST (ST st_rep) = case runRW# st_rep of (# _, a #) -> a --- See Note [Definition of runRW#] in GHC.Magic +-- See Note [runRW magic] in GHC.CoreToStg.Prep diff --git a/GHC/TopHandler.hs b/GHC/TopHandler.hs --- a/GHC/TopHandler.hs +++ b/GHC/TopHandler.hs @@ -84,7 +84,7 @@ main_thread_id <- myThreadId weak_tid <- mkWeakThreadId main_thread_id - --setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler + --setFinalizerExceptionHandler (printToHandleFinalizerExceptionHandler stderr) -- For the time being, we don't install any exception handler for -- Handle finalization. Instead, the user should set one manually. diff --git a/GHC/TypeError.hs b/GHC/TypeError.hs --- a/GHC/TypeError.hs +++ b/GHC/TypeError.hs @@ -1,33 +1,42 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK not-home #-} {-| -This module exports the TypeError family, which is used to provide custom type -errors, and the ErrorMessage kind used to define these custom error messages. -This is a type-level analogue to the term level error function. +This module exports: -@since 4.16.0.0 + - The 'TypeError' type family, which is used to provide custom type + errors. This is a type-level analogue to the term level error function. + - The 'ErrorMessage' kind, used to define custom error messages. + - The 'Unsatisfiable' constraint, a more principled variant of 'TypeError' + which gives a more predictable way of reporting custom type errors. + +@since 4.17.0.0 -} module GHC.TypeError ( ErrorMessage (..) , TypeError , Assert + , Unsatisfiable, unsatisfiable ) where import Data.Bool import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base -import GHC.Types (Constraint, Symbol) +import GHC.Types (TYPE, Constraint, Symbol) -{- -Note [Custom type errors] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Custom type errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ TypeError is used to provide custom type errors, similar to the term-level error function. TypeError is somewhat magical: when the constraint solver encounters a constraint where the RHS is TypeError, it reports the error to @@ -85,9 +94,8 @@ -- @since 4.9.0.0 type family TypeError (a :: ErrorMessage) :: b where -{- -Note [Getting good error messages from boolean comparisons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Getting good error messages from boolean comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to write types like f :: forall (x :: Int) (y :: Int). (x <= y) => T x -> T y @@ -132,10 +140,57 @@ -- where @NotPError@ reduces to a @TypeError@ which is reported if the -- assertion fails. -- --- @since 4.16.0.0 +-- @since 4.17.0.0 -- type Assert :: Bool -> Constraint -> Constraint type family Assert check errMsg where Assert 'True _ = () Assert _ errMsg = errMsg -- See Note [Getting good error messages from boolean comparisons] + +{- Note [The Unsatisfiable constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The class `Unsatisfiable :: ErrorMessage -> Constraint` provides a mechanism +for custom type errors that reports the errors in a more predictable behaviour +than `TypeError`, as these constraints are handled purely during constraint solving. + +The details are laid out in GHC Proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst). + +See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors for +details of the implementation in GHC. + +Note [The Unsatisfiable representation-polymorphism trick] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The class method `unsatisfiableLifted :: forall (a::Type). Unsatisfiable msg => a` +works only for lifted types `a`. What if we want an unsatisfiable value of type +`Int#`, say? The function `unsatisfiable` has a representation-polymoprhic type + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (b :: TYPE rep). + Unsatisfiable msg => b +and yet is defined in terms of `unsatisfiableLifted`. How? By instantiating +`unsatisfiableLifted` at type `(##) -> b`, and applying the result to `(##)`. +Very cunning! +-} + +-- | An unsatisfiable constraint. Similar to 'TypeError' when used at the +-- 'Constraint' kind, but reports errors in a more predictable manner. +-- +-- See also the 'unsatisfiable' function. +-- +-- @since 4.19.0.0@. +type Unsatisfiable :: ErrorMessage -> Constraint +class Unsatisfiable msg where + unsatisfiableLifted :: a + +-- | Prove anything within a context with an 'Unsatisfiable' constraint. +-- +-- This is useful for filling in instance methods when there is an 'Unsatisfiable' +-- constraint in the instance head, e.g.: +-- +-- > instance Unsatisfiable (Text "No Eq instance for functions") => Eq (a -> b) where +-- (==) = unsatisfiable +-- +-- @since 4.19.0.0@. +unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a +unsatisfiable = unsatisfiableLifted @msg @((##) -> a) (##) + -- See Note [The Unsatisfiable representation-polymorphism trick] + diff --git a/GHC/TypeLits.hs b/GHC/TypeLits.hs --- a/GHC/TypeLits.hs +++ b/GHC/TypeLits.hs @@ -15,6 +15,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RoleAnnotations #-} {-| GHC's @DataKinds@ language extension lifts data constructors, natural @@ -44,6 +45,7 @@ , N.SomeNat(..), SomeSymbol(..), SomeChar(..) , someNatVal, someSymbolVal, someCharVal , N.sameNat, sameSymbol, sameChar + , N.decideNat, decideSymbol, decideChar , OrderingI(..) , N.cmpNat, cmpSymbol, cmpChar -- ** Singleton values @@ -67,8 +69,9 @@ ) where -import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String - , (.), otherwise, withDict ) +import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String + , (.), otherwise, withDict, Void, (++) + , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) import GHC.TypeError(ErrorMessage(..), TypeError) import GHC.Num(Integer, fromInteger) @@ -76,7 +79,8 @@ import GHC.Read(Read(..)) import GHC.Real(toInteger) import GHC.Prim(Proxy#) -import Data.Maybe(Maybe(..)) +import Data.Either (Either (..)) +import Data.Maybe (Maybe(..)) import Data.Proxy (Proxy(..)) import Data.Type.Coercion (Coercion(..), TestCoercion(..)) import Data.Type.Equality((:~:)(Refl), TestEquality(..)) @@ -224,7 +228,21 @@ proxy1 a -> proxy2 b -> Maybe (a :~: b) sameSymbol _ _ = testEquality (symbolSing @a) (symbolSing @b) +-- | We either get evidence that this function was instantiated with the +-- same type-level symbols, or that the type-level symbols are distinct. +-- +-- @since 4.19.0.0 +decideSymbol :: forall a b proxy1 proxy2. + (KnownSymbol a, KnownSymbol b) => + proxy1 a -> proxy2 b -> Either (a :~: b -> Void) (a :~: b) +decideSymbol _ _ = decSymbol (symbolSing @a) (symbolSing @b) +-- Not exported: See [Not exported decNat, decSymbol and decChar] +decSymbol :: SSymbol a -> SSymbol b -> Either (a :~: b -> Void) (a :~: b) +decSymbol (UnsafeSSymbol x) (UnsafeSSymbol y) + | x == y = Right (unsafeCoerce Refl) + | otherwise = Left (\Refl -> errorWithoutStackTrace ("decideSymbol: Impossible equality proof " ++ show x ++ " :~: " ++ show y)) + -- | We either get evidence that this function was instantiated with the -- same type-level characters, or 'Nothing'. -- @@ -234,6 +252,21 @@ proxy1 a -> proxy2 b -> Maybe (a :~: b) sameChar _ _ = testEquality (charSing @a) (charSing @b) +-- | We either get evidence that this function was instantiated with the +-- same type-level characters, or that the type-level characters are distinct. +-- +-- @since 4.19.0.0 +decideChar :: forall a b proxy1 proxy2. + (KnownChar a, KnownChar b) => + proxy1 a -> proxy2 b -> Either (a :~: b -> Void) (a :~: b) +decideChar _ _ = decChar (charSing @a) (charSing @b) + +-- Not exported: See [Not exported decNat, decSymbol and decChar] +decChar :: SChar a -> SChar b -> Either (a :~: b -> Void) (a :~: b) +decChar (UnsafeSChar x) (UnsafeSChar y) + | x == y = Right (unsafeCoerce Refl) + | otherwise = Left (\Refl -> errorWithoutStackTrace ("decideChar: Impossible equality proof " ++ show x ++ " :~: " ++ show y)) + -- | Like 'sameSymbol', but if the symbols aren't equal, this additionally -- provides proof of LT or GT. -- @@ -308,6 +341,7 @@ -- -- @since 4.18.0.0 newtype SSymbol (s :: Symbol) = UnsafeSSymbol String +type role SSymbol nominal -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. @@ -331,6 +365,7 @@ pattern SSymbol :: forall s. () => KnownSymbol s => SSymbol s pattern SSymbol <- (knownSymbolInstance -> KnownSymbolInstance) where SSymbol = symbolSing +{-# COMPLETE SSymbol #-} -- An internal data type that is only used for defining the SSymbol pattern -- synonym. @@ -342,6 +377,14 @@ knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance +-- | @since 4.19.0.0 +instance Eq (SSymbol s) where + _ == _ = True + +-- | @since 4.19.0.0 +instance Ord (SSymbol s) where + compare _ _ = EQ + -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -352,9 +395,9 @@ -- | @since 4.18.0.0 instance TestEquality SSymbol where - testEquality (UnsafeSSymbol x) (UnsafeSSymbol y) - | x == y = Just (unsafeCoerce Refl) - | otherwise = Nothing + testEquality a b = case decSymbol a b of + Right p -> Just p + Left _ -> Nothing -- | @since 4.18.0.0 instance TestCoercion SSymbol where @@ -401,6 +444,7 @@ -- -- @since 4.18.0.0 newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -424,6 +468,7 @@ pattern SChar :: forall c. () => KnownChar c => SChar c pattern SChar <- (knownCharInstance -> KnownCharInstance) where SChar = charSing +{-# COMPLETE SChar #-} -- An internal data type that is only used for defining the SChar pattern -- synonym. @@ -435,6 +480,14 @@ knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance +-- | @since 4.19.0.0 +instance Eq (SChar c) where + _ == _ = True + +-- | @since 4.19.0.0 +instance Ord (SChar c) where + compare _ _ = EQ + -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) @@ -445,9 +498,9 @@ -- | @since 4.18.0.0 instance TestEquality SChar where - testEquality (UnsafeSChar x) (UnsafeSChar y) - | x == y = Just (unsafeCoerce Refl) - | otherwise = Nothing + testEquality a b = case decChar a b of + Right p -> Just p + Left _ -> Nothing -- | @since 4.18.0.0 instance TestCoercion SChar where diff --git a/GHC/TypeLits/Internal.hs b/GHC/TypeLits/Internal.hs --- a/GHC/TypeLits/Internal.hs +++ b/GHC/TypeLits/Internal.hs @@ -5,9 +5,14 @@ {-# OPTIONS_HADDOCK not-home #-} {-| -This module exports the Type Literal kinds as well as the comparison type -families for those kinds. It is needed to prevent module cycles while still -allowing these identifiers to be imported in 'Data.Type.Ord'. +DO NOT USE THIS MODULE. Use "GHC.TypeLits" instead. + +This module is internal-only and was exposed by accident. It may be +removed without warning in a future version. + +(The technical reason for this module's existence is that it is needed +to prevent module cycles while still allowing these identifiers to be +imported in 'Data.Type.Ord'.) @since 4.16.0.0 -} diff --git a/GHC/TypeNats.hs b/GHC/TypeNats.hs --- a/GHC/TypeNats.hs +++ b/GHC/TypeNats.hs @@ -16,6 +16,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RoleAnnotations #-} {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface @@ -33,6 +34,7 @@ , SomeNat(..) , someNatVal , sameNat + , decideNat -- ** Singleton values , SNat , pattern SNat @@ -48,12 +50,14 @@ ) where -import GHC.Base(Eq(..), Functor(..), Ord(..), WithDict(..), (.), otherwise) +import GHC.Base( Eq(..), Functor(..), Ord(..), WithDict(..), (.), otherwise + , Void, errorWithoutStackTrace, (++)) import GHC.Types import GHC.Num.Natural(Natural) import GHC.Show(Show(..), appPrec, appPrec1, showParen, showString) import GHC.Read(Read(..)) import GHC.Prim(Proxy#) +import Data.Either(Either(..)) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) import Data.Type.Coercion (Coercion(..), TestCoercion(..)) @@ -65,7 +69,7 @@ -- | A type synonym for 'Natural'. -- --- Prevously, this was an opaque data type, but it was changed to a type +-- Previously, this was an opaque data type, but it was changed to a type -- synonym. -- -- @since 4.16.0.0 @@ -239,6 +243,73 @@ proxy1 a -> proxy2 b -> Maybe (a :~: b) sameNat _ _ = testEquality (natSing @a) (natSing @b) +-- | We either get evidence that this function was instantiated with the +-- same type-level numbers, or that the type-level numbers are distinct. +-- +-- @since 4.19.0.0 +decideNat :: forall a b proxy1 proxy2. + (KnownNat a, KnownNat b) => + proxy1 a -> proxy2 b -> Either (a :~: b -> Void) (a :~: b) +decideNat _ _ = decNat (natSing @a) (natSing @b) + +-- Not exported: See [Not exported decNat, decSymbol and decChar] +decNat :: SNat a -> SNat b -> Either (a :~: b -> Void) (a :~: b) +decNat (UnsafeSNat x) (UnsafeSNat y) + | x == y = Right (unsafeCoerce Refl) + | otherwise = Left (\Refl -> errorWithoutStackTrace ("decideNat: Impossible equality proof " ++ show x ++ " :~: " ++ show y)) + +{- +Note [Not exported decNat, decSymbol and decChar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The decNat, decSymbol and decChar are not (yet) exported. + +There are two development paths: +1. export them. +2. Add `decideEquality :: f a -> f b -> Either (a :~: b -> Void) (a :~: b)` + to the `Data.Type.Equality.TestEquality` typeclass. + +The second option looks nicer given the current base API: +there aren't `eqNat :: SNat a -> SNat b -> Maybe (a :~: b)` like functions, +they are abstracted by `TestEquality` typeclass. + +Also TestEquality class has a law that testEquality result +should be Just Refl iff the types applied to are equal: + +testEquality (x :: f a) (y :: f b) = Just Refl <=> a = b + +As consequence we have that testEquality should be Nothing +iff the types applied are inequal: + +testEquality (x :: f a) (y :: f b) = Nothing <=> a /= b + +And the decideEquality would enforce that. + +However, adding a new method is a breaking change, +as default implementation cannot be (safely) provided. +Also there are unlawful instances of `TestEquality` out there, +(e.g. https://hackage.haskell.org/package/parameterized-utils Index instance + https://hackage.haskell.org/package/witness various types) +which makes adding unsafe default implementation a bad idea. + +Adding own typeclass: + +class TestEquality f => DecideEquality f where + decideEquality :: f a -> f b -> Either (a :~: b -> Void) (a :~: b) + +is bad design, as `TestEquality` already implies that it should be possible. +In other words, every f with (lawful) `TestEquality` instance should have +`DecideEquality` instance as well. + +We hold on doing either 1. or 2. yet, as doing 2. is "harder", +but if it is done eventually, doing 1. is pointless. +In other words the paths can be thought as mutually exclusive. + +Fortunately the dec* functions can be simulated using decide* variants +if needed, so there is no hurry to commit to either development paths. + +-} + -- | Like 'sameNat', but if the numbers aren't equal, this additionally -- provides proof of LT or GT. -- @@ -274,6 +345,7 @@ -- -- @since 4.18.0.0 newtype SNat (n :: Nat) = UnsafeSNat Natural +type role SNat nominal -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -297,6 +369,7 @@ pattern SNat :: forall n. () => KnownNat n => SNat n pattern SNat <- (knownNatInstance -> KnownNatInstance) where SNat = natSing +{-# COMPLETE SNat #-} -- An internal data type that is only used for defining the SNat pattern -- synonym. @@ -308,6 +381,14 @@ knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance +-- | @since 4.19.0.0 +instance Eq (SNat n) where + _ == _ = True + +-- | @since 4.19.0.0 +instance Ord (SNat n) where + compare _ _ = EQ + -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) @@ -318,9 +399,9 @@ -- | @since 4.18.0.0 instance TestEquality SNat where - testEquality (UnsafeSNat x) (UnsafeSNat y) - | x == y = Just (unsafeCoerce Refl) - | otherwise = Nothing + testEquality a b = case decNat a b of + Right x -> Just x + Left _ -> Nothing -- | @since 4.18.0.0 instance TestCoercion SNat where diff --git a/GHC/TypeNats/Internal.hs b/GHC/TypeNats/Internal.hs --- a/GHC/TypeNats/Internal.hs +++ b/GHC/TypeNats/Internal.hs @@ -5,9 +5,14 @@ {-# OPTIONS_HADDOCK not-home #-} {-| -This module exports the Type Nat kind as well as the comparison type -family for that kinds. It is needed to prevent module cycles while still -allowing these identifiers to be imported in 'Data.Type.Ord'. +DO NOT USE THIS MODULE. Use "GHC.TypeNats" instead. + +This module is internal-only and was exposed by accident. It may be +removed without warning in a future version. + +(The technical reason for this module's existence is that it is needed +to prevent module cycles while still allowing these identifiers to be +imported in 'Data.Type.Ord'.) @since 4.16.0.0 -} diff --git a/GHC/Weak.hs b/GHC/Weak.hs --- a/GHC/Weak.hs +++ b/GHC/Weak.hs @@ -31,7 +31,8 @@ -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by -- this handler will be ignored. setFinalizerExceptionHandler, - getFinalizerExceptionHandler + getFinalizerExceptionHandler, + printToHandleFinalizerExceptionHandler ) where import GHC.Base diff --git a/GHC/Weak/Finalize.hs b/GHC/Weak/Finalize.hs --- a/GHC/Weak/Finalize.hs +++ b/GHC/Weak/Finalize.hs @@ -11,6 +11,7 @@ -- this handler will be ignored. setFinalizerExceptionHandler , getFinalizerExceptionHandler + , printToHandleFinalizerExceptionHandler -- * Internal , runFinalizerBatch ) where @@ -20,6 +21,8 @@ import GHC.IORef import {-# SOURCE #-} GHC.Conc.Sync (labelThreadByteArray#, myThreadId) import GHC.IO (catchException, unsafePerformIO) +import {-# SOURCE #-} GHC.IO.Handle.Types (Handle) +import {-# SOURCE #-} GHC.IO.Handle.Text (hPutStrLn) import GHC.Encoding.UTF8 (utf8EncodeByteArray#) data ByteArray = ByteArray ByteArray# @@ -79,3 +82,13 @@ -- @since 4.18.0.0 setFinalizerExceptionHandler :: (SomeException -> IO ()) -> IO () setFinalizerExceptionHandler = writeIORef finalizerExceptionHandler + +-- | An exception handler for 'Handle' finalization that prints the error to +-- the given 'Handle', but doesn't rethrow it. +-- +-- @since 4.18.0.0 +printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () +printToHandleFinalizerExceptionHandler hdl se = + hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) + where + msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n" diff --git a/System/Environment.hs b/System/Environment.hs --- a/System/Environment.hs +++ b/System/Environment.hs @@ -19,9 +19,7 @@ ( getArgs, getProgName, -#if !defined(javascript_HOST_ARCH) executablePath, -#endif getExecutablePath, getEnv, lookupEnv, diff --git a/System/Environment/ExecutablePath.hsc b/System/Environment/ExecutablePath.hsc --- a/System/Environment/ExecutablePath.hsc +++ b/System/Environment/ExecutablePath.hsc @@ -18,9 +18,7 @@ module System.Environment.ExecutablePath ( getExecutablePath -##if !defined(javascript_HOST_ARCH) , executablePath -##endif ) where ##if defined(javascript_HOST_ARCH) @@ -28,6 +26,9 @@ getExecutablePath :: IO FilePath getExecutablePath = return "a.jsexe" +executablePath :: Maybe (IO (Maybe FilePath)) +executablePath = Nothing + ##else -- The imports are purposely kept completely disjoint to prevent edits @@ -47,6 +48,12 @@ import Foreign.C import Foreign.Marshal.Array import System.Posix.Internals +#elif defined(solaris2_HOST_OS) +import Control.Exception (catch, throw) +import Foreign.C +import Foreign.Marshal.Array +import System.IO.Error (isDoesNotExistError) +import System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) import Control.Exception (catch, throw) import Foreign.C @@ -101,7 +108,7 @@ -- -- If the operating system provides a reliable way to determine the current -- executable, return the query action, otherwise return @Nothing@. The action --- is defined on FreeBSD, Linux, MacOS, NetBSD, and Windows. +-- is defined on FreeBSD, Linux, MacOS, NetBSD, Solaris, and Windows. -- -- Even where the query action is defined, there may be situations where no -- result is available, e.g. if the executable file was deleted while the @@ -171,9 +178,9 @@ | otherwise = throw e -------------------------------------------------------------------------------- --- Linux +-- Linux / Solaris -#elif defined(linux_HOST_OS) +#elif defined(linux_HOST_OS) || defined(solaris2_HOST_OS) foreign import ccall unsafe "readlink" c_readlink :: CString -> CString -> CSize -> IO CInt @@ -190,6 +197,7 @@ c_readlink s buf 4096 peekFilePathLen (buf,fromIntegral len) +# if defined(linux_HOST_OS) getExecutablePath = readSymbolicLink $ "/proc/self/exe" executablePath = Just (check <$> getExecutablePath) where @@ -199,6 +207,18 @@ -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/10957 check s | "(deleted)" `isSuffixOf` s = Nothing | otherwise = Just s + +# elif defined(solaris2_HOST_OS) +getExecutablePath = readSymbolicLink "/proc/self/path/a.out" + +executablePath = Just ((Just <$> getExecutablePath) `catch` f) + where + -- readlink(2) fails with ENOENT when the executable has been deleted, + -- even though the symlink itself still exists according to readdir(3). + f e | isDoesNotExistError e = pure Nothing + | otherwise = throw e + +#endif -------------------------------------------------------------------------------- -- FreeBSD / NetBSD diff --git a/System/Mem/Weak.hs b/System/Mem/Weak.hs --- a/System/Mem/Weak.hs +++ b/System/Mem/Weak.hs @@ -64,6 +64,15 @@ mkWeakPair, -- replaceFinaliser + -- * Handling exceptions + -- | When an exception is thrown by a finalizer called by the + -- garbage collector, GHC calls a global handler which can be set with + -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by + -- this handler will be ignored. + setFinalizerExceptionHandler, + getFinalizerExceptionHandler, + printToHandleFinalizerExceptionHandler, + -- * A precise semantics -- $precise diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -34,7 +34,6 @@ import Foreign import Foreign.C --- import Data.Bits import Data.Maybe #if !defined(HTYPE_TCFLAG_T) @@ -51,6 +50,9 @@ #if !defined(mingw32_HOST_OS) import {-# SOURCE #-} GHC.IO.Encoding (getFileSystemEncoding) import qualified GHC.Foreign as GHC +import GHC.Ptr +#else +import Data.OldList (elem) #endif -- --------------------------------------------------------------------------- @@ -139,10 +141,10 @@ Nothing fdGetMode :: FD -> IO IOMode -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) || defined(javascript_HOST_ARCH) fdGetMode _ = do -- We don't have a way of finding out which flags are set on FDs - -- on Windows, so make a handle that thinks that anything goes. + -- on Windows/JS, so make a handle that thinks that anything goes. let flags = o_RDWR #else fdGetMode fd = do @@ -164,13 +166,23 @@ #if defined(mingw32_HOST_OS) withFilePath :: FilePath -> (CWString -> IO a) -> IO a -withFilePath = withCWString +withFilePath fp f = do + checkForInteriorNuls fp + withCWString fp f newFilePath :: FilePath -> IO CWString -newFilePath = newCWString +newFilePath fp = do + checkForInteriorNuls fp + newCWString fp peekFilePath :: CWString -> IO FilePath peekFilePath = peekCWString + +-- | Check a 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See #13660. +checkForInteriorNuls :: FilePath -> IO () +checkForInteriorNuls fp = when ('\0' `elem` fp) (throwInternalNulError fp) + #else withFilePath :: FilePath -> (CString -> IO a) -> IO a @@ -178,13 +190,43 @@ peekFilePath :: CString -> IO FilePath peekFilePathLen :: CStringLen -> IO FilePath -withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f -newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp +withFilePath fp f = do + enc <- getFileSystemEncoding + GHC.withCStringLen0 enc fp $ \(str, len) -> do + checkForInteriorNuls fp (str, len) + f str +newFilePath fp = do + enc <- getFileSystemEncoding + (str, len) <- GHC.newCStringLen0 enc fp + checkForInteriorNuls fp (str, len) + return str peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp +-- | Check an encoded 'FilePath' for internal NUL octets as these are +-- disallowed in POSIX filepaths. See #13660. +checkForInteriorNuls :: FilePath -> CStringLen -> IO () +checkForInteriorNuls fp (str, len) = + when (len' /= len) (throwInternalNulError fp) + -- N.B. If the string contains internal NUL codeunits then the strlen will + -- indicate a size smaller than that returned by withCStringLen. + where + len' = case str of Ptr ptr -> I# (cstringLength# ptr) #endif +throwInternalNulError :: FilePath -> IO a +throwInternalNulError fp = ioError err + where + err = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "checkForInteriorNuls" + , ioe_description = "FilePaths must not contain internal NUL code units." + , ioe_errno = Nothing + , ioe_filename = Just fp + } + -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -457,71 +499,71 @@ #if defined(javascript_HOST_ARCH) foreign import javascript unsafe "(() => { return rts_isThreaded; })" rtsIsThreaded_ :: Int -foreign import javascript interruptible "(($1_1, $2_2, $2, $c) => { return h$base_access($1_1,$2_2,$2,$c); })" +foreign import javascript interruptible "h$base_access" c_access :: CString -> CInt -> IO CInt -foreign import javascript interruptible "(($1_1, $2_2, $2, $c) => { return h$base_chmod($1_1,$2_2,$2,$c); })" +foreign import javascript interruptible "h$base_chmod" c_chmod :: CString -> CMode -> IO CInt -foreign import javascript interruptible "(($1,$c) => { return h$base_close($1,$c); })" +foreign import javascript interruptible "h$base_close" c_close :: CInt -> IO CInt -foreign import javascript interruptible "(($1, $c) => { return h$base_creat($1,$c); })" +foreign import javascript interruptible "h$base_creat" c_creat :: CString -> CMode -> IO CInt -foreign import javascript interruptible "(($1, $c) => { return h$base_dup($1, $c); })" +foreign import javascript interruptible "h$base_dup" c_dup :: CInt -> IO CInt -foreign import javascript interruptible "(($1, $2, $c) => { return h$base_dup2($1,$2,$c); })" +foreign import javascript interruptible "h$base_dup2" c_dup2 :: CInt -> CInt -> IO CInt -foreign import javascript interruptible "(($1,$2_1,$2_2,$c) => { return h$base_fstat($1,$2_1,$2_2,$c); })" -- fixme wrong type +foreign import javascript interruptible "h$base_fstat" -- fixme wrong type c_fstat :: CInt -> Ptr CStat -> IO CInt -foreign import javascript unsafe "(($1) => { return h$base_isatty($1); })" +foreign import javascript unsafe "h$base_isatty" c_isatty :: CInt -> IO CInt -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_lseek($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_lseek" c_lseek :: CInt -> COff -> CInt -> IO COff -foreign import javascript interruptible "(($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_lstat($1_1,$1_2,$2_1,$2_2,$c); })" -- fixme wrong type +foreign import javascript interruptible "h$base_lstat" -- fixme wrong type lstat :: CFilePath -> Ptr CStat -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" +foreign import javascript interruptible "h$base_open" c_open :: CFilePath -> CInt -> CMode -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" +foreign import javascript interruptible "h$base_open" c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" +foreign import javascript interruptible "h$base_open" c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_read($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_read" c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_read($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_read" c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import javascript interruptible "(($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_stat($1_1,$1_2,$2_1,$2_2,$c); })" -- fixme wrong type +foreign import javascript interruptible "h$base_stat" -- fixme wrong type c_stat :: CFilePath -> Ptr CStat -> IO CInt -foreign import javascript unsafe "(($1) => { return h$base_umask($1); })" +foreign import javascript unsafe "h$base_umask" c_umask :: CMode -> IO CMode -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_write($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_write" c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_write($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_write" c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import javascript interruptible "(($1,$2_1,$2_2,$c) => { return h$base_ftruncate($1,$2_1,$2_2,$c); })" -- fixme COff +foreign import javascript interruptible "h$base_ftruncate" -- fixme COff c_ftruncate :: CInt -> FileOffset -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$c) => { return h$base_unlink($1_1,$1_2,$c); })" +foreign import javascript interruptible "h$base_unlink" c_unlink :: CString -> IO CInt foreign import javascript unsafe "h$base_getpid" c_getpid :: IO CPid -- foreign import ccall unsafe "HsBase.h fork" -- c_fork :: IO CPid -foreign import javascript interruptible "($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_link($1_1,$1_2,$2_1,$2_2,$c); })" +foreign import javascript interruptible "h$base_link" c_link :: CString -> CString -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$2,$c) => { return h$base_mkfifo($1_1,$1_2,$2,$c); })" +foreign import javascript interruptible "h$base_mkfifo" c_mkfifo :: CString -> CMode -> IO CInt -foreign import javascript interruptible "(($1_1,$1_2,$c) => { return h$base_pipe($1_1,$1_2,$c); })" +foreign import javascript interruptible "h$base_pipe" c_pipe :: Ptr CInt -> IO CInt -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_sigemptyset($1_1,$1_2); })" +foreign import javascript unsafe "h$base_sigemptyset" c_sigemptyset :: Ptr CSigset -> IO CInt -foreign import javascript unsafe "(($1_1,$1_2,$2) => { return h$base_sigaddset($1_1,$1_2,$2); })" +foreign import javascript unsafe "h$base_sigaddset" c_sigaddset :: Ptr CSigset -> CInt -> IO CInt -foreign import javascript unsafe "(($1,$2_1,$2_2,$3_1,$3_2) => { return h$base_sigprocmask($1,$2_1,$2_2,$3_1,$3_2); })" +foreign import javascript unsafe "h$base_sigprocmask" c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt -foreign import javascript unsafe "(($1,$2_1,$2_2) => { return h$base_tcgetattr($1,$2_1,$2_2); })" +foreign import javascript unsafe "h$base_tcgetattr" c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt -foreign import javascript unsafe "(($1,$2,$3_1,$3_2) => { return h$base_tcsetattr($1,$2,$3_1,$3_2); })" +foreign import javascript unsafe "h$base_tcsetattr" c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt -foreign import javascript unsafe "(($1_1,$1_2,$2_1,$2_2) => { return h$base_utime($1_1,$1_2,$2_1,$2_2); })" -- should this be async? +foreign import javascript interruptible "h$base_utime" c_utime :: CString -> Ptr CUtimbuf -> IO CInt -foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_waitpid($1,$2_1,$2_2,$3,$c); })" +foreign import javascript interruptible "h$base_waitpid" c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid foreign import javascript unsafe "(() => { return h$base_o_rdonly; })" o_RDONLY :: CInt @@ -535,11 +577,11 @@ foreign import javascript unsafe "(() => { return h$base_o_nonblock; })" o_NONBLOCK :: CInt foreign import javascript unsafe "(() => { return h$base_o_binary; })" o_BINARY :: CInt -foreign import javascript unsafe "(($1) => { return h$base_c_s_isreg($1); })" c_s_isreg :: CMode -> CInt -foreign import javascript unsafe "(($1) => { return h$base_c_s_ischr($1); })" c_s_ischr :: CMode -> CInt -foreign import javascript unsafe "(($1) => { return h$base_c_s_isblk($1); })" c_s_isblk :: CMode -> CInt -foreign import javascript unsafe "(($1) => { return h$base_c_s_isdir($1); })" c_s_isdir :: CMode -> CInt -foreign import javascript unsafe "(($1) => { return h$base_c_s_isfifo($1); })" c_s_isfifo :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_isreg" c_s_isreg :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_ischr" c_s_ischr :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_isblk" c_s_isblk :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_isdir" c_s_isdir :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_isfifo" c_s_isfifo :: CMode -> CInt s_isreg :: CMode -> Bool s_isreg cm = c_s_isreg cm /= 0 @@ -552,12 +594,12 @@ s_isfifo :: CMode -> Bool s_isfifo cm = c_s_isfifo cm /= 0 -foreign import javascript unsafe "(() => { return h$base_sizeof_stat; })" sizeof_stat :: Int -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_mtime($1_1,$1_2); })" st_mtime :: Ptr CStat -> IO CTime -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_size($1_1,$1_2); })" st_size :: Ptr CStat -> IO Int64 -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_mode($1_1,$1_2); })" st_mode :: Ptr CStat -> IO CMode -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_dev($1_1,$1_2); })" st_dev :: Ptr CStat -> IO CDev -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_ino($1_1,$1_2); })" st_ino :: Ptr CStat -> IO CIno +foreign import javascript unsafe "h$base_sizeof_stat" sizeof_stat :: Int +foreign import javascript unsafe "h$base_st_mtime" st_mtime :: Ptr CStat -> IO CTime +foreign import javascript unsafe "h$base_st_size" st_size :: Ptr CStat -> IO Int64 +foreign import javascript unsafe "h$base_st_mode" st_mode :: Ptr CStat -> IO CMode +foreign import javascript unsafe "h$base_st_dev" st_dev :: Ptr CStat -> IO CDev +foreign import javascript unsafe "h$base_st_ino" st_ino :: Ptr CStat -> IO CIno foreign import javascript unsafe "(() => { return h$base_echo; })" const_echo :: CInt foreign import javascript unsafe "(() => { return h$base_tcsanow; })" const_tcsanow :: CInt @@ -573,21 +615,21 @@ foreign import javascript unsafe "(() => { return h$base_fd_cloexec; })" const_fd_cloexec :: CLong foreign import javascript unsafe "(() => { return h$base_sizeof_termios; })" sizeof_termios :: Int foreign import javascript unsafe "(() => { return h$base_sizeof_sigset_t; })" sizeof_sigset_t :: Int -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_lflag($1_1,$1_2); })" c_lflag :: Ptr CTermios -> IO CTcflag -foreign import javascript unsafe "(($1_1,$1_2,$2) => { return h$base_poke_lflag($1_1,$1_2,$2); })" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO () -foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_ptr_c_cc($1_1,$1_2); })" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8) +foreign import javascript unsafe "h$base_lflag" c_lflag :: Ptr CTermios -> IO CTcflag +foreign import javascript unsafe "h$base_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO () +foreign import javascript unsafe "h$base_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8) s_issock :: CMode -> Bool s_issock cmode = c_s_issock cmode /= 0 -foreign import javascript unsafe "(($1) => { return h$base_c_s_issock($1); })" c_s_issock :: CMode -> CInt +foreign import javascript unsafe "h$base_c_s_issock" c_s_issock :: CMode -> CInt foreign import javascript unsafe "(() => { return h$base_default_buffer_size; })" dEFAULT_BUFFER_SIZE :: Int foreign import javascript unsafe "(() => { return h$base_SEEK_CUR; })" sEEK_CUR :: CInt foreign import javascript unsafe "(() => { return h$base_SEEK_SET; })" sEEK_SET :: CInt foreign import javascript unsafe "(() => { return h$base_SEEK_END; })" sEEK_END :: CInt -- fixme, unclear if these can be supported, remove? -foreign import javascript unsafe "(($1, $2) => { return h$base_c_fcntl_read($1,$2); })" c_fcntl_read :: CInt -> CInt -> IO CInt -foreign import javascript unsafe "(($1, $2, $3) => { return h$base_c_fcntl_write($1,$2,$3); })" c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt -foreign import javascript unsafe "(($1,$2,$3_1,$3_2) => { return h$base_c_fcntl_lock($1,$2,$3_1,$3_2); })" c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt +foreign import javascript unsafe "h$base_c_fcntl_read" c_fcntl_read :: CInt -> CInt -> IO CInt +foreign import javascript unsafe "h$base_c_fcntl_write" c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt +foreign import javascript unsafe "h$base_c_fcntl_lock" c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt #else diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs --- a/Text/Read/Lex.hs +++ b/Text/Read/Lex.hs @@ -112,7 +112,7 @@ -- space problems in #5688 -- Ways this is conservative: -- * the floatRange is in base 2, but we pretend it is in base 10 --- * we pad the floateRange a bit, just in case it is very small +-- * we pad the floatRange a bit, just in case it is very small -- and we would otherwise hit an edge case -- * We only worry about numbers that have an exponent. If they don't -- have an exponent then the Rational won't be much larger than the diff --git a/Type/Reflection.hs b/Type/Reflection.hs --- a/Type/Reflection.hs +++ b/Type/Reflection.hs @@ -44,6 +44,7 @@ , I.typeRepTyCon , I.rnfTypeRep , I.eqTypeRep + , I.decTypeRep , I.typeRepKind , I.splitApps diff --git a/Unsafe/Coerce.hs b/Unsafe/Coerce.hs --- a/Unsafe/Coerce.hs +++ b/Unsafe/Coerce.hs @@ -244,11 +244,11 @@ -- Why delay inlining to Phase 1? Because of the RULES for map/unsafeCoerce; -- see (U8) in Note [Implementing unsafeCoerce] --- | Coerce a value from one type to another, bypassing the type-checker. +-- | `unsafeCoerce` coerces a value from one type to another, bypassing the type-checker. -- -- There are several legitimate ways to use 'unsafeCoerce': -- --- 1. To coerce e.g. @Int@ to @HValue@, put it in a list of @HValue@, +-- 1. To coerce a lifted type such as @Int@ to @Any@, put it in a list of @Any@, -- and then later coerce it back to @Int@ before using it. -- -- 2. To produce e.g. @(a+b) :~: (b+a)@ from @unsafeCoerce Refl@. @@ -269,15 +269,35 @@ -- are the same -- but the proof of that relies on the complex, trusted -- implementation of @Typeable@. -- --- 4. The "reflection trick", which takes advantage of the fact that in +-- 4. (superseded) The "reflection trick", which takes advantage of the fact that in -- @class C a where { op :: ty }@, we can safely coerce between @C a@ and @ty@ -- (which have different kinds!) because it's really just a newtype. -- Note: there is /no guarantee, at all/ that this behavior will be supported -- into perpetuity. +-- It is now preferred to use `withDict` in @GHC.Magic.Dict@, which +-- is type-safe. See Note [withDict] in GHC.Tc.Instance.Class for details. -- +-- 5. (superseded) Casting between two types which have exactly the same structure: +-- between a newtype of T and T, or between types which differ only +-- in "phantom" type parameters. +-- It is now preferred to use `coerce` from @Data.Coerce@, which +-- is type-safe. -- --- For safe zero-cost coercions you can instead use the 'Data.Coerce.coerce' function from --- "Data.Coerce". +-- Other uses of 'unsafeCoerce' are undefined. In particular, you should not use +-- 'unsafeCoerce' to cast a T to an algebraic data type D, unless T is also +-- an algebraic data type. For example, do not cast @'Int'->'Int'@ to 'Bool', even if +-- you later cast that 'Bool' back to @'Int'->'Int'@ before applying it. The reasons +-- have to do with GHC's internal representation details (for the cognoscenti, data values +-- can be entered but function closures cannot). If you want a safe type to cast things +-- to, use 'Any', which is not an algebraic data type. + +-- NB. It is tempting to think that casting a value to a type that it doesn't have is safe +-- as long as you don't "do anything" with the value in its cast form, such as seq on it. This +-- isn't the case: the compiler can insert seqs itself, and if these happen at the wrong type, +-- Bad Things Might Happen. See bug #1616: in this case we cast a function of type (a,b) -> (a,b) +-- to () -> () and back again. The strictness analyser saw that the function was strict, but +-- the wrapper had type () -> (), and hence the wrapper de-constructed the (), the worker re-constructed +-- a new (), with the result that the code ended up with "case () of (a,b) -> ...". unsafeCoerce :: forall (a :: Type) (b :: Type) . a -> b unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x diff --git a/aclocal.m4 b/aclocal.m4 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -14,6 +14,32 @@ ])# FP_COMPUTE_INT +# FP_COMPUTE_OFFSET(VARIABLE, TYPE, MEMBER, INCLUDES) +# --------------------------------------------------- +# Assign VARIABLE the offset of MEMBER in struct TYPE using INCLUDES +# for compilation. If compilation fails, VARIABLE is set to -1. Works for +# cross-compilation, too. +AC_DEFUN([FP_COMPUTE_OFFSET], +[AC_MSG_CHECKING([offset of [$2].[$3]]) +FP_COMPUTE_INT([$1], [(offsetof(struct [$2], [$3]))], [$4 +#include ], AC_MSG_ERROR([could not determine offset of $2.$3])) +AC_MSG_RESULT($[$1]) +AC_DEFINE_UNQUOTED([$1], $[$1], [Offset of $2.$3]) +]) # FP_COMPUTE_OFFSET + +# FP_COMPUTE_SIZE(VARIABLE, TYPE, MEMBER, INCLUDES) +# --------------------------------------------------- +# Assign VARIABLE the offset of MEMBER in struct TYPE using INCLUDES +# for compilation. If compilation fails, VARIABLE is set to -1. Works for +# cross-compilation, too. +AC_DEFUN([FP_COMPUTE_SIZE], +[AC_MSG_CHECKING([size of [$2].[$3]]) +FP_COMPUTE_INT([$1], [(sizeof(((struct [$2] *)0)->[$3]))], [$4 +#include ], AC_MSG_ERROR([could not determine size of $2.$3])) +AC_MSG_RESULT($[$1]) +AC_DEFINE_UNQUOTED([$1], $[$1], [Size of $2.$3]) +]) # FP_COMPUTE_SIZE + # FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1]) # ------------------------------------------------------------------------------- # Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,24 +1,19 @@ cabal-version: 3.0 name: base -version: 4.18.3.0 +version: 4.19.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE maintainer: Core Libraries Committee bug-reports: https://github.com/haskell/core-libraries-committee/issues -synopsis: Core data structures and operations +synopsis: Basic libraries category: Prelude build-type: Configure -description: Haskell's base library provides, among other things, core types (e.g. [Bool]("Data.Bool") and [Int]("Data.Int")), - data structures (e.g. [List]("Data.List"), [Tuple]("Data.Tuple") and [Maybe]("Data.Maybe")), - the [Exception]("Control.Exception") mechanism, and the [IO]("System.IO") & [Concurrency]("Control.Concurrent") operations. - The "Prelude" module, which is imported by default, exposes a curated set of types and functions from other modules. - - Other data structures like [Map](https://hackage.haskell.org/package/containers/docs/Data-Map.html), - [Set](https://hackage.haskell.org/package/containers/docs/Data-Set.html) are available in the [containers](https://hackage.haskell.org/package/containers) library. - To work with textual data, use the [text](https://hackage.haskell.org/package/text/docs/Data-Text.html) library. - +description: + This package contains the Standard Haskell "Prelude" and its support libraries, + and a large collection of useful libraries ranging from data + structures to parsing combinators and debugging utilities. extra-tmp-files: autom4te.cache @@ -91,7 +86,7 @@ build-depends: rts == 1.0.*, - ghc-prim >= 0.5.1.0 && < 0.11, + ghc-prim >= 0.5.1.0 && < 0.12, ghc-bignum >= 1.0 && < 2.0 exposed-modules: @@ -356,6 +351,7 @@ GHC.Event.IntVar GHC.Event.PSQ GHC.Event.Unique + GHC.Foreign.Internal -- GHC.IOPort -- TODO: hide again after debug GHC.Unicode.Internal.Bits GHC.Unicode.Internal.Char.DerivedCoreProperties @@ -481,6 +477,7 @@ GHC.JS.Prim GHC.JS.Prim.Internal GHC.JS.Prim.Internal.Build + GHC.JS.Foreign.Callback -- We need to set the unit id to base (without a version number) -- as it's magic. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,30 +1,54 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) -## 4.18.3.0 *January 2025* - * Shipped with GHC 9.6.7. - * Fix interaction between `fork` and the `kqueue`-based IO manager ([#24672](https://gitlab.haskell.org/ghc/ghc/-/issues/24672)). - -## 4.18.2.1 *April 2024* - * Various documentation improvements +## 4.19.0.0 *October 2023* -## 4.18.2.0 *January 2024* + * Shipped with GHC 9.8.1 + * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`. + Use `{-# OPTIONS_GHC -Wno-x-partial #-}` to disable it. + ([CLC proposal #87](https://github.com/haskell/core-libraries-committee/issues/87) and [#114](https://github.com/haskell/core-libraries-committee/issues/114)) + * `GHC.Conc.Sync` now exports `fromThreadId :: ThreadId -> Word64`, which maps a thread to a per-process-unique identifier ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117)) + * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110)) + * `maximumBy`/`minimumBy` are now marked as `INLINE` improving performance for unpackable + types significantly. + * Add `INLINABLE` pragmas to `generic*` functions in Data.OldList ([CLC proposal #129](https://github.com/haskell/core-libraries-committee/issues/130)) + * Export `getSolo` from `Data.Tuple`. + ([CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113)) + * Add `Type.Reflection.decTypeRep`, `Data.Typeable.decT` and `Data.Typeable.hdecT` equality decisions functions. + ([CLC proposal #98](https://github.com/haskell/core-libraries-committee/issues/98)) + * Add `Data.Functor.unzip` ([CLC proposal #88](https://github.com/haskell/core-libraries-committee/issues/88)) + * Add `System.Mem.Weak.{get,set}FinalizerExceptionHandler`, which allows the user to set the global handler invoked by when a `Weak` pointer finalizer throws an exception. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126)) + * Add `System.Mem.Weak.printToHandleFinalizerExceptionHandler`, which can be used with `setFinalizerExceptionHandler` to print exceptions thrown by finalizers to the given `Handle`. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126)) + * Add `Data.List.unsnoc` ([CLC proposal #165](https://github.com/haskell/core-libraries-committee/issues/165)) + * Implement more members of `instance Foldable (Compose f g)` explicitly. + ([CLC proposal #57](https://github.com/haskell/core-libraries-committee/issues/57)) + * Add `Eq` and `Ord` instances for `SSymbol`, `SChar`, and `SNat`. + ([CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148)) + * Add `COMPLETE` pragmas to the `TypeRep`, `SSymbol`, `SChar`, and `SNat` pattern synonyms. + ([CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149)) + * Make `($)` representation polymorphic ([CLC proposal #132](https://github.com/haskell/core-libraries-committee/issues/132)) + * Make `(&)` representation polymorphic in the return type ([CLC proposal #158](https://github.com/haskell/core-libraries-committee/issues/158)) + * Implemented [GHC Proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), + adding the class `Unsatisfiable :: ErrorMessage -> TypeError` to `GHC.TypeError`, + which provides a mechanism for custom type errors that reports the errors in + a more predictable behaviour than `TypeError`. + * Add more instances for `Compose`: `Enum`, `Bounded`, `Num`, `Real`, `Integral` ([CLC proposal #160](https://github.com/haskell/core-libraries-committee/issues/160)) + * Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139)) + * Change codebuffers to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134)) + * Add nominal role annotations to SNat/SSymbol/SChar ([CLC proposal #170](https://github.com/haskell/core-libraries-committee/issues/170)) * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/). - * Improve String & IsString documentation. - -## 4.18.1.0 *September 2023* - - * Add missing int64/word64-to-double/float rules ([CLC Proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)) - - * Restore `mingwex` dependency on Windows (#23309). - - * Fix an incorrect CPP guard on `darwin_HOST_OS`. + * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8)) + * Deprecate `Data.List.NonEmpty.unzip` ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86)) + * Fixed exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192)) + * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188)) + * Add rewrite rules for conversion between `Int64`/`Word64` and `Float`/`Double` on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)). ## 4.18.0.0 *March 2023* - * Add `INLINABLE` pragmas to `generic*` functions in Data.OldList ([CLC proposal #129](https://github.com/haskell/core-libraries-committee/issues/130)) + * Shipped with GHC 9.6.1 * `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117)) * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91)) + * Add `forall a. Functor (p a)` superclass for `Bifunctor p`. * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and `(,,,,,) a b c d e f`. * Exceptions thrown by weak pointer finalizers can now be reported by setting @@ -57,6 +81,9 @@ ([CLC proposal #50](https://github.com/haskell/core-libraries-committee/issues/50), [the migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)) + * Switch to a pure Haskell implementation of `GHC.Unicode` + ([CLC proposals #59](https://github.com/haskell/core-libraries-committee/issues/59) + and [#130](https://github.com/haskell/core-libraries-committee/issues/130)) * Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/). * Add standard Unicode case predicates `isUpperCase` and `isLowerCase` to `GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode @@ -93,12 +120,13 @@ * Add functions `traceWith`, `traceShowWith`, `traceEventWith` to `Debug.Trace`, per [CLC proposal #36](https://github.com/haskell/core-libraries-committee/issues/36). - * Refactor `generalCategory` to stop very large literal string being inlined to call-sites. - ([CLC proposal #130](https://github.com/haskell/core-libraries-committee/issues/130)) - * Add INLINABLE pragmas to `generic*` functions in Data.OldList ([CLC proposal #129](https://github.com/haskell/core-libraries-committee/issues/130)) + * Export `List` from `GHC.List` + ([CLC proposal #186](https://github.com/haskell/core-libraries-committee/issues/186)). ## 4.17.0.0 *August 2022* + * Shipped with GHC 9.4.1 + * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`. * Add `Generically` and `Generically1` to `GHC.Generics` for deriving generic @@ -178,6 +206,9 @@ errors. `TypeError` is re-exported from `GHC.TypeLits` for backwards compatibility. + * Comparison constraints in `Data.Type.Ord` (e.g. `<=`) now use the new + `GHC.TypeError.Assert` type family instead of type equality with `~`. + ## 4.16.3.0 *May 2022* * Shipped with GHC 9.2.4 @@ -205,6 +236,8 @@ ## 4.16.0.0 *Nov 2021* + * Shipped with GHC 9.2.1 + * The unary tuple type, `Solo`, is now exported by `Data.Tuple`. * Add a `Typeable` constraint to `fromStaticPtr` in the class `GHC.StaticPtr.IsStatic`. @@ -255,9 +288,6 @@ * `fromInteger :: Integer -> Float/Double` now consistently round to the nearest value, with ties to even. - * Comparison constraints in `Data.Type.Ord` (e.g. `<=`) now use the new - `GHC.TypeError.Assert` type family instead of type equality with `~`. - * Additions to `Data.Bits`: - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument, @@ -267,6 +297,8 @@ - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. ## 4.15.0.0 *Feb 2021* + + * Shipped with GHC 9.0.1 * `openFile` now calls the `open` system call with an `interruptible` FFI call, ensuring that the call can be interrupted with `SIGINT` on POSIX diff --git a/configure b/configure --- a/configure +++ b/configure @@ -4317,6 +4317,693 @@ + +# Compute offsets/sizes used by jsbits/base.js +if test "$host" = "javascript-ghcjs" +then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_mode" >&5 +$as_echo_n "checking offset of stat.st_mode... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_mode))" "OFFSET_STAT_ST_MODE" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_mode" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_MODE" >&5 +$as_echo "$OFFSET_STAT_ST_MODE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_MODE $OFFSET_STAT_ST_MODE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_dev" >&5 +$as_echo_n "checking offset of stat.st_dev... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_dev))" "OFFSET_STAT_ST_DEV" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_dev" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_DEV" >&5 +$as_echo "$OFFSET_STAT_ST_DEV" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_DEV $OFFSET_STAT_ST_DEV +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_uid" >&5 +$as_echo_n "checking offset of stat.st_uid... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_uid))" "OFFSET_STAT_ST_UID" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_uid" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_UID" >&5 +$as_echo "$OFFSET_STAT_ST_UID" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_UID $OFFSET_STAT_ST_UID +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_gid" >&5 +$as_echo_n "checking offset of stat.st_gid... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_gid))" "OFFSET_STAT_ST_GID" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_gid" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_GID" >&5 +$as_echo "$OFFSET_STAT_ST_GID" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_GID $OFFSET_STAT_ST_GID +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_nlink" >&5 +$as_echo_n "checking offset of stat.st_nlink... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_nlink))" "OFFSET_STAT_ST_NLINK" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_nlink" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_NLINK" >&5 +$as_echo "$OFFSET_STAT_ST_NLINK" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_NLINK $OFFSET_STAT_ST_NLINK +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_rdev" >&5 +$as_echo_n "checking offset of stat.st_rdev... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_rdev))" "OFFSET_STAT_ST_RDEV" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_rdev" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_RDEV" >&5 +$as_echo "$OFFSET_STAT_ST_RDEV" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_RDEV $OFFSET_STAT_ST_RDEV +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_size" >&5 +$as_echo_n "checking offset of stat.st_size... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_size))" "OFFSET_STAT_ST_SIZE" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_size" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_SIZE" >&5 +$as_echo "$OFFSET_STAT_ST_SIZE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_SIZE $OFFSET_STAT_ST_SIZE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_blksize" >&5 +$as_echo_n "checking offset of stat.st_blksize... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_blksize))" "OFFSET_STAT_ST_BLKSIZE" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_blksize" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_BLKSIZE" >&5 +$as_echo "$OFFSET_STAT_ST_BLKSIZE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_BLKSIZE $OFFSET_STAT_ST_BLKSIZE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_blocks" >&5 +$as_echo_n "checking offset of stat.st_blocks... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_blocks))" "OFFSET_STAT_ST_BLOCKS" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_blocks" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_BLOCKS" >&5 +$as_echo "$OFFSET_STAT_ST_BLOCKS" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_BLOCKS $OFFSET_STAT_ST_BLOCKS +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_ino" >&5 +$as_echo_n "checking offset of stat.st_ino... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_ino))" "OFFSET_STAT_ST_INO" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_ino" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_INO" >&5 +$as_echo "$OFFSET_STAT_ST_INO" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_INO $OFFSET_STAT_ST_INO +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_atime" >&5 +$as_echo_n "checking offset of stat.st_atime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_atime))" "OFFSET_STAT_ST_ATIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_atime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_ATIME" >&5 +$as_echo "$OFFSET_STAT_ST_ATIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_ATIME $OFFSET_STAT_ST_ATIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_atim.tv_nsec" >&5 +$as_echo_n "checking offset of stat.st_atim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_atim.tv_nsec))" "OFFSET_STAT_ST_ATIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_atim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_ATIM_TV_NSEC" >&5 +$as_echo "$OFFSET_STAT_ST_ATIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_ATIM_TV_NSEC $OFFSET_STAT_ST_ATIM_TV_NSEC +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_mtime" >&5 +$as_echo_n "checking offset of stat.st_mtime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_mtime))" "OFFSET_STAT_ST_MTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_mtime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_MTIME" >&5 +$as_echo "$OFFSET_STAT_ST_MTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_MTIME $OFFSET_STAT_ST_MTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_mtim.tv_nsec" >&5 +$as_echo_n "checking offset of stat.st_mtim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_mtim.tv_nsec))" "OFFSET_STAT_ST_MTIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_mtim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_MTIM_TV_NSEC" >&5 +$as_echo "$OFFSET_STAT_ST_MTIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_MTIM_TV_NSEC $OFFSET_STAT_ST_MTIM_TV_NSEC +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_ctime" >&5 +$as_echo_n "checking offset of stat.st_ctime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_ctime))" "OFFSET_STAT_ST_CTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_ctime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_CTIME" >&5 +$as_echo "$OFFSET_STAT_ST_CTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_CTIME $OFFSET_STAT_ST_CTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of stat.st_ctim.tv_nsec" >&5 +$as_echo_n "checking offset of stat.st_ctim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct stat, st_ctim.tv_nsec))" "OFFSET_STAT_ST_CTIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of stat.st_ctim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_STAT_ST_CTIM_TV_NSEC" >&5 +$as_echo "$OFFSET_STAT_ST_CTIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_STAT_ST_CTIM_TV_NSEC $OFFSET_STAT_ST_CTIM_TV_NSEC +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_mode" >&5 +$as_echo_n "checking size of stat.st_mode... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_mode))" "SIZEOF_STAT_ST_MODE" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_mode" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_MODE" >&5 +$as_echo "$SIZEOF_STAT_ST_MODE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_MODE $SIZEOF_STAT_ST_MODE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_dev" >&5 +$as_echo_n "checking size of stat.st_dev... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_dev))" "SIZEOF_STAT_ST_DEV" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_dev" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_DEV" >&5 +$as_echo "$SIZEOF_STAT_ST_DEV" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_DEV $SIZEOF_STAT_ST_DEV +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_uid" >&5 +$as_echo_n "checking size of stat.st_uid... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_uid))" "SIZEOF_STAT_ST_UID" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_uid" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_UID" >&5 +$as_echo "$SIZEOF_STAT_ST_UID" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_UID $SIZEOF_STAT_ST_UID +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_gid" >&5 +$as_echo_n "checking size of stat.st_gid... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_gid))" "SIZEOF_STAT_ST_GID" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_gid" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_GID" >&5 +$as_echo "$SIZEOF_STAT_ST_GID" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_GID $SIZEOF_STAT_ST_GID +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_nlink" >&5 +$as_echo_n "checking size of stat.st_nlink... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_nlink))" "SIZEOF_STAT_ST_NLINK" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_nlink" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_NLINK" >&5 +$as_echo "$SIZEOF_STAT_ST_NLINK" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_NLINK $SIZEOF_STAT_ST_NLINK +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_rdev" >&5 +$as_echo_n "checking size of stat.st_rdev... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_rdev))" "SIZEOF_STAT_ST_RDEV" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_rdev" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_RDEV" >&5 +$as_echo "$SIZEOF_STAT_ST_RDEV" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_RDEV $SIZEOF_STAT_ST_RDEV +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_size" >&5 +$as_echo_n "checking size of stat.st_size... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_size))" "SIZEOF_STAT_ST_SIZE" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_size" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_SIZE" >&5 +$as_echo "$SIZEOF_STAT_ST_SIZE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_SIZE $SIZEOF_STAT_ST_SIZE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_blksize" >&5 +$as_echo_n "checking size of stat.st_blksize... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_blksize))" "SIZEOF_STAT_ST_BLKSIZE" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_blksize" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_BLKSIZE" >&5 +$as_echo "$SIZEOF_STAT_ST_BLKSIZE" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_BLKSIZE $SIZEOF_STAT_ST_BLKSIZE +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_blocks" >&5 +$as_echo_n "checking size of stat.st_blocks... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_blocks))" "SIZEOF_STAT_ST_BLOCKS" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_blocks" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_BLOCKS" >&5 +$as_echo "$SIZEOF_STAT_ST_BLOCKS" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_BLOCKS $SIZEOF_STAT_ST_BLOCKS +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_ino" >&5 +$as_echo_n "checking size of stat.st_ino... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_ino))" "SIZEOF_STAT_ST_INO" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_ino" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_INO" >&5 +$as_echo "$SIZEOF_STAT_ST_INO" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_INO $SIZEOF_STAT_ST_INO +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_atime" >&5 +$as_echo_n "checking size of stat.st_atime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_atime))" "SIZEOF_STAT_ST_ATIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_atime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_ATIME" >&5 +$as_echo "$SIZEOF_STAT_ST_ATIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_ATIME $SIZEOF_STAT_ST_ATIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_atim.tv_nsec" >&5 +$as_echo_n "checking size of stat.st_atim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_atim.tv_nsec))" "SIZEOF_STAT_ST_ATIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_atim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_ATIM_TV_NSEC" >&5 +$as_echo "$SIZEOF_STAT_ST_ATIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_ATIM_TV_NSEC $SIZEOF_STAT_ST_ATIM_TV_NSEC +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_mtime" >&5 +$as_echo_n "checking size of stat.st_mtime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_mtime))" "SIZEOF_STAT_ST_MTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_mtime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_MTIME" >&5 +$as_echo "$SIZEOF_STAT_ST_MTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_MTIME $SIZEOF_STAT_ST_MTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_mtim.tv_nsec" >&5 +$as_echo_n "checking size of stat.st_mtim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_mtim.tv_nsec))" "SIZEOF_STAT_ST_MTIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_mtim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_MTIM_TV_NSEC" >&5 +$as_echo "$SIZEOF_STAT_ST_MTIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_MTIM_TV_NSEC $SIZEOF_STAT_ST_MTIM_TV_NSEC +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_ctime" >&5 +$as_echo_n "checking size of stat.st_ctime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_ctime))" "SIZEOF_STAT_ST_CTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_ctime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_CTIME" >&5 +$as_echo "$SIZEOF_STAT_ST_CTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_CTIME $SIZEOF_STAT_ST_CTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of stat.st_ctim.tv_nsec" >&5 +$as_echo_n "checking size of stat.st_ctim.tv_nsec... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct stat *)0)->st_ctim.tv_nsec))" "SIZEOF_STAT_ST_CTIM_TV_NSEC" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of stat.st_ctim.tv_nsec" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_STAT_ST_CTIM_TV_NSEC" >&5 +$as_echo "$SIZEOF_STAT_ST_CTIM_TV_NSEC" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STAT_ST_CTIM_TV_NSEC $SIZEOF_STAT_ST_CTIM_TV_NSEC +_ACEOF + + + # The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of struct stat" >&5 +$as_echo_n "checking size of struct stat... " >&6; } +if ${ac_cv_sizeof_struct_stat+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (struct stat))" "ac_cv_sizeof_struct_stat" "#include +"; then : + +else + if test "$ac_cv_type_struct_stat" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (struct stat) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_struct_stat=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_struct_stat" >&5 +$as_echo "$ac_cv_sizeof_struct_stat" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STRUCT_STAT $ac_cv_sizeof_struct_stat +_ACEOF + + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of utimbuf.actime" >&5 +$as_echo_n "checking offset of utimbuf.actime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct utimbuf, actime))" "OFFSET_UTIMBUF_ACTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of utimbuf.actime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_UTIMBUF_ACTIME" >&5 +$as_echo "$OFFSET_UTIMBUF_ACTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_UTIMBUF_ACTIME $OFFSET_UTIMBUF_ACTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking offset of utimbuf.modtime" >&5 +$as_echo_n "checking offset of utimbuf.modtime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(offsetof(struct utimbuf, modtime))" "OFFSET_UTIMBUF_MODTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine offset of utimbuf.modtime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OFFSET_UTIMBUF_MODTIME" >&5 +$as_echo "$OFFSET_UTIMBUF_MODTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OFFSET_UTIMBUF_MODTIME $OFFSET_UTIMBUF_MODTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of utimbuf.actime" >&5 +$as_echo_n "checking size of utimbuf.actime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct utimbuf *)0)->actime))" "SIZEOF_UTIMBUF_ACTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of utimbuf.actime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_UTIMBUF_ACTIME" >&5 +$as_echo "$SIZEOF_UTIMBUF_ACTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UTIMBUF_ACTIME $SIZEOF_UTIMBUF_ACTIME +_ACEOF + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of utimbuf.modtime" >&5 +$as_echo_n "checking size of utimbuf.modtime... " >&6; } +if ac_fn_c_compute_int "$LINENO" "(sizeof(((struct utimbuf *)0)->modtime))" "SIZEOF_UTIMBUF_MODTIME" "#include +#include "; then : + +else + as_fn_error $? "could not determine size of utimbuf.modtime" "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $SIZEOF_UTIMBUF_MODTIME" >&5 +$as_echo "$SIZEOF_UTIMBUF_MODTIME" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UTIMBUF_MODTIME $SIZEOF_UTIMBUF_MODTIME +_ACEOF + + + # The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of struct utimbuf" >&5 +$as_echo_n "checking size of struct utimbuf... " >&6; } +if ${ac_cv_sizeof_struct_utimbuf+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (struct utimbuf))" "ac_cv_sizeof_struct_utimbuf" "#include +"; then : + +else + if test "$ac_cv_type_struct_utimbuf" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (struct utimbuf) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_struct_utimbuf=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_struct_utimbuf" >&5 +$as_echo "$ac_cv_sizeof_struct_utimbuf" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_STRUCT_UTIMBUF $ac_cv_sizeof_struct_utimbuf +_ACEOF + + +fi + # map standard C types and ISO types to Haskell types diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -126,6 +126,51 @@ AC_SUBST(ICONV_INCLUDE_DIRS) AC_SUBST(ICONV_LIB_DIRS) + +# Compute offsets/sizes used by jsbits/base.js +if test "$host" = "javascript-ghcjs" +then + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_MODE], [stat], [st_mode], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_DEV], [stat], [st_dev], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_UID], [stat], [st_uid], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_GID], [stat], [st_gid], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_NLINK], [stat], [st_nlink], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_RDEV], [stat], [st_rdev], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_SIZE], [stat], [st_size], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_BLKSIZE], [stat], [st_blksize], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_BLOCKS], [stat], [st_blocks], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_INO], [stat], [st_ino], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_ATIME], [stat], [st_atime], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_ATIM_TV_NSEC], [stat], [st_atim.tv_nsec], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_MTIME], [stat], [st_mtime], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_MTIM_TV_NSEC], [stat], [st_mtim.tv_nsec], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_CTIME], [stat], [st_ctime], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_STAT_ST_CTIM_TV_NSEC], [stat], [st_ctim.tv_nsec], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_MODE], [stat], [st_mode], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_DEV], [stat], [st_dev], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_UID], [stat], [st_uid], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_GID], [stat], [st_gid], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_NLINK], [stat], [st_nlink], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_RDEV], [stat], [st_rdev], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_SIZE], [stat], [st_size], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_BLKSIZE], [stat], [st_blksize], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_BLOCKS], [stat], [st_blocks], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_INO], [stat], [st_ino], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_ATIME], [stat], [st_atime], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_ATIM_TV_NSEC], [stat], [st_atim.tv_nsec], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_MTIME], [stat], [st_mtime], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_MTIM_TV_NSEC], [stat], [st_mtim.tv_nsec], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_CTIME], [stat], [st_ctime], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_STAT_ST_CTIM_TV_NSEC], [stat], [st_ctim.tv_nsec], [#include ]) + AC_CHECK_SIZEOF([struct stat], [], [#include ]) + + FP_COMPUTE_OFFSET([OFFSET_UTIMBUF_ACTIME], [utimbuf], [actime], [#include ]) + FP_COMPUTE_OFFSET([OFFSET_UTIMBUF_MODTIME], [utimbuf], [modtime], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_UTIMBUF_ACTIME], [utimbuf], [actime], [#include ]) + FP_COMPUTE_SIZE([SIZEOF_UTIMBUF_MODTIME], [utimbuf], [modtime], [#include ]) + AC_CHECK_SIZEOF([struct utimbuf], [], [#include ]) +fi + # map standard C types and ISO types to Haskell types FPTOOLS_CHECK_HTYPE(char) FPTOOLS_CHECK_HTYPE(signed char) diff --git a/include/HsBaseConfig.h.in b/include/HsBaseConfig.h.in --- a/include/HsBaseConfig.h.in +++ b/include/HsBaseConfig.h.in @@ -656,6 +656,60 @@ /* Define to Haskell type for wchar_t */ #undef HTYPE_WCHAR_T +/* Offset of stat.st_atime */ +#undef OFFSET_STAT_ST_ATIME + +/* Offset of stat.st_atim.tv_nsec */ +#undef OFFSET_STAT_ST_ATIM_TV_NSEC + +/* Offset of stat.st_blksize */ +#undef OFFSET_STAT_ST_BLKSIZE + +/* Offset of stat.st_blocks */ +#undef OFFSET_STAT_ST_BLOCKS + +/* Offset of stat.st_ctime */ +#undef OFFSET_STAT_ST_CTIME + +/* Offset of stat.st_ctim.tv_nsec */ +#undef OFFSET_STAT_ST_CTIM_TV_NSEC + +/* Offset of stat.st_dev */ +#undef OFFSET_STAT_ST_DEV + +/* Offset of stat.st_gid */ +#undef OFFSET_STAT_ST_GID + +/* Offset of stat.st_ino */ +#undef OFFSET_STAT_ST_INO + +/* Offset of stat.st_mode */ +#undef OFFSET_STAT_ST_MODE + +/* Offset of stat.st_mtime */ +#undef OFFSET_STAT_ST_MTIME + +/* Offset of stat.st_mtim.tv_nsec */ +#undef OFFSET_STAT_ST_MTIM_TV_NSEC + +/* Offset of stat.st_nlink */ +#undef OFFSET_STAT_ST_NLINK + +/* Offset of stat.st_rdev */ +#undef OFFSET_STAT_ST_RDEV + +/* Offset of stat.st_size */ +#undef OFFSET_STAT_ST_SIZE + +/* Offset of stat.st_uid */ +#undef OFFSET_STAT_ST_UID + +/* Offset of utimbuf.actime */ +#undef OFFSET_UTIMBUF_ACTIME + +/* Offset of utimbuf.modtime */ +#undef OFFSET_UTIMBUF_MODTIME + /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT @@ -680,8 +734,68 @@ /* The size of `kev.flags', as computed by sizeof. */ #undef SIZEOF_KEV_FLAGS +/* Size of stat.st_atime */ +#undef SIZEOF_STAT_ST_ATIME + +/* Size of stat.st_atim.tv_nsec */ +#undef SIZEOF_STAT_ST_ATIM_TV_NSEC + +/* Size of stat.st_blksize */ +#undef SIZEOF_STAT_ST_BLKSIZE + +/* Size of stat.st_blocks */ +#undef SIZEOF_STAT_ST_BLOCKS + +/* Size of stat.st_ctime */ +#undef SIZEOF_STAT_ST_CTIME + +/* Size of stat.st_ctim.tv_nsec */ +#undef SIZEOF_STAT_ST_CTIM_TV_NSEC + +/* Size of stat.st_dev */ +#undef SIZEOF_STAT_ST_DEV + +/* Size of stat.st_gid */ +#undef SIZEOF_STAT_ST_GID + +/* Size of stat.st_ino */ +#undef SIZEOF_STAT_ST_INO + +/* Size of stat.st_mode */ +#undef SIZEOF_STAT_ST_MODE + +/* Size of stat.st_mtime */ +#undef SIZEOF_STAT_ST_MTIME + +/* Size of stat.st_mtim.tv_nsec */ +#undef SIZEOF_STAT_ST_MTIM_TV_NSEC + +/* Size of stat.st_nlink */ +#undef SIZEOF_STAT_ST_NLINK + +/* Size of stat.st_rdev */ +#undef SIZEOF_STAT_ST_RDEV + +/* Size of stat.st_size */ +#undef SIZEOF_STAT_ST_SIZE + +/* Size of stat.st_uid */ +#undef SIZEOF_STAT_ST_UID + /* The size of `struct MD5Context', as computed by sizeof. */ #undef SIZEOF_STRUCT_MD5CONTEXT + +/* The size of `struct stat', as computed by sizeof. */ +#undef SIZEOF_STRUCT_STAT + +/* The size of `struct utimbuf', as computed by sizeof. */ +#undef SIZEOF_STRUCT_UTIMBUF + +/* Size of utimbuf.actime */ +#undef SIZEOF_UTIMBUF_ACTIME + +/* Size of utimbuf.modtime */ +#undef SIZEOF_UTIMBUF_MODTIME /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS diff --git a/jsbits/base.js b/jsbits/base.js --- a/jsbits/base.js +++ b/jsbits/base.js @@ -14,11 +14,11 @@ TRACE_IO("base_access") #ifndef GHCJS_BROWSER if(h$isNode()) { - h$fs.stat(fd, function(err, fs) { - if(err) { + h$fs.access(h$decodeUtf8z(file, file_off), mode, function(err) { + if (err) { h$handleErrnoC(err, -1, 0, c); } else { - c(mode & fs.mode); // fixme is this ok? + c(0); } }); } else @@ -39,7 +39,13 @@ } function h$base_close(fd, c) { - TRACE_IO("base_close fd: " + fd) + TRACE_IO("base_close fd: " + fd) + return h$close(fd,c); +} + +function h$close(fd,c) { + if (c) { + //asynchronous var fdo = h$base_fds[fd]; if(fdo) { delete h$base_fds[fd]; @@ -59,6 +65,16 @@ h$errno = CONST_EINVAL; c(-1); } + } else { + //synchronous + try { + h$fs.closeSync(fd); + return 0; + } catch(err) { + h$setErrno(err); + return (-1); + } + } } function h$base_dup(fd, c) { @@ -230,12 +246,80 @@ #endif h$unsupported(-1, c); } + +function h$rename(old_path, old_path_off, new_path, new_path_off) { + TRACE_IO("rename") +#ifndef GHCJS_BROWSER + if (h$isNode()) { + try { + fs.renameSync(h$decodeUtf8z(old_path, old_path_off), h$decodeUtf8z(new_path, new_path_off)); + return 0; + } catch(e) { + h$setErrno(e); + return -1; + } + } else +#endif + h$unsupported(-1); +} + +function h$getcwd(buf, off, buf_size) { + TRACE_IO("getcwd") +#ifndef GHCJS_BROWSER + if (h$isNode()) { + try { + var cwd = h$encodeUtf8(process.cwd()); + h$copyMutableByteArray(cwd, 0, buf, off, cwd.len); + RETURN_UBX_TUP2(cwd, 0); + } catch (e) { + h$setErrno(e); + return -1; + } + } else +#endif + h$unsupported(-1); +} + +function h$realpath(path,off,resolved,resolved_off) { + TRACE_IO("realpath") +#ifndef GHCJS_BROWSER + if (h$isNode()) { + try { + var rp = h$encodeUtf8(fs.realpathSync(h$decodeUtf8z(path,off))); + if (resolved !== null) { + h$copyMutableByteArray(rp, 0, resolved, resolved_off, Math.min(resolved.len - resolved_off, rp.len)); + RETURN_UBX_TUP2(resolved, resolved_off); + } + RETURN_UBX_TUP2(rp, 0); + } catch (e) { + h$setErrno(e); + return -1; + } + } else +#endif + h$unsupported(-1); +} + function h$base_open(file, file_off, how, mode, c) { + return h$open(file,file_off,how,mode,c); +} + +function h$openat(dirfd, file, file_off, how, mode) { + if (dirfd != h$base_at_fdcwd) { + // we only support AT_FDWCD (open) until NodeJS provides "openat" + return h$unsupported(-1); + } + else { + return h$open(file,file_off,how,mode,undefined); + } +} + +function h$open(file, file_off, how, mode,c) { #ifndef GHCJS_BROWSER if(h$isNode()) { var flags, off; var fp = h$decodeUtf8z(file, file_off); - TRACE_IO("base_open: " + fp) + TRACE_IO("open: " + fp) var acc = how & h$base_o_accmode; // passing a number lets node.js use it directly as the flags (undocumented) if(acc === h$base_o_rdonly) { @@ -250,34 +334,64 @@ | ((how & h$base_o_creat) ? h$processConstants['fs']['O_CREAT'] : 0) | ((how & h$base_o_excl) ? h$processConstants['fs']['O_EXCL'] : 0) | ((how & h$base_o_append) ? h$processConstants['fs']['O_APPEND'] : 0); - h$fs.open(fp, flags, mode, function(err, fd) { - if(err) { - h$handleErrnoC(err, -1, 0, c); + if (c) { + // asynchronous + h$fs.open(fp, flags, mode, function(err, fd) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + var f = function(p) { + h$base_fds[fd] = { read: h$base_readFile + , write: h$base_writeFile + , close: h$base_closeFile + , fd: fd + , pos: p + , refs: 1 + }; + TRACE_IO("base_open: " + fp + " -> " + fd) + c(fd); + } + if(off === -1) { + h$fs.stat(fp, function(err, fs) { + if(err) h$handleErrnoC(err, -1, 0, c); else f(fs.size); + }); + } else { + f(0); + } + } + }); + } + else { + // synchronous + try { + var fd = h$fs.openSync(fp, flags, mode); + var f = function(p) { + h$base_fds[fd] = { read: h$base_readFile + , write: h$base_writeFile + , close: h$base_closeFile + , fd: fd + , pos: p + , refs: 1 + }; + TRACE_IO("open: " + fp + " -> " + fd) + } + if(off === -1) { + var fs = h$fs.statSync(fp); + f(fs.size); } else { - var f = function(p) { - h$base_fds[fd] = { read: h$base_readFile - , write: h$base_writeFile - , close: h$base_closeFile - , fd: fd - , pos: p - , refs: 1 - }; - TRACE_IO("base_open: " + fp + " -> " + fd) - c(fd); - } - if(off === -1) { - h$fs.stat(fp, function(err, fs) { - if(err) h$handleErrnoC(err, -1, 0, c); else f(fs.size); - }); - } else { - f(0); - } + f(0); } - }); + return fd; + } catch(err) { + h$setErrno(err); + return -1; + } + } } else #endif - h$unsupported(-1, c); + return h$unsupported(-1,c); } + function h$base_read(fd, buf, buf_off, n, c) { TRACE_IO("base_read: " + fd) var fdo = h$base_fds[fd]; @@ -319,16 +433,30 @@ // buf_off: offset in the buffer // n: number of bytes to write // c: continuation - TRACE_IO("base_write: " + fd) + TRACE_IO("base_write: " + fd) + return h$write(fd,buf,buf_off,n,c); +} - var fdo = h$base_fds[fd]; +function h$write(fd, buf, buf_off, n, c) { - if(fdo && fdo.write) { - fdo.write(fd, fdo, buf, buf_off, n, c); + if (c) { + var fdo = h$base_fds[fd]; + // asynchronous + if(fdo && fdo.write) { + fdo.write(fd, fdo, buf, buf_off, n, c); + } else { + h$fs.write(fd, buf.u8, buf_off, n, function(err, bytesWritten, buf0) { + h$handleErrnoC(err, -1, bytesWritten, c); + }); + } } else { - h$fs.write(fd, buf.u8, buf_off, n, function(err, bytesWritten, buf0) { - h$handleErrnoC(err, -1, bytesWritten, c); - }); + //synchronous + try { + return h$fs.writeSync(fd, buf.u8, buf_off, n); + } catch(err) { + h$setErrno(err); + return (-1); + } } } @@ -401,18 +529,8 @@ if(err) { h$handleErrnoC(err, 0, -1, c); // fixme } else { - h$long_from_number(fs.atime.getTime(), (h,l) => { - timbuf.i3[0] = h; - timbuf.i3[1] = l; - }); - h$long_from_number(fs.mtime.getTime(), (h,l) => { - timbuf.i3[2] = h; - timbuf.i3[3] = l; - }); - h$long_from_number(fs.ctime.getTime(), (h,l) => { - timbuf.i3[4] = h; - timbuf.i3[5] = l; - }); + h$base_store_field_number(timbuf, timbuf_off, OFFSET_UTIMBUF_ACTIME, SIZEOF_UTIMBUF_ACTIME, fs.atime.getTime()); + h$base_store_field_number(timbuf, timbuf_off, OFFSET_UTIMBUF_MODTIME, SIZEOF_UTIMBUF_MODTIME, fs.mtime.getTime()); c(0); } }); @@ -423,18 +541,20 @@ function h$base_waitpid(pid, stat, stat_off, options, c) { throw "h$base_waitpid"; } -/** @const */ var h$base_o_rdonly = 0x00000; -/** @const */ var h$base_o_wronly = 0x00001; -/** @const */ var h$base_o_rdwr = 0x00002; -/** @const */ var h$base_o_accmode = 0x00003; -/** @const */ var h$base_o_append = 0x00008; -/** @const */ var h$base_o_creat = 0x00200; -/** @const */ var h$base_o_trunc = 0x00400; -/** @const */ var h$base_o_excl = 0x00800; -/** @const */ var h$base_o_noctty = 0x20000; -/** @const */ var h$base_o_nonblock = 0x00004; -/** @const */ var h$base_o_binary = 0x00000; +const h$base_o_rdonly = 0x00000; +const h$base_o_wronly = 0x00001; +const h$base_o_rdwr = 0x00002; +const h$base_o_accmode = 0x00003; +const h$base_o_append = 0x00008; +const h$base_o_creat = 0x00200; +const h$base_o_trunc = 0x00400; +const h$base_o_excl = 0x00800; +const h$base_o_noctty = 0x20000; +const h$base_o_nonblock = 0x00004; +const h$base_o_binary = 0x00000; +const h$base_at_fdcwd = -100; + function h$base_c_s_isreg(mode) { return 1; } @@ -450,50 +570,109 @@ function h$base_c_s_isfifo(mode) { return 0; } +function h$base_c_fcntl_read(fd,cmd) { + return -1; +} +function h$base_c_fcntl_write(fd,cmd,value) { + return -1; +} +function h$base_c_fcntl_lock(fd,cmd,ptr,ptr_o) { + return -1; +} #ifndef GHCJS_BROWSER +// The `fileStat` is filled according to the layout of Emscripten's `stat` +// struct - defined in stat.h. We must use this layout due to this header +// file being used to retrieve the offsets for hsc files that peek into +// memory locations of structs directly. For more information see: +// https://gitlab.haskell.org/ghc/ghc/-/issues/22573 function h$base_fillStat(fs, b, off) { - if(off%4) throw "h$base_fillStat: not aligned"; + if(off%4) throw new Error("h$base_fillStat: not aligned"); var o = off>>2; - b.i3[o+0] = fs.mode; - h$long_from_number(fs.size, (h,l) => { - b.i3[o+1] = h; - b.i3[o+2] = l; - }); - b.i3[o+3] = 0; // fixme - b.i3[o+4] = 0; // fixme - b.i3[o+5] = fs.dev; - h$long_from_number(fs.ino, (h,l) => { - b.i3[o+6] = h; - b.i3[o+7] = l; - }); - b.i3[o+8] = fs.uid; - b.i3[o+9] = fs.gid; + // clear memory + for(var i=0;i<(SIZEOF_STRUCT_STAT>>2);i++) { + b.i3[o+i] = 0; + } + + // fill struct + h$base_store_field_number(b, off, OFFSET_STAT_ST_DEV, SIZEOF_STAT_ST_DEV, fs.dev); + h$base_store_field_number(b, off, OFFSET_STAT_ST_MODE, SIZEOF_STAT_ST_MODE, fs.mode); + h$base_store_field_number(b, off, OFFSET_STAT_ST_NLINK, SIZEOF_STAT_ST_NLINK, fs.nlink); + h$base_store_field_number(b, off, OFFSET_STAT_ST_UID, SIZEOF_STAT_ST_UID, fs.uid); + h$base_store_field_number(b, off, OFFSET_STAT_ST_GID, SIZEOF_STAT_ST_GID, fs.gid); + h$base_store_field_number(b, off, OFFSET_STAT_ST_RDEV, SIZEOF_STAT_ST_RDEV, fs.rdev); + h$base_store_field_number(b, off, OFFSET_STAT_ST_SIZE, SIZEOF_STAT_ST_SIZE, fs.size); + h$base_store_field_number(b, off, OFFSET_STAT_ST_BLKSIZE, SIZEOF_STAT_ST_BLKSIZE, fs.blksize); + h$base_store_field_number(b, off, OFFSET_STAT_ST_BLOCKS, SIZEOF_STAT_ST_BLOCKS, fs.blocks); + h$base_store_field_number(b, off, OFFSET_STAT_ST_INO, SIZEOF_STAT_ST_INO, fs.ino); + + var atimeS = Math.floor(fs.atimeMs/1000); + var atimeNs = (fs.atimeMs/1000 - atimeS) * 1000000000; + h$base_store_field_number(b, off, OFFSET_STAT_ST_ATIME, SIZEOF_STAT_ST_ATIME, atimeS); + h$base_store_field_number(b, off, OFFSET_STAT_ST_ATIM_TV_NSEC, SIZEOF_STAT_ST_ATIM_TV_NSEC, atimeNs); + var mtimeS = Math.floor(fs.mtimeMs/1000); + var mtimeNs = (fs.mtimeMs/1000 - mtimeS) * 1000000000; + h$base_store_field_number(b, off, OFFSET_STAT_ST_MTIME, SIZEOF_STAT_ST_MTIME, mtimeS); + h$base_store_field_number(b, off, OFFSET_STAT_ST_MTIM_TV_NSEC, SIZEOF_STAT_ST_MTIM_TV_NSEC, mtimeNs); + var ctimeS = Math.floor(fs.ctimeMs/1000); + var ctimeNs = (fs.ctimeMs/1000 - ctimeS) * 1000000000; + h$base_store_field_number(b, off, OFFSET_STAT_ST_CTIME, SIZEOF_STAT_ST_CTIME, ctimeS); + h$base_store_field_number(b, off, OFFSET_STAT_ST_CTIM_TV_NSEC, SIZEOF_STAT_ST_CTIM_TV_NSEC, ctimeNs); } #endif -// [mode,size1,size2,mtime1,mtime2,dev,ino1,ino2,uid,gid] all 32 bit -/** @const */ var h$base_sizeof_stat = 40; +function h$base_store_field_number(ptr, ptr_off, field_off, field_size, val) { + if(ptr_off%4) throw new Error("ptr not aligned"); + if(field_off%4) throw new Error("field not aligned"); + if(typeof val !== 'number') throw new Error("not a number: " + val); + if(field_size === 4) { + ptr.i3[(ptr_off>>2)+(field_off>>2)] = val; + } else if(field_size === 8) { + h$long_from_number(val, (h,l) => { + ptr.i3[(ptr_off>>2)+(field_off>>2)] = l; + ptr.i3[(ptr_off>>2)+(field_off>>2)+1] = h; + }); + } else { + throw new Error("unsupported field size: " + field_size); + } +} +function h$base_return_field(ptr, ptr_off, field_off, field_size) { + if(ptr_off%4) throw new Error("ptr not aligned"); + if(field_off%4) throw new Error("field not aligned"); + if(field_size === 4) { + return ptr.i3[(ptr_off>>2) + (field_off>>2)]; + } else if(field_size === 8) { + RETURN_UBX_TUP2(ptr.i3[(ptr_off>>2) + (field_off>>2)+1], ptr.i3[(ptr_off>>2) + (field_off>>2)]); + } else { + throw new Error("unsupported field size: " + field_size); + } +} + +function h$base_sizeof_stat() { + return SIZEOF_STRUCT_STAT; +} + function h$base_st_mtime(stat, stat_off) { - RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+3], stat.i3[(stat_off>>2)+4]); + // XXX should we use the nanoseconds? + return h$base_return_field(stat, stat_off, OFFSET_STAT_ST_MTIME, SIZEOF_STAT_ST_MTIME); } function h$base_st_size(stat, stat_off) { - RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+1], stat.i3[(stat_off>>2)+2]); + return h$base_return_field(stat, stat_off, OFFSET_STAT_ST_SIZE, SIZEOF_STAT_ST_SIZE); } function h$base_st_mode(stat, stat_off) { - return stat.i3[stat_off>>2]; + return h$base_return_field(stat, stat_off, OFFSET_STAT_ST_MODE, SIZEOF_STAT_ST_MODE); } function h$base_st_dev(stat, stat_off) { - return stat.i3[(stat_off>>2)+5]; + return h$base_return_field(stat, stat_off, OFFSET_STAT_ST_DEV, SIZEOF_STAT_ST_DEV); } function h$base_st_ino(stat, stat_off) { - RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+6], stat.i3[(stat_off>>2)+7]); + return h$base_return_field(stat, stat_off, OFFSET_STAT_ST_INO, SIZEOF_STAT_ST_INO); } /** @const */ var h$base_echo = 1; @@ -612,8 +791,14 @@ }); } + var h$base_stdinHandlerInstalled = false; + h$base_readStdin = function(fd, fdo, buf, buf_offset, n, c) { TRACE_IO("read stdin") + if(!h$base_stdinHandlerInstalled) { + process.stdin.on('readable', h$base_process_stdin); + h$base_stdinHandlerInstalled = true; + } h$base_stdin_waiting.enqueue({buf: buf, off: buf_offset, n: n, c: c}); h$base_process_stdin(); } @@ -668,7 +853,6 @@ c(0); } - process.stdin.on('readable', h$base_process_stdin); process.stdin.on('end', function() { h$base_stdin_eof = true; h$base_process_stdin(); }); h$base_isattyStdin = function() { return process.stdin.isTTY; }; @@ -751,7 +935,7 @@ , refs: 1 }; -var h$base_fdN = -2; // negative file descriptors are 'virtual', -1 is already used to indicated error +var h$base_fdN = -3; // negative file descriptors are 'virtual', -1 and -2 are reserved var h$base_fds = [h$base_stdin_fd, h$base_stdout_fd, h$base_stderr_fd]; function h$shutdownHaskellAndExit(code, fast) { @@ -835,4 +1019,22 @@ function h$__hscore_d_name(a,o) { RETURN_UBX_TUP2(h$encodeModifiedUtf8(a.name),0); +} + +function h$mkdir(path, path_offset, mode) { + if (!h$isNode()) { + throw "h$mkdir unsupported"; + } + const d = h$decodeUtf8z(path, path_offset); + try { + h$fs.mkdirSync(d, {mode: mode}); + } catch(e) { + // we can't directly set errno code, because numbers may not match + // e.g. e.errno is -17 for EEXIST while we would expect -20 + // this is probably an inconsistency between nodejs using the native + // environment and everything else using Emscripten-provided headers. + h$setErrno(e); + return -1; + } + return 0; } diff --git a/jsbits/errno.js b/jsbits/errno.js --- a/jsbits/errno.js +++ b/jsbits/errno.js @@ -50,8 +50,10 @@ if(es.indexOf('EINVAL') !== -1) return CONST_EINVAL; if(es.indexOf('ESPIPE') !== -1) return CONST_ESPIPE; if(es.indexOf('EBADF') !== -1) return CONST_EBADF; + if(es.indexOf('ENOSPC') !== -1) return CONST_ENOSPC; + if(es.indexOf('EACCES') !== -1) return CONST_EACCES; if(es.indexOf('Bad argument') !== -1) return CONST_ENOENT; // fixme? - throw ("setErrno not yet implemented: " + e); + throw ("setErrno not yet implemented for: " + e); } h$errno = getErr();