[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: Add a test for I/O managers
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Nov 5 21:02:56 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cc1c7c54 by Duncan Coutts at 2023-11-05T00:23:44-04:00
Add a test for I/O managers
It tries to cover the cases of multiple threads waiting on the same
fd for reading and multiple threads waiting for writing, including
wait cancellation by async exceptions.
It should work for any I/O manager, in-RTS or in-Haskell.
Unfortunately it will not currently work for Windows because it relies
on anonymous unix sockets. It could in principle be ported to use
Windows named pipes.
- - - - -
2e448f98 by Cheng Shao at 2023-11-05T00:23:44-04:00
Skip the IOManager test on wasm32 arch.
The test relies on the sockets API which are not (yet) available.
- - - - -
fe50eb35 by Cheng Shao at 2023-11-05T00:24:20-04:00
compiler: fix eager blackhole symbol in wasm32 NCG
- - - - -
af771148 by Cheng Shao at 2023-11-05T00:24:20-04:00
testsuite: fix optasm tests for wasm32
- - - - -
1b90735c by Matthew Pickering at 2023-11-05T00:24:20-04:00
testsuite: Add wasm32 to testsuite arches with NCG
The compiler --info reports that wasm32 compilers have a NCG, so we
should agree with that here.
- - - - -
db9a6496 by Alan Zimmerman at 2023-11-05T00:24:55-04:00
EPA: make locA a function, not a field name
And use it to generalise reLoc
The following for the windows pipeline one. 5.5%
Metric Increase:
T5205
- - - - -
833e250c by Simon Peyton Jones at 2023-11-05T00:25:31-04:00
Update the unification count in wrapUnifierX
Omitting this caused type inference to fail in #24146.
This was an accidental omision in my refactoring of the
equality solver.
- - - - -
e451139f by Andreas Klebinger at 2023-11-05T00:26:07-04:00
Remove an accidental git conflict marker from a comment.
- - - - -
7b29c39c by Tobias Haslop at 2023-11-05T16:02:28-05:00
Add laws relating between Foldable/Traversable with their Bi- superclasses
See https://github.com/haskell/core-libraries-committee/issues/205 for
discussion.
This commit also documents that the tuple instances only satisfy the
laws up to lazyness, similar to the documentation added in !9512.
- - - - -
9b546964 by Tobias Haslop at 2023-11-05T16:02:31-05:00
Elaborate on the quantified superclass of Bifunctor
This was requested in the comment
https://github.com/haskell/core-libraries-committee/issues/93#issuecomment-1597271700
for when Traversable becomes a superclass of Bitraversable, but similarly
applies to Functor/Bifunctor, which already are in a superclass relationship.
- - - - -
25 changed files:
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/ThToHs.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/src/Data/Bifoldable.hs
- libraries/base/src/Data/Bifunctor.hs
- libraries/base/src/Data/Bitraversable.hs
- testsuite/tests/cmm/should_compile/all.T
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/regalloc/all.T
- + testsuite/tests/rts/IOManager.hsc
- + testsuite/tests/rts/IOManager.stdout
- testsuite/tests/rts/Makefile
- testsuite/tests/rts/T5644/all.T
- testsuite/tests/rts/all.T
- testsuite/tests/simplCore/prog003/simplCore.oneShot.stderr → testsuite/tests/simplCore/prog003/simplCore-oneShot.stderr
- testsuite/tests/simplCore/prog003/simplCore.oneShot.stdout → testsuite/tests/simplCore/prog003/simplCore-oneShot.stdout
- testsuite/tests/simplCore/prog003/test.T
- testsuite/tests/simplCore/should_run/all.T
- + testsuite/tests/typecheck/should_compile/T24146.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -883,7 +883,7 @@ lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do
pure $
SomeWasmExpr ty_word $
WasmExpr $
- WasmSymConst "stg_EAGER_BLACKHOLE_info"
+ WasmSymConst "__stg_EAGER_BLACKHOLE_info"
GCEnter1 -> do
onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]
pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -278,7 +278,6 @@ pmcRecSel _ _ = return ()
{- Note [pmcPatBind doesn't warn on pattern guards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@pmcPatBind@'s main purpose is to check vanilla pattern bindings, like
->>>>>>> 8760510af3 (This MR is an implementation of the proposal #516.)
@x :: Int; Just x = e@, which is in a @PatBindRhs@ context.
But its caller is also called for individual pattern guards in a @StmtCtxt at .
For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1019,13 +1019,13 @@ exportlist1 :: { OrdList (LIE GhcPs) }
export :: { OrdList (LIE GhcPs) }
: maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }
; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)
- ; return $ unitOL $ reLocA $ sL span $ impExp } }
+ ; return $ unitOL $ reLoc $ sL span $ impExp } }
| maybe_warning_pragma 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $>
; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }
; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))
- ; return $ unitOL $ reLocA $ locImpExp } }
+ ; return $ unitOL $ reLoc $ locImpExp } }
| maybe_warning_pragma 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $>
- in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
+ in unitOL $ reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
@@ -1117,7 +1117,7 @@ importdecl :: { LImportDecl GhcPs }
, importDeclAnnAs = fst $8
}
; let loc = (comb5 $1 $6 $7 (snd $8) $9);
- ; fmap reLocA $ acs (\cs -> L loc $
+ ; fmap reLoc $ acs (\cs -> L loc $
ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False
, ideclName = $6, ideclPkgQual = snd $5
, ideclSource = snd $2, ideclSafe = snd $3
@@ -1192,9 +1192,9 @@ importlist1 :: { OrdList (LIE GhcPs) }
| import { $1 }
import :: { OrdList (LIE GhcPs) }
- : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
- | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
- | 'pattern' qcon { unitOL $ reLocA $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
+ : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
+ | 'module' modid {% fmap (unitOL . reLoc) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
+ | 'pattern' qcon { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -2174,7 +2174,7 @@ ctype :: { LHsType GhcPs }
, hst_xqual = NoExtField
, hst_body = $3 })) }
- | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
+ | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLoc $1) $3)) }
| type { $1 }
----------------------
@@ -2736,7 +2736,7 @@ exp :: { ECP }
-- Embed types into expressions and patterns for required type arguments
| 'type' atype
{% do { requireExplicitNamespaces (getLoc $1)
- ; return $ ECP $ mkHsEmbTyPV (comb2 $1 (reLoc $>)) (hsTok $1) $2 } }
+ ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (hsTok $1) $2 } }
infixexp :: { ECP }
: exp10 { $1 }
@@ -2998,7 +2998,7 @@ aexp2 :: { ECP }
-- Template Haskell Extension
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
- | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }
+ | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }
| SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
| SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
@@ -3036,8 +3036,8 @@ projection
| PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
splice_exp :: { LHsExpr GhcPs }
- : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }
- | splice_typed { fmap (uncurry HsTypedSplice) (reLocA $1) }
+ : splice_untyped { fmap (HsUntypedSplice noAnn) (reLoc $1) }
+ | splice_typed { fmap (uncurry HsTypedSplice) (reLoc $1) }
splice_untyped :: { Located (HsUntypedSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
@@ -3338,7 +3338,7 @@ alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
- acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 (reLoc $2)) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }
+ acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) }
| gdpats { $1 >>= \gdpats ->
return $ sL1 gdpats (reverse (unLoc gdpats)) }
@@ -3535,7 +3535,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
+ acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLoc $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -4361,7 +4361,7 @@ acsa a = do
return (a cs)
acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
-acsA a = reLocA <$> acs a
+acsA a = reLoc <$> acs a
acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP
acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
@@ -4421,7 +4421,7 @@ mcs ll = mj AnnCloseS ll
pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)
pvA a = do { av <- a
- ; return (reLocA av) }
+ ; return (reLoc av) }
pvN :: MonadP m => m (Located a) -> m (LocatedN a)
pvN a = do { (L l av) <- a
@@ -4475,7 +4475,7 @@ hsDoAnn (L l _) (L ll _) kw
listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor
listAsAnchor [] (L l _) = spanAsAnchor l
-listAsAnchor (h:_) s = spanAsAnchor (comb2 (reLoc h) s)
+listAsAnchor (h:_) s = spanAsAnchor (comb2 h s)
listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor
listAsAnchorM [] = Nothing
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Parser.Annotation (
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
la2na, na2la, n2l, l2n, l2l, la2la,
- reLoc, reLocA, reLocL, reLocC, reLocN,
+ reLoc,
HasLoc(..), getHasLocList,
srcSpan2e, la2e, realSrcSpan,
@@ -78,6 +78,7 @@ module GHC.Parser.Annotation (
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
HasAnnotation(..),
+ locA,
noLocA,
getLocA,
noSrcSpanA,
@@ -579,7 +580,7 @@ emptyComments = EpaComments []
-- Important that the fields are strict as these live inside L nodes which
-- are live for a long time.
-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }
+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locAn :: !SrcSpan }
deriving (Data, Eq)
-- See Note [XRec and Anno in the AST]
@@ -1016,27 +1017,23 @@ l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
na2la l = noAnnSrcSpan (locA l)
-reLoc :: LocatedAn a e -> Located e
-reLoc (L (SrcSpanAnn _ l) a) = L l a
+locA :: (HasLoc a) => a -> SrcSpan
+locA = getHasLoc
-reLocA :: Located e -> LocatedAn ann e
-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)
+reLoc :: (HasLoc (GenLocated a e), HasAnnotation b)
+ => GenLocated a e -> GenLocated b e
+reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
-reLocL :: LocatedN e -> LocatedA e
-reLocL (L l a) = (L (na2la l) a)
-
-reLocC :: LocatedN e -> LocatedC e
-reLocC (L l a) = (L (na2la l) a)
-
-reLocN :: LocatedN a -> Located a
-reLocN (L (SrcSpanAnn _ l) a) = L l a
-- ---------------------------------------------------------------------
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance (NoAnn ann) => HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
+instance HasAnnotation (SrcSpan) where
+ noAnnSrcSpan l = l
+
+instance HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
noLocA :: (HasAnnotation e) => a -> GenLocated e a
@@ -1060,11 +1057,14 @@ class HasLoc a where
-- ^ conveniently calculate locations for things without locations attached
getHasLoc :: a -> SrcSpan
-instance HasLoc (Located a) where
- getHasLoc (L l _) = l
+instance (HasLoc l) => HasLoc (GenLocated l a) where
+ getHasLoc (L l _) = getHasLoc l
+
+instance HasLoc SrcSpan where
+ getHasLoc l = l
-instance HasLoc (GenLocated (SrcSpanAnn' a) e) where
- getHasLoc (L (SrcSpanAnn _ l) _) = l
+instance HasLoc (SrcSpanAnn' a) where
+ getHasLoc (SrcSpanAnn _ l) = l
instance (HasLoc a) => (HasLoc (Maybe a)) where
getHasLoc (Just a) = getHasLoc a
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1727,7 +1727,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]
+ return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
cs <- getCommentsFor l
@@ -1807,7 +1807,7 @@ instance DisambECP (HsExpr GhcPs) where
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2
+ return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLoc op) e2
mkHsCasePV l e (L lm m) anns = do
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
@@ -2092,7 +2092,7 @@ instance DisambTD DataConBuilder where
= -- When the user writes data T = {-# UNPACK #-} Int :+ Bool
-- we apply {-# UNPACK #-} to the LHS
do lhs' <- addUnpackednessP unpk lhs
- let l = combineLocsA (reLocA unpk) constr_stuff
+ let l = combineLocsA (reLoc unpk) constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| otherwise =
do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1197,6 +1197,9 @@ if you do so.
-- Getters and setters of GHC.Tc.Utils.Env fields
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+getUnifiedRef :: TcS (IORef Int)
+getUnifiedRef = TcS (return . tcs_unified)
+
-- Getter of inerts and worklist
getInertSetRef :: TcS (IORef InertSet)
getInertSetRef = TcS (return . tcs_inerts)
@@ -2040,21 +2043,28 @@ wrapUnifierX :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
-> TcS (a, Bag Ct, [TcTyVar], RewriterSet)
wrapUnifierX ev role do_unifications
- = wrapTcS $
- do { defer_ref <- TcM.newTcRef emptyBag
- ; unified_ref <- TcM.newTcRef []
- ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)
- ; let env = UE { u_role = role
- , u_rewriters = rewriters
- , u_loc = ctEvLoc ev
- , u_defer = defer_ref
- , u_unified = Just unified_ref}
-
- ; res <- do_unifications env
-
- ; cts <- TcM.readTcRef defer_ref
- ; unified <- TcM.readTcRef unified_ref
- ; return (res, cts, unified, rewriters) }
+ = do { unif_count_ref <- getUnifiedRef
+ ; wrapTcS $
+ do { defer_ref <- TcM.newTcRef emptyBag
+ ; unified_ref <- TcM.newTcRef []
+ ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)
+ ; let env = UE { u_role = role
+ , u_rewriters = rewriters
+ , u_loc = ctEvLoc ev
+ , u_defer = defer_ref
+ , u_unified = Just unified_ref}
+
+ ; res <- do_unifications env
+
+ ; cts <- TcM.readTcRef defer_ref
+ ; unified <- TcM.readTcRef unified_ref
+
+ -- Don't forget to update the count of variables
+ -- unified, lest we forget to iterate (#24146)
+ ; unless (null unified) $
+ TcM.updTcRef unif_count_ref (+ (length unified))
+
+ ; return (res, cts, unified, rewriters) } }
{-
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1016,7 +1016,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
n' <- wrapL (ipName n)
e' <- cvtl e
- returnLA (IPBind noAnn (reLocA n') e')
+ returnLA (IPBind noAnn (reLoc n') e')
-------------------------------------------------------------------
-- Expressions
@@ -1799,7 +1799,7 @@ cvtTypeKind typeOrKind ty
ImplicitParamT n t
-> do { n' <- wrapL $ ipName n
; t' <- cvtType t
- ; returnLA (HsIParamTy noAnn (reLocA n') t')
+ ; returnLA (HsIParamTy noAnn (reLoc n') t')
}
_ -> failWith (MalformedType typeOrKind ty)
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -118,7 +118,7 @@ inTreeCompilerArgs stg = do
os <- queryHostTarget queryOS
arch <- queryTargetTarget queryArch
- let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64"]
+ let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32"]
let withNativeCodeGen
| unregisterised = False
| arch `elem` codegen_arches = True
=====================================
libraries/base/src/Data/Bifoldable.hs
=====================================
@@ -92,6 +92,15 @@ import GHC.Generics (K1(..))
-- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z
-- @
--
+-- If the type is also an instance of 'Foldable', then
+-- it must satisfy (up to laziness):
+--
+-- @
+-- 'bifoldl' 'const' ≡ 'foldl'
+-- 'bifoldr' ('flip' 'const') ≡ 'foldr'
+-- 'bifoldMap' ('const' 'mempty') ≡ 'foldMap'
+-- @
+--
-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy:
--
-- @
@@ -221,7 +230,17 @@ class Bifoldable p where
bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f)
(Dual . Endo . flip g) t)) z
--- | @since 4.10.0.0
+-- | Class laws for tuples hold only up to laziness. The
+-- Bifoldable methods are lazier than their Foldable counterparts.
+-- For example the law @'bifoldr' ('flip' 'const') ≡ 'foldr'@ does
+-- not hold for tuples if lazyness is exploited:
+--
+-- >>> bifoldr (flip const) (:) [] (undefined :: (Int, Word)) `seq` ()
+-- ()
+-- >>> foldr (:) [] (undefined :: (Int, Word)) `seq` ()
+-- *** Exception: Prelude.undefined
+--
+-- @since 4.10.0.0
instance Bifoldable (,) where
bifoldMap f g ~(a, b) = f a `mappend` g b
=====================================
libraries/base/src/Data/Bifunctor.hs
=====================================
@@ -39,12 +39,26 @@ import GHC.Generics ( K1(..) )
-- Intuitively it is a bifunctor where both the first and second
-- arguments are covariant.
--
+-- The class definition of a 'Bifunctor' @p@ uses the
+-- [QuantifiedConstraints](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/quantified_constraints.html)
+-- language extension to quantify over the first type
+-- argument @a@ in its context. The context requires that @p a@
+-- must be a 'Functor' for all @a at . In other words a partially
+-- applied 'Bifunctor' must be a 'Functor'. This makes 'Functor' a
+-- superclass of 'Bifunctor' such that a function with a
+-- 'Bifunctor' constraint may use 'fmap' in its implementation.
+-- 'Functor' has been a quantified superclass of
+-- 'Bifunctor' since base-4.18.0.0.
+--
-- You can define a 'Bifunctor' by either defining 'bimap' or by
--- defining both 'first' and 'second'. A partially applied 'Bifunctor'
--- must be a 'Functor' and the 'second' method must agree with 'fmap'.
+-- defining both 'first' and 'second'. The 'second' method must
+-- agree with 'fmap':
+--
+-- @'second' ≡ 'fmap'@
+--
-- From this it follows that:
--
--- @'second' 'id' = 'id'@
+-- @'second' 'id' ≡ 'id'@
--
-- If you supply 'bimap', you should ensure that:
--
@@ -69,8 +83,6 @@ import GHC.Generics ( K1(..) )
-- 'second' (f '.' g) ≡ 'second' f '.' 'second' g
-- @
--
--- Since 4.18.0.0 'Functor' is a superclass of 'Bifunctor.
---
-- @since 4.8.0.0
class (forall a. Functor (p a)) => Bifunctor p where
{-# MINIMAL bimap | first, second #-}
=====================================
libraries/base/src/Data/Bitraversable.hs
=====================================
@@ -70,8 +70,8 @@ import GHC.Generics (K1(..))
-- preserving the 'Applicative' operations:
--
-- @
--- t ('pure' x) = 'pure' x
--- t (f '<*>' x) = t f '<*>' t x
+-- t ('pure' x) ≡ 'pure' x
+-- t (f '<*>' x) ≡ t f '<*>' t x
-- @
--
-- and the identity functor 'Identity' and composition functors
@@ -91,11 +91,18 @@ import GHC.Generics (K1(..))
--
-- @
-- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)
--- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)
+-- 'bifoldMap' f g ≡ 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)
-- @
--
-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.
--
+-- If the type is also an instance of 'Traversable', then
+-- it must satisfy (up to laziness):
+--
+-- @
+-- 'traverse' ≡ 'bitraverse' 'pure'
+-- @
+--
-- @since 4.10.0.0
class (Bifunctor t, Bifoldable t) => Bitraversable t where
-- | Evaluates the relevant functions at each element in the structure,
@@ -164,7 +171,17 @@ bimapM = bitraverse
bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bisequence = bitraverse id id
--- | @since 4.10.0.0
+-- | Class laws for tuples hold only up to laziness. The
+-- Bitraversable methods are lazier than their Traversable counterparts.
+-- For example the law @'bitraverse' 'pure' ≡ 'traverse'@ does
+-- not hold for tuples if lazyness is exploited:
+--
+-- >>> (bitraverse pure pure undefined :: IO (Int, Word)) `seq` ()
+-- ()
+-- >>> (traverse pure undefined :: IO (Int, Word)) `seq` ()
+-- *** Exception: Prelude.undefined
+--
+-- @since 4.10.0.0
instance Bitraversable (,) where
bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b)
=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -3,7 +3,10 @@ setTestOpts(
])
test('selfloop', [cmm_src], compile, ['-no-hs-main'])
-test('cmm_sink_sp', [ only_ways(['optasm']), grep_errmsg(r'(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]), cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O'])
+test('cmm_sink_sp', [ only_ways(['optasm']),
+ when(arch('wasm32'), fragile(24152)),
+ grep_errmsg(r'(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]),
+ cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O'])
test('T16930', normal, makefile_test, ['T16930'])
test('T17442', normal, compile, [''])
=====================================
testsuite/tests/parser/should_compile/T23315/T23315.stderr
=====================================
@@ -108,5 +108,3 @@
" More docs"))
[]))
[])))))]))
-
-
=====================================
testsuite/tests/regalloc/all.T
=====================================
@@ -1,6 +1,8 @@
test('regalloc_unit_tests',
[ when(unregisterised(), skip), extra_files(['no_spills.cmm']),
when(not have_ncg(), skip),
+ # no regalloc business on wasm32
+ when(arch('wasm32'), expect_fail),
[ignore_stderr, only_ways(['normal'])], extra_run_opts('"' + config.libdir + '"') ],
compile_and_run,
['-package ghc'])
=====================================
testsuite/tests/rts/IOManager.hsc
=====================================
@@ -0,0 +1,1089 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main (main) where
+
+-- When building within the GHC testsuite, we do not have access to the
+-- async package, so we use a bundled version. The cut down version is
+-- included at the end of this file.
+#define USE_ASYNC_BUNDLED 1
+
+import qualified Data.Map as Map
+import Control.Monad
+import Control.Concurrent
+#ifndef USE_ASYNC_BUNDLED
+import Control.Concurrent.Async
+#endif
+import Control.Concurrent.STM
+import Control.Exception
+import GHC.IO.Exception (ioe_errno)
+import System.Timeout
+
+import Foreign
+import Foreign.C
+import System.Posix.Types (Fd(Fd))
+
+import Prelude hiding (read)
+
+#include <sys/socket.h>
+#include <fcntl.h>
+
+{-
+The purpose of these tests is to try to get some decent test coverage of the
+GHC I/O managers. Most of the time the I/O manager only has to deal with one
+thread blocking on a file descriptor at once, but it's important to also cover
+the more complex cases:
+
+ * Multiple file descriptors
+ * Multiple threads blocking on reading/writing
+ * Multiple threads blocking on reading and writing on the same file descriptor
+ * Killing threads blocking on reading/writing, while there are still other
+ remaining threads.
+
+We start with some simple scenarios and work up towards the complex scenarios.
+
+To do this we use anonymous unix domain sockets, created using socketpair().
+We cannot use ordinary pipes because they are unidirectional, with a write-only
+file descriptor for one end and a read-only file descriptor for the other end:
+which makes it impossible to have threads waiting for reading and writing on
+the same file descriptor.
+
+Unfortunately this makes these tests Unix-only for now, due to the use of
+socketpair(). In principle it's possible on Win32 to create a bidirectional
+non-blocking pipe by using the named pipe API with a unique name (since this is
+what the Win32 CreatePipe() API does internally, but uses blocking mode). Thus
+this test could in principle be extended to work on Windows.
+
+For blocking on reading we need socket buffers to be empty, while for blocking
+on writing we need socket buffers to be full. The empty case is nice and simple
+but the full case is surprisingly asymmetric.
+
+The most complex scenario looks like this: a sequence of sockets, with
+Haskell threads copying bytes between them. Data is injected at one end by a
+special sender thread and collected at the other end of the pipeline by a
+special receiver thread. Each socket has two directions, in one direction we
+arrange for the socket buffers to be usually empty, so threads are typically
+blocked on reading, while in the other direction we arrange for the buffers to
+be usually full so that threads are typically blocked on writing. Between each
+pair of sockets we use one or more Haskell threads that just copy a byte from
+source socket to destination socket. This simple copying behaviour works with
+both full and empty buffers, the difference is just whether the copying threads
+are usually blocked on the reading or writing side. We use different numbers of
+threads to get coverage of the 1 and many cases.
+
+ ╍╍╍╍╍╍╍╍▶ data flow direction ╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍┓
+ ┇
+ ┏━━━━━━━━━━━━━━━━┓ ┏━━━━━━━━━━━━━━━━┓ ┇
+ ┏━━━━━━━━━━━━━━━━┓ ┃ m copy threads ┃ ┃ m copy threads ┃ ┇
+ ┃ send thread ┃ ┃ block on read ┃ ┃ block on read ┃ ▼
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛
+ │ │ │ │ │ ┏━━━━━━━━━┓
+ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━━━━┓ ┃ ┃
+empty buffers ┃ in ┃ out ┃ ┃ in ┃ out ┃ ┃ in ┃ out ╂──▶reflect ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┃ thread ┃
+full buffers ┃ out ┃ in ┃ ┃ out ┃ in ┃ ┃ out ┃ in ◀──╂ ┃
+ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━━━━┛ ┃ ┃
+ │ │ │ │ │ ┗━━━━━━━━━┛
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓
+ ┃ receive thread ┃ ┃ m copy threads ┃ ┃ m copy threads ┃ ┇
+ ┗━━━━━━━━━━━━━━━━┛ ┃ block on write ┃ ┃ block on write ┃ ┇
+ ┗━━━━━━━━━━━━━━━━┛ ┗━━━━━━━━━━━━━━━━┛ ┇
+ ┇
+ ◀╍╍╍╍╍╍╍╍╍ data flow direction ◀╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍╍┛
+
+The simpler scenarios are all subsets of this complex one.
+
+These scenarios make use of two protocols: the "empty buffer" protocol and the
+"full buffer" protocol. See 'EmptyBufPtcl' and 'FullBufPtcl' below for details.
+-}
+
+main :: IO ()
+main = do
+ putStrLn "I/O manager tests"
+ sequence_
+ [ do putStrLn (show n ++ ". " ++ show scenario)
+ runScenario scenario
+ | (n, scenario) <- zip [1 :: Int ..] scenarios ]
+
+data Scenario =
+ Scenario {
+ mode :: Mode,
+ nsockets :: Int,
+ nthreads :: Int,
+ cancelio :: Bool,
+ size :: Int
+ }
+ deriving Show
+
+data Mode = EmptyBufs
+ | FullBufs
+ | EmptyFullBufs
+ deriving Show
+
+scenarios :: [Scenario]
+scenarios =
+ [ Scenario { mode, nsockets, nthreads, cancelio = False, size }
+ | mode <- [EmptyBufs, FullBufs, EmptyFullBufs]
+ , (nsockets, nthreads, size) <-
+ [ (1,0,10)
+ , (1,0,100)
+ , (2,1,100)
+ , (2,3,100)
+ , (3,5,1000)
+ ]
+ ]
+ ++ [ Scenario { mode, nsockets, nthreads, cancelio = True, size }
+ | (mode, nsockets, nthreads, size) <-
+ [ (EmptyBufs, 2,3,100)
+ , (FullBufs, 2,3,100)
+ , (EmptyFullBufs, 2,3,100)
+ , (EmptyFullBufs, 3,5,1000)
+ , (EmptyFullBufs, 7,10,5000)
+ ]
+ ]
+
+runScenario :: Scenario -> IO ()
+runScenario Scenario { mode = EmptyBufs, cancelio = False,
+ nsockets = 1, size } =
+ scenarioEmptyBuffersSimple size
+
+runScenario Scenario { mode = EmptyBufs, cancelio = False,
+ nsockets, nthreads, size } =
+ scenarioEmptyBuffers size nsockets nthreads
+
+runScenario Scenario { mode = FullBufs, cancelio = False,
+ nsockets = 1, size } =
+ scenarioFullBuffersSimple size
+
+runScenario Scenario { mode = FullBufs, cancelio = False,
+ nsockets, nthreads, size } =
+ scenarioFullBuffers size nsockets nthreads
+
+runScenario Scenario { mode = EmptyFullBufs, cancelio = False,
+ nsockets = 1, size } =
+ scenarioEmptyFullBuffersSimple size
+
+runScenario Scenario { mode = EmptyFullBufs, cancelio = False,
+ nsockets, nthreads, size } =
+ scenarioEmptyFullBuffers size nsockets nthreads
+
+runScenario Scenario { mode = EmptyBufs, cancelio = True,
+ nsockets, nthreads, size } =
+ assert (nsockets == 2) $
+ scenarioEmptyBuffersCancel size nthreads
+
+runScenario Scenario { mode = FullBufs, cancelio = True,
+ nsockets, nthreads, size } =
+ assert (nsockets == 2) $
+ scenarioFullBuffersCancel size nthreads
+
+runScenario Scenario { mode = EmptyFullBufs, cancelio = True,
+ nsockets, nthreads, size } =
+ scenarioEmptyFullBuffersCancel size nsockets nthreads
+
+{-
+Scenario: empty socket buffers, 1 socket, 0 copy hops
+ ┏━━━━━━━━━━━━━━━━┓ ┏━━━━━━━━━━━━━━━━┓
+ ┃ send thread ┃ ┃ receive thread ┃
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━━━┛
+ │ │
+ ┏━━▼━━┳━━┿━━┓
+empty buffer ┃ s1a ┃ s1b ┃
+ ┣━━━━━╋━━━━━┫
+unused buffer ┃ ┃ ┃
+ ┗━━━━━┻━━━━━┛
+-}
+scenarioEmptyBuffersSimple :: Int -> IO ()
+scenarioEmptyBuffersSimple sz = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPair $ \s1a s1b -> do
+ traceIO $ "s1a = " ++ show s1a ++ ", s1b = " ++ show s1b
+ sync <- newEmptyBufPtcl
+ runConcurrently $
+ Concurrently (senderEmpty sync s1a input)
+ *> Concurrently (receiverEmpty sync s1b)
+ let expected = input
+ checkExpected id expected actual
+
+
+{-
+Scenario: empty socket buffers, n sockets, n-1 copy hops, m copy threads
+ ┏━━━━━━━━━━━━━━━━┓ ┏━━━━━━━━━━━━━━━━┓
+ ┏━━━━━━━━━━━━━━━━┓ ┃ m copy threads ┃ ┃ m copy threads ┃ ┏━━━━━━━━━━━━━━━━┓
+ ┃ send thread ┃ ┃ block on read ┃ ┃ block on read ┃ ┃ receive thread ┃
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━━━┛
+ │ │ │ │ │ │
+ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓
+empty buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫
+unused buffers ┃ ┃ ┃ ┃ ┃ ┃ ┃ ┃ ┃
+ ┗━━━━━┻━━━━━┛ ┗━━━━━┻━━━━━┛ ┗━━━━━┻━━━━━┛
+ n sockets in total, n-1 hops
+-}
+scenarioEmptyBuffers :: Int -> Int -> Int -> IO ()
+scenarioEmptyBuffers sz n m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPairs n $ \sockets-> do
+ let (s1a, _) = head sockets
+ (_, snb) = last sockets
+ sync <- newEmptyBufPtcl
+ runConcurrently $
+ Concurrently (senderEmpty sync s1a input)
+ *> sequenceA
+ [ Concurrently (copyBetweenFdsN ReadFirst m sib si'a)
+ | ((_sia, sib), (si'a, _si'b)) <- zip sockets (tail sockets) ]
+ *> Concurrently (receiverEmpty sync snb)
+ let expected = input
+ checkExpected id expected actual
+
+
+{-
+Scenario: full socket buffers, 1 socket, 0 copy hops
+ ┏━━━━━┳━━━━━┓
+unused buffers ┃ ┃ ┃
+ ┣━━━━━╋━━━━━┫
+full buffers ┃ s1a ┃ s1b ┃
+ ┗━━┿━━┻━━▲━━┛
+ │ │
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━━━┓
+ ┃ receive thread ┃ ┃ send thread ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioFullBuffersSimple :: Int -> IO ()
+scenarioFullBuffersSimple sz = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPair $ \s1a s1b -> do
+ traceIO $ "s1a = " ++ show s1a ++ ", s1b = " ++ show s1b
+ zeroFillFdBuffer s1b
+ sync <- newFullBufPtcl 1
+ runConcurrently $
+ Concurrently (senderFull sync s1b input)
+ *> Concurrently (receiverFull sync s1a)
+ let expected = input
+ checkExpected (dropWhile (==0)) expected actual
+
+{-
+Scenario: full socket buffers, n sockets, n-1 copy hops x m copy threads
+ ┏━━━━━┳━━━━━┓ ┏━━━━━┳━━━━━┓ ┏━━━━━┳━━━━━┓
+unused buffers ┃ ┃ ┃ ┃ ┃ ┃ ┃ ┃ ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫
+full buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb ┃
+ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛
+ │ │ │ │ │ │
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━━━┓
+ ┃ receive thread ┃ ┃ m copy threads ┃ ┃ m copy threads ┃ ┃ send thread ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┃ block on write ┃ ┃ block on write ┃ ┗━━━━━━━━━━━━━━━━┛
+ ┗━━━━━━━━━━━━━━━━┛ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioFullBuffers :: Int -> Int -> Int -> IO ()
+scenarioFullBuffers sz n m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPairs n $ \sockets-> do
+ let (s1a, _) = head sockets
+ (_, snb) = last sockets
+ sequence_ [ zeroFillFdBuffer sib | (_sia, sib) <- sockets ]
+ sync <- newFullBufPtcl n
+ runConcurrently $
+ Concurrently (senderFull sync snb input)
+ *> sequenceA
+ [ Concurrently (copyBetweenFdsN WriteFirst m si'a sib)
+ | ((_sia, sib), (si'a, _si'b)) <- zip sockets (tail sockets) ]
+ *> Concurrently (receiverFull sync s1a)
+ let expected = input
+ checkExpected (Map.delete 0 . listToBag) expected actual
+
+
+{-
+Scenario: empty and full socket buffers, 1 socket, 0 copy hops
+ ┏━━━━━━━━━━━━━━━━┓
+ ┃ send thread ┃
+ ┗━━━━━━━━━━━━━━┿━┛
+ │ ┏━━━━━━━━━┓
+ ┏━━▼━━┳━━━━━┓ ┃ ┃
+empty buffers ┃ s1a ┃ s1b ╂──▶reflect ┃
+ ┣━━━━━╋━━━━━┫ ┃ thread ┃
+full buffers ┃ s1a ┃ s1b◀──╂ ┃
+ ┗━━┿━━┻━━━━━┛ ┃ ┃
+ │ ┗━━━━━━━━━┛
+ ┏━━━━━━━━━━━━━━▼━┓
+ ┃ receive thread ┃
+ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioEmptyFullBuffersSimple :: Int -> IO ()
+scenarioEmptyFullBuffersSimple sz = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPair $ \s1a s1b -> do
+ traceIO $ "s1a = " ++ show s1a ++ ", s1b = " ++ show s1b
+ zeroFillFdBuffer s1b
+ syncEmpty <- newEmptyBufPtcl
+ syncFull <- newFullBufPtcl 1
+ runConcurrently $
+ Concurrently (senderEmpty syncEmpty s1a input)
+ *> Concurrently (reflectorEmptyToFull syncEmpty syncFull s1b s1b)
+ *> Concurrently (receiverFull syncFull s1a)
+ let expected = input
+ checkExpected (dropWhile (==0)) expected actual
+
+{-
+Scenario: empty & full socket buffers, 3 sockets, 2x2 copy hops x 5 copy threads
+ ┏━━━━━━━━━━━━━━━━┓ ┏━━━━━━━━━━━━━━━━┓
+ ┏━━━━━━━━━━━━━━━━┓ ┃ m copy threads ┃ ┃ m copy threads ┃
+ ┃ send thread ┃ ┃ block on read ┃ ┃ block on read ┃
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛
+ │ │ │ │ │ ┏━━━━━━━━━┓
+ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━━━━┓ ┃ ┃
+empty buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb ╂──▶reflect ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┃ thread ┃
+full buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb◀──╂ ┃
+ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━━━━┛ ┃ ┃
+ │ │ │ │ │ ┗━━━━━━━━━┛
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓
+ ┃ receive thread ┃ ┃ m copy threads ┃ ┃ m copy threads ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┃ block on write ┃ ┃ block on write ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioEmptyFullBuffers :: Int -> Int -> Int -> IO ()
+scenarioEmptyFullBuffers sz n m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ actual <-
+ withLocalSocketPairs n $ \sockets-> do
+ let (s1a, _) = head sockets
+ (_, snb) = last sockets
+ sequence_ [ zeroFillFdBuffer sib | (_sia, sib) <- sockets ]
+ syncEmpty <- newEmptyBufPtcl
+ syncFull <- newFullBufPtcl n
+ runConcurrently $
+ Concurrently (senderEmpty syncEmpty s1a input)
+ *> sequenceA
+ [ Concurrently (copyBetweenFdsN ReadFirst m sib si'a)
+ | ((_sia, sib), (si'a, _si'b)) <- zip sockets (tail sockets) ]
+ *> Concurrently (reflectorEmptyToFull syncEmpty syncFull snb snb)
+ *> sequenceA
+ [ Concurrently (copyBetweenFdsN WriteFirst m si'a sib)
+ | ((_sia, sib), (si'a, _si'b)) <- zip sockets (tail sockets) ]
+ *> Concurrently (receiverFull syncFull s1a)
+ let expected = input
+ checkExpected (Map.delete 0 . listToBag) expected actual
+
+
+{-
+Scenario: empty buffers, 2 sockets, 1 copy hop x m copy threads
+with copy thread cancellation
+ ┏━━━━━━━━━━━━━━━━┓
+ ┃ m copy threads ┃
+ ┏━━━━━━━━━━━━━━━━┓ ┃ cancellation ┃ ┏━━━━━━━━━━━━━━━━┓
+ ┃ send thread ┃ ┃ block on read ┃ ┃ receive thread ┃
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━━━┛
+ │ │ │ │
+ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓
+empty buffers ┃ s1a ┃ s1b ┃ ┃ s2a ┃ s2b ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫
+ ┃ ┃ ┃ ┃ ┃ ┃
+ ┗━━━━━┻━━━━━┛ ┗━━━━━┻━━━━━┛
+-}
+scenarioEmptyBuffersCancel :: Int -> Int -> IO ()
+scenarioEmptyBuffersCancel sz m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ schedule = chaosMonkeySchedule 0
+ actual <-
+ withLocalSocketPair $ \s1a s1b ->
+ withLocalSocketPair $ \s2a s2b -> do
+ sync <- newEmptyBufPtcl
+ runConcurrently $
+ Concurrently (senderEmpty sync s1a input)
+ *> Concurrently (copyBetweenFdsNChaosMonkey ReadFirst m schedule s1b s2a)
+ *> Concurrently (receiverEmpty sync s2b)
+ let expected = input
+ checkExpected (Map.delete 0 . listToBag) expected actual
+
+
+{-
+Scenario: full buffers, 2 sockets, 1 copy hop x m copy threads
+with copy thread cancellation
+ ┏━━━━━┳━━━━━┓ ┏━━━━━┳━━━━━┓
+unused buffers ┃ ┃ ┃ ┃ ┃ ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫
+full buffers ┃ s1a ┃ s1b ┃ ┃ s1a ┃ s1b ┃
+ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛
+ │ │ │ │
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━━━┓
+ ┃ receive thread ┃ ┃ m copy threads ┃ ┃ send thread ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┃ cancellation ┃ ┗━━━━━━━━━━━━━━━━┛
+ ┃ block on write ┃
+ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioFullBuffersCancel :: Int -> Int -> IO ()
+scenarioFullBuffersCancel sz m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ schedule = chaosMonkeySchedule 0
+ actual <-
+ withLocalSocketPair $ \s1a s1b ->
+ withLocalSocketPair $ \s2a s2b -> do
+ mapM_ zeroFillFdBuffer [s1b, s2b]
+ sync <- newFullBufPtcl 1
+ runConcurrently $
+ Concurrently (senderFull sync s2b input)
+ *> Concurrently (copyBetweenFdsNChaosMonkey WriteFirst m schedule s2a s1b)
+ *> Concurrently (receiverFull sync s1a)
+ let expected = input
+ checkExpected (Map.delete 0 . listToBag) expected actual
+
+
+{-
+Scenario: empty & full buffers, n sockets, 2(n-1) copy hops x m copy threads
+with copy thread cancellation
+ ┏━━━━━━━━━━━━━━━━┓ ┏━━━━━━━━━━━━━━━━┓
+ ┃ m copy threads ┃ ┃ m copy threads ┃
+ ┏━━━━━━━━━━━━━━━━┓ ┃ cancellation ┃ ┃ cancellation ┃
+ ┃ send thread ┃ ┃ block on read ┃ ┃ block on read ┃
+ ┗━━━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛ ┗━▲━━━━━━━━━━━━┿━┛
+ │ │ │ │ │ ┏━━━━━━━━━┓
+ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━┿━━┓ ┏━━▼━━┳━━━━━┓ ┃ ┃
+empty buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb ╂──▶reflect ┃
+ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┣━━━━━╋━━━━━┫ ┃ thread ┃
+full buffers ┃ s1a ┃ s1b ┃ ┃ sia ┃ sib ┃ ┃ sna ┃ snb◀──╂ ┃
+ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━▲━━┛ ┗━━┿━━┻━━━━━┛ ┃ ┃
+ │ │ │ │ │ ┗━━━━━━━━━┛
+ ┏━━━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓ ┏━┿━━━━━━━━━━━━▼━┓
+ ┃ receive thread ┃ ┃ m copy threads ┃ ┃ m copy threads ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┃ cancellation ┃ ┃ cancellation ┃
+ ┃ block on write ┃ ┃ block on write ┃
+ ┗━━━━━━━━━━━━━━━━┛ ┗━━━━━━━━━━━━━━━━┛
+-}
+scenarioEmptyFullBuffersCancel :: Int -> Int -> Int -> IO ()
+scenarioEmptyFullBuffersCancel sz n m = do
+ let input = map (fromIntegral :: Int -> Word8) [1..sz]
+ schedules1 = map chaosMonkeySchedule [1..]
+ schedules2 = map chaosMonkeySchedule [2..]
+ actual <-
+ withLocalSocketPairs n $ \sockets-> do
+ let (s1a, _) = head sockets
+ (_, snb) = last sockets
+ sequence_ [ zeroFillFdBuffer sib | (_sia, sib) <- sockets ]
+ syncEmpty <- newEmptyBufPtcl
+ syncFull <- newFullBufPtcl n
+ runConcurrently $
+ Concurrently (senderEmpty syncEmpty s1a input)
+ *> sequenceA
+ [ Concurrently $
+ copyBetweenFdsNChaosMonkey ReadFirst m schedule sib si'a
+ | ((_sia, sib), (si'a, _si'b), schedule)
+ <- zip3 sockets (tail sockets) schedules1
+ ]
+ *> Concurrently (reflectorEmptyToFull syncEmpty syncFull snb snb)
+ *> sequenceA
+ [ Concurrently $
+ copyBetweenFdsNChaosMonkey WriteFirst m schedule si'a sib
+ | ((_sia, sib), (si'a, _si'b), schedule)
+ <- zip3 sockets (tail sockets) schedules2
+ ]
+ *> Concurrently (receiverFull syncFull s1a)
+ let expected = input
+ checkExpected (Map.delete 0 . listToBag) expected actual
+
+
+checkExpected :: (Eq a, Show a) => ([Word8] -> a) -> [Word8] -> [Word8] -> IO ()
+checkExpected normalise expected actual
+ | expected_normalised == actual_normalised = return ()
+ | otherwise = do
+ putStrLn "---------"
+ putStrLn $ "expected output differs:"
+ putStrLn $ "expected: " ++ show expected_normalised
+ putStrLn $ "actual: " ++ show actual_normalised
+ putStrLn "---------"
+ where
+ expected_normalised = normalise expected
+ actual_normalised = normalise actual
+
+listToBag :: Ord a => [a] -> Map.Map a Int
+listToBag = Map.fromListWith (+) . map (\k -> (k,1))
+
+
+-- | The \"empty buffer protocol\" is for sending a series of bytes over a
+-- series of hops -- consisting of sockets and simple copying threads -- in
+-- such a way that the copying threads are usually blocking waiting on
+-- /reading/, i.e. the socket buffers are usually empty.
+--
+-- We do this by synchronising between the sending and receiving ends so that
+-- we only send one byte at a time, and the sender waits for the receiver to
+-- get it.
+--
+-- To do this we use a simple TVar Bool shared between the sender and receiver.
+-- The sender sends a byte and then waits for the tvar to be set to true by
+-- the receiver, at which point it resets the tvar to false and continues.
+--
+-- This is usually used in a loop.
+--
+newtype EmptyBufPtcl = EmptyBufPtcl (TVar Bool)
+
+newEmptyBufPtcl :: IO EmptyBufPtcl
+newEmptyBufPtcl = EmptyBufPtcl <$> newTVarIO False
+
+sendEmptyBufPtcl :: EmptyBufPtcl -> Fd -> Word8 -> IO ()
+sendEmptyBufPtcl (EmptyBufPtcl sync) fd x = do
+ writeByteBlocking fd x
+ atomically $ do
+ continue <- readTVar sync
+ check continue
+ writeTVar sync False
+
+recvEmptyBufPtcl :: EmptyBufPtcl -> Fd -> IO (Maybe Word8)
+recvEmptyBufPtcl (EmptyBufPtcl sync) fd = do
+ res <- readByteBlocking fd
+ atomically $ writeTVar sync True
+ return res
+
+-- | The \"full buffer protocol\" is for sending a series of bytes over a
+-- series of hops -- consisting of sockets and simple copying threads -- in
+-- such a way that the copying threads are usually blocking waiting on
+-- /writing/, i.e. the socket buffers are usually full.
+--
+-- Sending through a full socket buffer is surprisingly tricky in practice
+-- however. Suppose we have a thread blocked on writing into a socket (because
+-- the socket) buffer is full. One might expect that if another thread reads
+-- some data from the socket that this would unblock the writing thread. On
+-- Linux at least, this is not necessarily the case. One may have to remove
+-- much more data before the writer is unblocked.
+--
+-- (It probably behaves this way because the Linux kernel implementation of
+-- local socket tracks packets written, and each packet has some overhead. So
+-- there has to be enough space to fit a whole packet.)
+--
+-- So what we do is this:
+--
+-- Write side:
+-- * try to write a byte
+-- * if it succeeds, repeat
+-- * else it returns EAGAIN
+-- * sync to release reader
+-- * block on readiness for writing
+-- * sync to stop reader
+-- * repeat
+--
+-- Read side:
+-- * sync wait to be released
+-- * read a byte (not expected to block)
+-- * wait for either sync to stop or timeout
+-- * either way, repeat
+--
+-- The point is this: the writer will block on writing but while it is blocked it
+-- will allow the read side to read a byte and then wait a bit. This might be
+-- enough to free up space and allow the writer to complete (in which case the
+-- reader will not read more bytes) but if it's not enough then the reader will
+-- eventually stop waiting and read again. Eventually it must be enough to free -- up space.
+--
+-- This protocol /should/ work across many hops, where the intermediate hops
+-- just do simple blocking read\/write of bytes. So this should just be needed
+-- at the far ends of the hops.
+--
+data FullBufPtcl = FullBufPtcl !(TVar Bool) !Int -- wait milliseconds
+
+newFullBufPtcl :: Int -> IO FullBufPtcl
+newFullBufPtcl nhops = FullBufPtcl <$> newTVarIO False <*> pure waitms
+ where
+ waitms = nhops * 100 --100ms per hop
+
+sendFullBufPtcl :: FullBufPtcl -> Fd -> Word8 -> IO ()
+sendFullBufPtcl ptcl@(FullBufPtcl sync _waitms) fd x = do
+ res <- writeByteNonBlocking fd x
+ case res of
+ Just () ->
+ traceIO ("sendFullBufPtcl: wrote byte '" ++ show x
+ ++ "' on fd " ++ show fd)
+ Nothing -> do
+ atomically $ writeTVar sync True
+ traceIO ("sendFullBufPtcl: waiting to write byte '" ++ show x
+ ++ "' on fd " ++ show fd)
+ threadWaitWrite fd
+ atomically $ writeTVar sync False
+ -- go round again
+ sendFullBufPtcl ptcl fd x
+
+finishSendFullBufPtcl :: FullBufPtcl -> IO ()
+finishSendFullBufPtcl (FullBufPtcl sync _waitms) =
+ atomically $ writeTVar sync True -- release reader to finish
+
+recvFullBufPtcl :: FullBufPtcl -> Fd -> IO (Maybe Word8)
+recvFullBufPtcl (FullBufPtcl sync waitms) fd = do
+ atomically $ readTVar sync >>= check
+ res <- readByteNonBlocking fd
+ case res of
+ Nothing -> fail "recvFullBufPtcl: unexpected blocking"
+ Just Nothing -> return Nothing
+ Just (Just x) -> do
+ traceIO ("recvFullBufPtcl: read byte '" ++ show x
+ ++ "' on fd " ++ show fd ++ ", now waiting")
+ _ <- timeout waitms $ atomically $ readTVar sync >>= check . not
+ return (Just x)
+
+
+senderEmpty :: EmptyBufPtcl -> Fd -> [Word8] -> IO ()
+senderEmpty ptcl fd xs = do
+ mapM_ (sendEmptyBufPtcl ptcl fd) xs
+ shutdown fd SHUT_WR
+
+receiverEmpty :: EmptyBufPtcl -> Fd -> IO [Word8]
+receiverEmpty ptcl fd =
+ untilM (recvEmptyBufPtcl ptcl fd)
+
+
+senderFull :: FullBufPtcl -> Fd -> [Word8] -> IO ()
+senderFull ptcl fd xs = do
+ mapM_ (sendFullBufPtcl ptcl fd) xs
+ finishSendFullBufPtcl ptcl
+ shutdown fd SHUT_WR
+
+receiverFull :: FullBufPtcl -> Fd -> IO [Word8]
+receiverFull ptcl fd =
+ untilM (recvFullBufPtcl ptcl fd)
+
+
+untilM :: Monad m => m (Maybe x) -> m [x]
+untilM action =
+ go []
+ where
+ go xs = do
+ mx <- action
+ case mx of
+ Nothing -> return (reverse xs)
+ Just x -> go (x:xs)
+
+
+reflectorEmptyToFull :: EmptyBufPtcl -> FullBufPtcl -> Fd -> Fd -> IO ()
+reflectorEmptyToFull ptclEmpty ptclFull fdFrom fdTo = do
+ copyloop
+ finishSendFullBufPtcl ptclFull
+ shutdown fdTo SHUT_WR
+ where
+ copyloop = do
+ mx <- recvEmptyBufPtcl ptclEmpty fdFrom
+ case mx of
+ Nothing -> return ()
+ Just x -> do sendFullBufPtcl ptclFull fdTo x
+ copyloop
+
+
+data ReadOrWriteFirst = ReadFirst | WriteFirst
+ deriving (Eq)
+
+-- | Use N threads concurrently to copy bytes. Each thread copies bytes,
+-- one-by-one, from one Fd to another, either starting with a
+-- read or a write (of 0).
+--
+-- Returns the bytes copied, one sublist per thread. Note that the split
+-- between threads will be non-deterministic.
+--
+-- Once all bytes are copied (indicated by EOF on the source), the destination
+-- Fd is shutdown for writing. This allows the other end of the destination Fd
+-- will be receive an EOF. The destination Fd is only shutdown once all
+-- threads are complete.
+--
+copyBetweenFdsN :: ReadOrWriteFirst -> Int -> Fd -> Fd -> IO [[Word8]]
+copyBetweenFdsN rw n fdFrom fdTo = do
+ result <-
+ runConcurrently $
+ sequenceA
+ [ Concurrently (copyBetweenFds rw fdFrom fdTo)
+ | _i <- [0..n-1] ]
+ shutdown fdTo SHUT_WR
+ return result
+
+
+copyBetweenFds :: ReadOrWriteFirst -> Fd -> Fd -> IO [Word8]
+copyBetweenFds rw fdFrom fdTo =
+ case rw of
+ ReadFirst -> goRead []
+ WriteFirst -> goWrite [] 0
+ where
+ goRead acc = do
+ res <- readByteBlocking fdFrom
+ case res of
+ Nothing -> return (reverse acc)
+ Just byte -> goWrite acc byte
+
+ goWrite acc byte = do
+ writeByteBlocking fdTo byte
+ goRead (byte:acc)
+
+-- | It turns out that chaos monkeys are more predictable than you might think.
+--
+-- Each schedule entry (i,j) says: on transferring byte i, interrupt thread j.
+--
+type ChaosMonkeySchedule = [(Int, Int)]
+
+chaosMonkeySchedule :: Int -> ChaosMonkeySchedule
+chaosMonkeySchedule seed =
+ go (Prng seed) 0
+ where
+ go prng i =
+ let (prng', a) = random prng
+ (prng'', j) = random prng'
+ i' = i + 1 + a `mod` 3 -- so 1,2,3
+ in (i', j) : go prng'' i'
+
+
+newtype Prng = Prng Int deriving Show
+
+random :: Prng -> (Prng, Int)
+random (Prng n) =
+ let !n' = n * 1103515245 + 12345
+ !x = (n' `div` 65536) `mod` 32768
+ in (Prng n', x)
+
+-- | Like copyBetweenFdsN but with scheduled interruption of blocking I\/O
+-- operations by asynchronous exceptions to cancel the I\/O.
+--
+-- Each copying thread will catch the async exception and repeat. The sending
+-- of the async exceptions is done based on a pre-defined schedule, based on
+-- the n'th byte read by each thread.
+--
+copyBetweenFdsNChaosMonkey :: ReadOrWriteFirst -> Int
+ -> ChaosMonkeySchedule
+ -> Fd -> Fd -> IO [[Word8]]
+copyBetweenFdsNChaosMonkey rw n schedule fdFrom fdTo =
+ mask_ $ do
+ sync <- newTVarIO False
+ bracket (replicateM n (async (copyBetweenFds' sync)))
+ (mapM_ cancel) $ \copyThreads ->
+ withAsync (chaosMonkey sync copyThreads schedule) $ \monkeyThread -> do
+ _ <- waitAny copyThreads
+ results <- mapM wait copyThreads
+ cancel monkeyThread
+ shutdown fdTo SHUT_WR
+ return results
+ where
+ chaosMonkey :: TVar Bool -> [Async a] -> ChaosMonkeySchedule -> IO ()
+ chaosMonkey sync threads = go 0
+ where
+ go _ [] = return ()
+ go !b sched@((i,_j):_) | b < i = do
+ awaitPulse sync
+ go (b+1) sched
+ go !b ((i,j):sched') | b == i = do
+ let tn = j `mod` n
+ tid = asyncThreadId (threads !! tn)
+ traceIO $ "interrupting thread number " ++ show tn ++ ", " ++ show tid
+ throwTo tid Interrupted
+ go b sched'
+ go !b ((_i,_j):sched') | otherwise =
+ go b sched'
+
+ awaitPulse sync = atomically $ do
+ check =<< readTVar sync
+ writeTVar sync False
+ pulse sync = atomically $ writeTVar sync True
+
+ copyBetweenFds' sync =
+ case rw of
+ ReadFirst -> goRead sync []
+ WriteFirst -> goWrite sync [] 0
+
+ goRead sync acc = do
+ res <- try $ readByteBlocking fdFrom
+ case res of
+ Left Interrupted -> do
+ tid <- myThreadId
+ traceIO $ "read interrupted on " ++ show tid
+ goRead sync acc
+ Right Nothing -> return (reverse acc)
+ Right (Just byte) -> do
+ when (rw == WriteFirst) (pulse sync)
+ goWrite sync acc byte
+
+ goWrite sync acc byte = do
+ res <- try $ writeByteBlocking fdTo byte
+ case res of
+ Left Interrupted -> do
+ tid <- myThreadId
+ traceIO $ "write interrupted on " ++ show tid
+ goWrite sync acc byte
+ Right () -> do
+ when (rw == ReadFirst) (pulse sync)
+ goRead sync (byte:acc)
+
+data Interrupted = Interrupted deriving Show
+instance Exception Interrupted
+
+readByteBlocking :: Fd -> IO (Maybe Word8)
+readByteBlocking fd =
+ allocaBytes 1 $ \bufptr ->
+ readLoop bufptr
+ where
+ readLoop bufptr = do
+ res <- try $ read fd bufptr 1
+ case res of
+ Left err | fmap Errno (ioe_errno err) == Just eWOULDBLOCK
+ -> do threadWaitRead fd
+ readLoop bufptr
+ | otherwise -> throwIO err
+ Right 1 -> Just <$> peek bufptr
+ Right 0 -> return Nothing
+ Right _ -> fail "impossible"
+
+readByteNonBlocking :: Fd -> IO (Maybe (Maybe Word8))
+readByteNonBlocking fd =
+ allocaBytes 1 $ \bufptr -> do
+ res <- try $ read fd bufptr 1
+ case res of
+ Left err | fmap Errno (ioe_errno err) == Just eWOULDBLOCK
+ -> return Nothing
+ | otherwise -> throwIO err
+ Right 1 -> Just . Just <$> peek bufptr
+ Right 0 -> return (Just Nothing)
+ Right _ -> fail "impossible"
+
+writeByteBlocking :: Fd -> Word8 -> IO ()
+writeByteBlocking fd byte =
+ allocaBytes 1 $ \bufptr -> do
+ writeLoop bufptr
+ where
+ writeLoop bufptr = do
+ poke bufptr byte
+ res <- try $ write fd bufptr 1
+ case res of
+ Left err | fmap Errno (ioe_errno err) == Just eWOULDBLOCK
+ -> do threadWaitWrite fd
+ writeLoop bufptr
+ | otherwise -> throwIO err
+ Right 1 -> return ()
+ Right _ -> fail "impossible"
+
+writeByteNonBlocking :: Fd -> Word8 -> IO (Maybe ())
+writeByteNonBlocking fd byte =
+ allocaBytes 1 $ \bufptr -> do
+ poke bufptr byte
+ res <- try $ write fd bufptr 1
+ case res of
+ Left err | fmap Errno (ioe_errno err) == Just eWOULDBLOCK
+ -> return Nothing
+ | otherwise -> throwIO err
+ Right 1 -> return (Just ())
+ Right _ -> fail "impossible"
+
+read :: Fd -> Ptr Word8 -> CSize -> IO CLong
+read fd buf count =
+ throwErrnoIfMinus1 "read" $ do
+ r <- c_read fd buf count
+{-
+ errno <- getErrno
+ let rstr | r == -1 && errno == eWOULDBLOCK = "EWOULDBLOCK"
+ | otherwise = show r
+ traceIO ("read " ++ show (fd, count) ++ " = " ++ rstr)
+-}
+ return r
+
+write :: Fd -> Ptr Word8 -> CSize -> IO CLong
+write fd buf count =
+ throwErrnoIfMinus1 "write" $ do
+ r <- c_write fd buf count
+{-
+ errno <- getErrno
+ let rstr | r == -1 && errno == eWOULDBLOCK = "EWOULDBLOCK"
+ | otherwise = show r
+ traceIO ("write" ++ show (fd, count) ++ " = " ++ rstr)
+-}
+ return r
+
+
+-- Ensure the fd's write buffer is full of zeros.
+--
+-- The Fd must be in non-blocking mode.
+--
+-- Uses 1 byte writes, which on Linux at least, fills up the buffer quickly.
+-- Presumably this is due to the overhead of tracking as packets.
+--
+zeroFillFdBuffer :: Fd -> IO ()
+zeroFillFdBuffer fd =
+ allocaBytes 1 $ \bufptr -> poke bufptr 0 >> go bufptr 0
+ where
+ go :: Ptr Word8 -> Int -> IO ()
+ go !bufptr !count = do
+ res <- c_write fd bufptr 1
+ errno <- getErrno
+ case () of
+ _ | res == 1 ->
+ go bufptr (count + 1)
+
+ | res < 0 && (errno == eAGAIN || errno == eWOULDBLOCK) ->
+ return ()
+
+ _ -> throwErrno "zeroFillFdBuffer"
+
+
+-- We have to use a local socket rather than a pipe, because we need a
+-- bi-directional pipe, and Posix (specially Linux) pipes are unidirectional.
+-- It needs to be bidirectional so that we have multiple threads ending up
+-- blocked reading and writing on the same socket, to test the IO manager
+-- handles this case correctly.
+--
+-- Also set the buffer size to be as small as possible (1 page).
+--
+localSocketPair :: IO (Fd, Fd)
+localSocketPair =
+ allocaArray 2 $ \sv -> do
+ let sockdomain = #{const AF_LOCAL}
+ socktype = #{const SOCK_STREAM}
+ sockproto = 0
+ throwErrnoIfMinus1_ "socketpair" $
+ c_socketpair sockdomain socktype sockproto sv
+ [a,b] <- peekArray 2 sv
+ forM_ [Fd a, Fd b] $ \fd@(Fd fdcint) -> do
+ c_fcntl_write fdcint #{const F_SETFL} #{const O_NONBLOCK}
+ let bufsize = 1024
+ setsockopt fd #{const SOL_SOCKET} #{const SO_SNDBUF} bufsize
+ setsockopt fd #{const SOL_SOCKET} #{const SO_RCVBUF} bufsize
+ return (Fd a, Fd b)
+
+withLocalSocketPair :: (Fd -> Fd -> IO a) -> IO a
+withLocalSocketPair action =
+ bracket
+ localSocketPair
+ (\(a, b) -> close a >> close b)
+ (uncurry action)
+
+withLocalSocketPairs :: Int -> ([(Fd, Fd)] -> IO a) -> IO a
+withLocalSocketPairs n =
+ bracket
+ (replicateM n localSocketPair)
+ (mapM_ (\(a, b) -> close a >> close b))
+
+setsockopt :: Fd -> CInt -> CInt -> CInt -> IO ()
+setsockopt fd level option value =
+ with value $ \p ->
+ throwErrnoIfMinus1_ "setsockopt" $
+ c_setsockopt fd level option p (fromIntegral (sizeOf value))
+
+close :: Fd -> IO ()
+close fd =
+ throwErrnoIfMinus1_ "close" $
+ c_close fd
+
+data ShutdownDir = SHUT_RD | SHUT_WR | SHUT_RDWR
+
+shutdown :: Fd -> ShutdownDir -> IO ()
+shutdown fd dir =
+ throwErrnoIfMinus1_ "shutdown" $
+ c_shutdown fd how
+ where
+ how :: CInt
+ how = case dir of
+ SHUT_RD -> #{const SHUT_RD}
+ SHUT_WR -> #{const SHUT_WR}
+ SHUT_RDWR -> #{const SHUT_RDWR}
+
+-- int socketpair(int domain, int type, int protocol, int sv[2]);
+foreign import ccall "sys/socket.h socketpair"
+ c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt
+
+foreign import ccall "sys/socket.h setsockopt"
+ c_setsockopt :: Fd -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+foreign import capi unsafe "HsBase.h fcntl"
+ c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
+
+foreign import ccall unsafe "unistd.h write"
+ c_write :: Fd -> Ptr Word8 -> CSize -> IO CLong
+
+foreign import ccall unsafe "unistd.h read"
+ c_read :: Fd -> Ptr Word8 -> CSize -> IO CLong
+
+foreign import ccall unsafe "unistd.h close"
+ c_close :: Fd -> IO CInt
+
+foreign import ccall unsafe "sys/socket.h shutdown"
+ c_shutdown :: Fd -> CInt -> IO CInt
+
+traceIO :: String -> IO ()
+traceIO _ = return ()
+--traceIO = BSC.putStrLn . BSC.pack
+
+
+#ifdef USE_ASYNC_BUNDLED
+
+-------------------------------------------------------------------------------
+-- Mini async library
+--
+
+data Async a = Async
+ { asyncThreadId :: !ThreadId
+ , _asyncWait :: STM (Either SomeException a)
+ }
+
+async :: IO a -> IO (Async a)
+async = \action -> do
+ var <- newEmptyTMVarIO
+ t <- forkFinally action (\r -> atomically $ putTMVar var r)
+ return (Async t (readTMVar var))
+
+withAsync :: IO a -> (Async a -> IO b) -> IO b
+withAsync action inner =
+ mask $ \restore -> do
+ a <- async (restore action)
+ restore (inner a) `finally` uninterruptibleCancel a
+
+cancel :: Async a -> IO ()
+cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a
+
+uninterruptibleCancel :: Async a -> IO ()
+uninterruptibleCancel = uninterruptibleMask_ . cancel
+
+data AsyncCancelled = AsyncCancelled
+ deriving Show
+
+instance Exception AsyncCancelled where
+ fromException = asyncExceptionFromException
+ toException = asyncExceptionToException
+
+wait :: Async a -> IO a
+wait = atomically . waitSTM
+
+waitSTM :: Async a -> STM a
+waitSTM a = do
+ r <- waitCatchSTM a
+ either throwSTM return r
+
+waitCatch :: Async a -> IO (Either SomeException a)
+waitCatch = atomically . waitCatchSTM
+
+waitCatchSTM :: Async a -> STM (Either SomeException a)
+waitCatchSTM (Async _ w) = w
+
+waitBoth :: Async a -> Async b -> IO (a,b)
+waitBoth left right = atomically (waitBothSTM left right)
+
+waitBothSTM :: Async a -> Async b -> STM (a,b)
+waitBothSTM left right = do
+ a <- waitSTM left `orElse` (waitSTM right >> retry)
+ b <- waitSTM right
+ return (a,b)
+
+waitAny :: [Async a] -> IO (Async a, a)
+waitAny = atomically . waitAnySTM
+
+waitAnySTM :: [Async a] -> STM (Async a, a)
+waitAnySTM = foldr orElse retry . map (\a -> waitSTM a >>= \r -> return (a, r))
+
+newtype Concurrently a = Concurrently { runConcurrently :: IO a }
+
+instance Functor Concurrently where
+ fmap f (Concurrently a) = Concurrently $ f <$> a
+
+instance Applicative Concurrently where
+ pure = Concurrently . return
+ Concurrently fs <*> Concurrently as =
+ Concurrently $ (\(f, a) -> f a) <$> concurrently fs as
+
+concurrently :: IO a -> IO b -> IO (a,b)
+concurrently left right =
+ withAsync left $ \a ->
+ withAsync right $ \b ->
+ waitBoth a b
+
+#endif
+
=====================================
testsuite/tests/rts/IOManager.stdout
=====================================
@@ -0,0 +1,21 @@
+I/O manager tests
+1. Scenario {mode = EmptyBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 10}
+2. Scenario {mode = EmptyBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 100}
+3. Scenario {mode = EmptyBufs, nsockets = 2, nthreads = 1, cancelio = False, size = 100}
+4. Scenario {mode = EmptyBufs, nsockets = 2, nthreads = 3, cancelio = False, size = 100}
+5. Scenario {mode = EmptyBufs, nsockets = 3, nthreads = 5, cancelio = False, size = 1000}
+6. Scenario {mode = FullBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 10}
+7. Scenario {mode = FullBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 100}
+8. Scenario {mode = FullBufs, nsockets = 2, nthreads = 1, cancelio = False, size = 100}
+9. Scenario {mode = FullBufs, nsockets = 2, nthreads = 3, cancelio = False, size = 100}
+10. Scenario {mode = FullBufs, nsockets = 3, nthreads = 5, cancelio = False, size = 1000}
+11. Scenario {mode = EmptyFullBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 10}
+12. Scenario {mode = EmptyFullBufs, nsockets = 1, nthreads = 0, cancelio = False, size = 100}
+13. Scenario {mode = EmptyFullBufs, nsockets = 2, nthreads = 1, cancelio = False, size = 100}
+14. Scenario {mode = EmptyFullBufs, nsockets = 2, nthreads = 3, cancelio = False, size = 100}
+15. Scenario {mode = EmptyFullBufs, nsockets = 3, nthreads = 5, cancelio = False, size = 1000}
+16. Scenario {mode = EmptyBufs, nsockets = 2, nthreads = 3, cancelio = True, size = 100}
+17. Scenario {mode = FullBufs, nsockets = 2, nthreads = 3, cancelio = True, size = 100}
+18. Scenario {mode = EmptyFullBufs, nsockets = 2, nthreads = 3, cancelio = True, size = 100}
+19. Scenario {mode = EmptyFullBufs, nsockets = 3, nthreads = 5, cancelio = True, size = 1000}
+20. Scenario {mode = EmptyFullBufs, nsockets = 7, nthreads = 10, cancelio = True, size = 5000}
=====================================
testsuite/tests/rts/Makefile
=====================================
@@ -157,3 +157,8 @@ T23142:
grep -m1 -c "CATCH_STM_FRAME" T23142.log
grep -m1 -c "MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
grep -m1 -c "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
+
+HSC2HS_OPTS = --cc="$(TEST_CC)" $(addprefix --cflag=,$(TEST_CC_OPTS)) --ld=$(TEST_CC) $(addprefix --lflag=,$(TEST_CC_OPTS))
+
+IOManager.hs: IOManager.hsc
+ '$(HSC2HS)' $(HSC2HS_OPTS) $<
=====================================
testsuite/tests/rts/T5644/all.T
=====================================
@@ -1,8 +1,9 @@
test('T5644', [extra_files(['Conf.hs', 'ManyQueue.hs', 'Util.hs', 'heap-overflow.hs']),
-
+
only_ways(['optasm','threaded1','threaded2']),
extra_run_opts('+RTS -M20m -RTS'),
- exit_code(251) # RTS exit code for "out of memory"
+ exit_code(251), # RTS exit code for "out of memory"
+ when(arch('wasm32'), [ignore_stderr, exit_code(1)])
],
multimod_compile_and_run,
['heap-overflow.hs','-O'])
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -44,6 +44,8 @@ test('derefnull',
when(opsys('mingw32'), [ignore_stderr, exit_code(11)]),
when(opsys('mingw32'), [fragile(18548)]),
when(arch('javascript'), [ignore_stderr, exit_code(1)]),
+ # On wasm32, 0x0 is a valid linear memory address
+ when(arch('wasm32'), [ignore_stdout, ignore_stderr, exit_code(0)]),
# ThreadSanitizer changes the output
when(have_thread_sanitizer(), skip),
# since these test are supposed to crash the
@@ -82,6 +84,8 @@ test('divbyzero',
when(platform('x86_64-apple-darwin'), [ignore_stderr, exit_code(136)]),
# ThreadSanitizer changes the output
when(have_thread_sanitizer(), skip),
+ # wasmtime returns sigabrt error code upon wasm traps
+ when(arch('wasm32'), [ignore_stdout, ignore_stderr, exit_code(134)]),
# since these test are supposed to crash the
# profile report will be empty always.
# so disable the check for profiling
@@ -604,3 +608,7 @@ test('T23221',
test('T23142', [unless(debug_rts(), skip), req_interp], makefile_test, ['T23142'])
test('T23400', [], compile_and_run, ['-with-rtsopts -A8k'])
+
+test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), skip),
+ pre_cmd('$MAKE -s --no-print-directory IOManager.hs')],
+ compile_and_run, [''])
=====================================
testsuite/tests/simplCore/prog003/simplCore.oneShot.stderr → testsuite/tests/simplCore/prog003/simplCore-oneShot.stderr
=====================================
=====================================
testsuite/tests/simplCore/prog003/simplCore.oneShot.stdout → testsuite/tests/simplCore/prog003/simplCore-oneShot.stdout
=====================================
=====================================
testsuite/tests/simplCore/prog003/test.T
=====================================
@@ -1,3 +1,3 @@
-test('simplCore.oneShot', [extra_files(['OneShot1.hs', 'OneShot2.hs']),
+test('simplCore-oneShot', [extra_files(['OneShot1.hs', 'OneShot2.hs']),
only_ways(['optasm'])], multimod_compile_and_run,
['OneShot2', '-v0'])
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -19,7 +19,8 @@ test('simplrun007', normal, compile_and_run, [''])
test('simplrun008', normal, compile_and_run, [''])
test('simplrun009', normal, compile_and_run, [''])
test('simplrun010', [extra_run_opts('24 16 8 +RTS -M10m -RTS'),
- exit_code(251)]
+ exit_code(251),
+ when(arch('wasm32'), [ignore_stderr, exit_code(1)])]
, compile_and_run, [''])
test('simplrun011', normal, compile_and_run, ['-fno-worker-wrapper'])
=====================================
testsuite/tests/typecheck/should_compile/T24146.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+module M where
+
+class (a ~ b) => Aggregate a b where
+instance Aggregate a a where
+
+liftM :: (Aggregate ae am) => (forall r. am -> r) -> ae
+liftM _ = undefined
+
+class Positive a
+
+mytake :: (Positive n) => n -> r
+mytake = undefined
+
+x :: (Positive n) => n
+x = liftM mytake
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -902,3 +902,4 @@ test('InstanceWarnings', normal, multimod_compile, ['InstanceWarnings', ''])
test('T23861', normal, compile, [''])
test('T23918', normal, compile, [''])
test('T17564', normal, compile, [''])
+test('T24146', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a735c06bb37a213a5a2dca0cfa909a77b673895...9b5469648293779febc9a05c8d6bb306a2b7d7ba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a735c06bb37a213a5a2dca0cfa909a77b673895...9b5469648293779febc9a05c8d6bb306a2b7d7ba
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231105/43c82c27/attachment-0001.html>
More information about the ghc-commits
mailing list