- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Fix several oversights in hsExprType
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4ee260cf by sheaf at 2026-03-27T04:46:06-04:00 Fix several oversights in hsExprType This commit fixes several oversights in GHC.Hs.Syn.Type.hsExprType: - The 'RecordCon' case was returning the type of the constructor, instead of the constructor application. This is fixed by using 'splitFunTys'. - The 'ExplicitTuple' case failed to take into account tuple sections, and was also incorrectly handling 1-tuples (e.g. 'Solo') which can be constructed using Template Haskell. - The 'NegApp' case was returning the type of the negation operator, again failing to apply it to the argument. Fixed by using 'funResultTy'. - The 'HsProc' case was computing the result type of the arrow proc block, without taking into account the argument type. Fix that by adding a new field to 'CmdTopTc' that stores the arrow type, so that we can construct the correct result type `arr a b` for `proc (pat :: a) -> (cmd :: b)`. - The 'ArithSeq' and 'NegApp' cases were failing to take into account the result 'HsWrapper', which could e.g. silently drop casts. This is fixed by introducing 'syntaxExpr_wrappedFunResTy' which, on top of taking the result type, applies the result 'HsWrapper'. These fixes are validated by the new GHC API test T26910. Fixes #26910 - - - - - 9 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Zonk/Type.hs - + testsuite/tests/ghc-api/T26910.hs - + testsuite/tests/ghc-api/T26910.stdout - + testsuite/tests/ghc-api/T26910_Input.hs - testsuite/tests/ghc-api/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1608,9 +1608,16 @@ is Less Cool because -} data CmdTopTc - = CmdTopTc Type -- Nested tuple of inputs on the command's stack - Type -- return type of the command - (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + = CmdTopTc + -- | Nested tuple of inputs on the command's stack + { ctt_stack :: Type + -- | Arrow type + , ctt_arr_ty :: Type + -- | Return type of the command + , ctt_res_ty :: Type + -- | Command syntax table; see Note [CmdSyntaxTable] + , ctt_table :: CmdSyntaxTable GhcTc + } type instance XCmdTop GhcPs = NoExtField type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence import GHC.Types.Id import GHC.Types.Var( VarBndr(..) ) import GHC.Types.SrcLoc +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -114,11 +115,16 @@ hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_gr hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v -hsExprType (NegApp _ _ se) = syntaxExprType se +hsExprType (NegApp _ _ se) = syntaxExpr_wrappedFunResTy se hsExprType (HsPar _ e) = lhsExprType e hsExprType (SectionL v _ _) = dataConCantHappen v hsExprType (SectionR v _ _) = dataConCantHappen v -hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args +hsExprType (ExplicitTuple _ args box) = + -- Deal with tuple sections: one function arrow per missing argument + mkScaledFunTys [s | Missing s <- args] $ + -- Use 'mkTupleTy1' to avoid flattening 1-tuples, as per + -- Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. + mkTupleTy1 box (map hsTupArgType args) hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t @@ -126,25 +132,29 @@ hsExprType (HsMultiIf ty _) = ty hsExprType (HsLet _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty -hsExprType (RecordCon con_expr _ _) = hsExprType con_expr +hsExprType (RecordCon con_expr _ _) = snd (splitFunTys (hsExprType con_expr)) hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e -hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of - Just op -> piResultTy (syntaxExprType op) asi_ty - Nothing -> asi_ty - where - asi_ty = arithSeqInfoType asi +hsExprType (ArithSeq _ mb_overloaded_op asi) = + case mb_overloaded_op of + Just se -> syntaxExpr_wrappedFunResTy se + Nothing -> arithSeqInfoType asi hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty -hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice" - (ppr e) - -- Typed splices should have been eliminated during zonking, but we - -- can't use `dataConCantHappen` since they are still present before - -- than in the typechecked AST. +hsExprType e@(HsTypedSplice{}) = + -- Typed splices should have been eliminated during zonking, but we + -- can't use `dataConCantHappen` since they are still present before + -- then in the typechecked AST. + pprPanic "hsExprType: Unexpected HsTypedSplice" + (ppr e) hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext -hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top +hsExprType (HsProc _ pat (L _ (HsCmdTop cmd_top_tc _))) = + let CmdTopTc { ctt_arr_ty = arr_ty, ctt_res_ty = res_ty } = cmd_top_tc + in + -- (proc (pat :: a) -> (cmd :: b)) :: arr a b + mkAppTys arr_ty [hsLPatType pat, res_ty] hsExprType (HsStatic (ty,_) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (HsEmbTy x _) = dataConCantHappen x @@ -178,6 +188,13 @@ hsTupArgType :: HsTupArg GhcTc -> Type hsTupArgType (Present _ e) = lhsExprType e hsTupArgType (Missing (Scaled _ ty)) = ty +-- | The result type of a @SyntaxExpr GhcTc@ for a unary function, +-- including the result 'HsWrapper'. +syntaxExpr_wrappedFunResTy :: HasDebugCallStack => SyntaxExpr GhcTc -> Type +syntaxExpr_wrappedFunResTy (SyntaxExprTc { syn_expr = e, syn_res_wrap = wrap }) = + hsWrapperType wrap (funResultTy (hsExprType e)) +syntaxExpr_wrappedFunResTy NoSyntaxExprTc = + panic "syntaxExpr_wrappedFunResTy: unexpected NoSyntaxExprTc" -- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas)) type PRType = (Type, [Type]) @@ -191,7 +208,7 @@ liftPRType :: (Type -> Type) -> PRType -> PRType liftPRType f pty = (f (prTypeType pty), []) hsWrapperType :: HsWrapper -> Type -> Type --- Return the type of (WrapExpr wrap e), given that e :: ty +-- ^ Return the type of @WrapExpr wrap e@, given that @e :: ty@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) where go WpHole = id @@ -209,12 +226,5 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) go (WpLet _) = id -lhsCmdTopType :: LHsCmdTop GhcTc -> Type -lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty - matchGroupTcType :: MatchGroupTc -> Type matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res - -syntaxExprType :: SyntaxExpr GhcTc -> Type -syntaxExprType (SyntaxExprTc e _ _) = hsExprType e -syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc" ===================================== compiler/GHC/HsToCore/Arrows.hs ===================================== @@ -284,7 +284,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc { ctt_res_ty = cmd_ty, ctt_table = ids }) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) (core_cmd, _free_vars, env_ids) @@ -656,8 +656,15 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids - (L _ (HsCmdTop - (CmdTopTc stack_ty cmd_ty ids) cmd )) = do + (L _ + (HsCmdTop + (CmdTopTc + { ctt_stack = stack_ty + , ctt_res_ty = cmd_ty + , ctt_table = ids + }) + cmd) + ) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd ===================================== compiler/GHC/Tc/Gen/Arrow.hs ===================================== @@ -136,7 +136,11 @@ tcCmdTop :: CmdEnv tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) = setSrcSpanA loc $ do { cmd' <- tcCmd env cmd cmd_ty - ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') } + ; let cmd_top = CmdTopTc { ctt_stack = cmd_stk + , ctt_arr_ty = cmd_arr env + , ctt_res_ty = res_ty + , ctt_table = names } + ; return (L loc $ HsCmdTop cmd_top cmd') } ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1211,10 +1211,14 @@ zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc) zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc) -zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) +zonk_cmd_top (HsCmdTop (CmdTopTc { ctt_stack = stack_tys + , ctt_arr_ty = arr_ty + , ctt_res_ty = res_ty + , ctt_table = ids }) cmd) = do new_cmd <- zonkLCmd cmd new_stack_tys <- zonkTcTypeToTypeX stack_tys - new_ty <- zonkTcTypeToTypeX ty + new_arr_ty <- zonkTcTypeToTypeX arr_ty + new_res_ty <- zonkTcTypeToTypeX res_ty new_ids <- mapSndM zonkExpr ids massert (definitelyLiftedType new_stack_tys) @@ -1222,7 +1226,13 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) -- but indeed it should always be lifted due to the typing -- rules for arrows - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + let new_cmd_top = + CmdTopTc { ctt_stack = new_stack_tys + , ctt_arr_ty = new_arr_ty + , ctt_res_ty = new_res_ty + , ctt_table = new_ids } + + return (HsCmdTop new_cmd_top new_cmd) ------------------------------------------------------------------------- zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper ===================================== testsuite/tests/ghc-api/T26910.hs ===================================== @@ -0,0 +1,113 @@ +module Main where + +-- base +import Control.Applicative +import Control.Monad.IO.Class + ( liftIO ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import System.Environment + ( getArgs ) + +-- directory +import System.Directory + ( removeFile ) + +-- ghc +import GHC +import GHC.Data.Bag + ( bagToList ) +import GHC.Driver.Ppr + ( showSDoc ) +import GHC.Driver.Session +import GHC.Hs +import GHC.Hs.Syn.Type + ( hsExprType ) +import GHC.Types.Name + ( nameOccName, occNameString ) +import GHC.Types.Var + ( varName ) +import GHC.Unit.Types + ( GenUnit (..), Definite (..) ) +import GHC.Utils.Outputable + ( ppr ) + +-------------------------------------------------------------------------------- + +findBindBody :: String -> LHsBinds GhcTc -> Maybe (HsExpr GhcTc) +findBindBody name = asum . map go + where + go (L _ FunBind { fun_id = L _ fid + , fun_matches = MG { mg_alts = L _ (m:_) } }) + | occNameString (nameOccName (varName fid)) == name + = case m_grhss (unLoc m) of + GRHSs { grhssGRHSs = L _ (GRHS _ _ bodyL) :| _ } -> Just (unLoc bodyL) + go (L _ (XHsBindsLR AbsBinds { abs_binds })) = findBindBody name abs_binds + go _ = Nothing + +checkBinding :: DynFlags -> String -> LHsBinds GhcTc -> IO () +checkBinding dflags name tcSrc = + case findBindBody name tcSrc of + Nothing -> + putStrLn $ name ++ " NOT FOUND" + Just body -> + putStrLn $ + "(<body of " ++ name ++ ">) :: " ++ showSDoc dflags (ppr (hsExprType body)) + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + logger <- getLogger + + -- Add 'template-haskell' dependency + (dflags, _, _) <- parseDynamicFlags logger dflags [noLoc "-package template-haskell"] + setSessionDynFlags dflags + + let modName = mkModuleName "T26910_Input" + m = mkModule (RealUnit (Definite (homeUnitId_ dflags))) modName + addTarget Target + { targetId = TargetModule modName + , targetAllowObjCode = True + , targetUnitId = homeUnitId_ dflags + , targetContents = Nothing + } + _ <- load LoadAllTargets + modSum <- getModSummary m + parsed <- parseModule modSum + tc <- typecheckModule parsed + + let tcSrc = tm_typechecked_source tc + check name = liftIO $ checkBinding dflags name tcSrc + + check "e_reccon" -- RecordCon + check "e_negapp" -- NegApp + check "e_proc" -- HsProc + check "e_arith_ol" -- ArithSeq + + check "e_var" -- ConLikeTc + check "e_lit" -- HsLit + check "e_overlit" -- HsOverLit + check "e_lam" -- HsLam + check "e_app" -- HsApp + check "e_apptype" -- HsAppType + check "e_par" -- HsPar + check "e_tuple1" -- ExplicitTuple + check "e_tuple2" -- ExplicitTuple + TupleSections + check "e_tuple3" -- ExplicitTuple 1-tuple (with Template Haskell) + check "e_utuple1" -- ExplicitTuple (unboxed) + check "e_utuple2" -- ExplicitTuple + TupleSections (unboxed) + check "e_usum" -- Unboxed sums + check "e_case" -- HsCase + check "e_if" -- HsIf + check "e_multiif" -- HsMultiIf + check "e_let" -- HsLet + check "e_list" -- ExplicitList + OverloadedLists + check "e_arith" -- ArithSeq + check "e_tysig" -- ExprWithTySig + check "e_listcomp" -- HsDo (ListComp) + check "e_recsel" -- HsRecSelTc + check "e_ubracket" -- HsUntypedBracket + check "e_tbracket" -- HsTypedBracket + check "e_static" -- HsStatic ===================================== testsuite/tests/ghc-api/T26910.stdout ===================================== @@ -0,0 +1,29 @@ +(<body of e_reccon>) :: MyRec +(<body of e_negapp>) :: T Word +(<body of e_proc>) :: Int -> Int +(<body of e_arith_ol>) :: MyList Int +(<body of e_var>) :: Either Int Bool +(<body of e_lit>) :: Char +(<body of e_overlit>) :: T Word +(<body of e_lam>) :: Bool -> Bool +(<body of e_app>) :: Bool +(<body of e_apptype>) :: Bool -> Bool +(<body of e_par>) :: Bool +(<body of e_tuple1>) :: (Int, Bool) +(<body of e_tuple2>) :: Int -> (Int, Bool) +(<body of e_tuple3>) :: Solo Char +(<body of e_utuple1>) :: (# Int, Int# #) +(<body of e_utuple2>) :: Int -> Int# -> (# Int, Int# #) +(<body of e_usum>) :: (# Int# | Word# #) +(<body of e_case>) :: Bool +(<body of e_if>) :: Char +(<body of e_multiif>) :: Int +(<body of e_let>) :: Int +(<body of e_list>) :: [Int] +(<body of e_arith>) :: MyList Int +(<body of e_tysig>) :: Bool +(<body of e_listcomp>) :: [Int] +(<body of e_recsel>) :: MyRec -> Int +(<body of e_ubracket>) :: Q Exp +(<body of e_tbracket>) :: Code Q Char +(<body of e_static>) :: StaticPtr Bool ===================================== testsuite/tests/ghc-api/T26910_Input.hs ===================================== @@ -0,0 +1,187 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +module T26910_Input where + +-- base +import Prelude + hiding ( negate, fromInteger ) +import qualified Prelude +import Control.Arrow + ( (>>>), arr, first, returnA ) +import Data.Kind + ( Type ) +import Data.Tuple + ( Solo(..) ) +import GHC.Exts + ( TYPE, RuntimeRep(..), LiftedRep + , IsList (..) + , Int#, Word# + ) +import GHC.StaticPtr + ( StaticPtr ) + +-- template-haskell +import qualified Language.Haskell.TH as TH + +-------------------------------------------------------------------------------- + +ifThenElse :: Bool -> a -> a -> a +ifThenElse c t f = + case c of + True -> t + False -> f + +data MyRec = MyRec { recInt :: Int, recBool :: Bool } + +-- Used to test ArithSeq with overloaded fromList (OverloadedLists) +newtype MyList a = MyList [a] +instance IsList (MyList a) where + type Item (MyList a) = a + fromList = MyList + toList (MyList xs) = xs + +-- RecordCon +e_reccon :: MyRec +e_reccon = MyRec { recInt = 1, recBool = True } + +-- NegApp +e_negapp :: T Word +e_negapp = -(1 :: Int) + +type R :: Type -> RuntimeRep +type family R a where + R Word = LiftedRep + +type T :: forall (a :: Type) -> TYPE (R a) +type family T a where + T Word = Int + +-- Weird RebindableSyntax negation that involves casts +negate :: T Word -> T Word +negate = Prelude.negate + +-- HsProc +e_proc :: Int -> Int +e_proc = proc x -> returnA -< x + +-- ArithSeq (with OverloadedLists) +e_arith_ol :: MyList Int +e_arith_ol = [1..10 :: Int] + +-- XExpr (ConLikeTc) +e_var :: Either Int Bool +e_var = Left 3 + +-- HsLit +e_lit :: Char +e_lit = 'x' + +-- HsOverLit +e_overlit :: T Word +e_overlit = 42 + +fromInteger :: Integer -> T Word +fromInteger = Prelude.fromInteger + +-- HsLam +e_lam :: Bool -> Bool +e_lam = \ x -> not x + +-- HsApp +e_app :: Bool +e_app = not True + +-- HsAppType +e_apptype :: Bool -> Bool +e_apptype = id @Bool + +-- HsPar +e_par :: Bool +e_par = (True) + +-- ExplicitTuple +e_tuple1 :: (Int, Bool) +e_tuple1 = (1 :: Int, True) + +-- ExplicitTuple + TupleSections +e_tuple2 :: Int -> (Int, Bool) +e_tuple2 = (, True) + +-- ExplicitTuple one-tuple +e_tuple3 :: Solo Char +e_tuple3 = + $( return $ TH.TupE [ Just $ TH.LitE ( TH.CharL 'x' ) ] ) + +-- Unboxed tuple +e_utuple1 :: () -> (# Int, Int# #) +e_utuple1 _ = (# 1, 1# #) + +-- Unboxed tuple + TupleSections +e_utuple2 :: Int -> Int# -> (# Int, Int# #) +e_utuple2 = (# , #) + +-- Unboxed sums +e_usum :: () -> (# Int# | Word# #) +e_usum _ = (# 1# | #) + +-- HsCase +e_case :: Bool +e_case = case id True of { True -> False; False -> True } + +-- HsIf +e_if :: Char +e_if = if id True then 'x' else 'y' + +-- HsMultiIf +e_multiif :: Int +e_multiif = if | id True -> (1 :: Int) + | otherwise -> (2 :: Int) + +-- HsLet +e_let :: Int +e_let = let x = 1 :: Int in x + +-- ExplicitList +e_list :: [Int] +e_list = [1 :: Int, 2, 3] + +-- ArithSeq with overloaded fromList +e_arith :: MyList Int +e_arith = [1 :: Int ..] + +-- ExprWithTySig +e_tysig :: Bool +e_tysig = (True :: Bool) + +-- HsDo ListComp +e_listcomp :: [Int] +e_listcomp = [x | x <- [1 :: Int, 2, 3]] + +-- HsRecSelTc +e_recsel :: MyRec -> Int +e_recsel = recInt + +-- HsUntypedBracket +e_ubracket :: TH.Q TH.Exp +e_ubracket = [| 'y' |] + +-- HsTypedBracket +e_tbracket :: TH.Code TH.Q Char +e_tbracket = [|| 'z' ||] + +-- HsStatic +e_static :: StaticPtr Bool +e_static = static True ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -74,4 +74,8 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"') test('T26120', [], compile_and_run, ['-package ghc']) test('T26264', normal, compile_and_run, ['-package ghc']) +test('T26910', [ extra_run_opts(f'"{config.libdir}"') + # doesn't work in wasm/js due to lack of pipe(2) support + , when(arch('wasm32') or arch('javascript'), skip) + ], compile_and_run, ['-package ghc -package template-haskell']) test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a0267… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a0267… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Don't refine DEFAULT alt for unary typeclasses
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 05094993 by Luite Stegeman at 2026-03-27T04:45:12-04:00 Don't refine DEFAULT alt for unary typeclasses A non-DEFAULT data alt for a unary typeclass dictionary would interfere with Unary Class Magic, leading to segfaults. fixes #27071 - - - - - 7 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - + testsuite/tests/simplCore/should_run/T27071.hs - + testsuite/tests/simplCore/should_run/T27071.stdout - testsuite/tests/simplCore/should_run/all.T Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -286,7 +286,9 @@ data Alt b -- See Note [GHC Formalism] in GHC.Core.Lint data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. - -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + -- Invariant: the 'DataCon' is always from a @data@ type, + -- and never from a @newtype@ or a unary class. + -- See Note [DataAlt restrictions] | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ -- Invariant: always an *unlifted* literal @@ -330,6 +332,63 @@ mkBinds Recursive binds = [Rec binds] mkBinds NonRecursive binds = map (uncurry NonRec) binds {- +Note [DataAlt restrictions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The DataCon in a DataAlt is subject to three restrictions: + +(DALT1) It is never from a newtype. + + Newtypes are always represented via coercions, never by pattern matching + on their data constructor. We can still have a case expression over a + newtype scrutinee if we are just doing an eval: + + case x of { DEFAULT -> e } + + but we must not match on the newtype constructor. + +(DALT2) It is never from a `type data` declaration. + + The constructors of a `type data` declaration (see + Note [Type data declarations] in GHC.Rename.Module) exist only at the + type level and have no value-level representation. Nevertheless, it is + possible to strictly evaluate a value whose type is a `type data` + declaration. For example (from test type-data/should_compile/T2294b.hs): + + type data T a where + A :: T Int + + f :: T a -> () + f !x = () + + We want to generate the following Core for f: + + f = \(@a) (x :: T a) -> + case x of { __DEFAULT -> () } + + Namely we do _not_ want to match on `A`, as it doesn't exist at the value + level! See wrinkle (W2b) in Note [Type data declarations] in + GHC.Rename.Module. + +(DALT3) It is never from a unary class (#27071). + + Unary class constructors are erased at runtime: the dictionary IS the + single method (or superclass), with no wrapper. Matching on the dictionary + constructor is therefore illegal in Core; case expressions over unary + class dictionaries must use DEFAULT. For example, given + + class C a where { op :: a -> a } + + a case on a C dictionary looks like: + + case d of bndr { DEFAULT -> ...bndr... } + not: + case d of { C:C op -> ...op... } -- WRONG + + See (UCM13) in Note [Unary class magic] in GHC.Core.TyCon. + +All three restrictions are checked by Core Lint, and they each give rise +to a special case in `GHC.Core.Utils.refineDefaultAlt`. + Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals. ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1720,11 +1720,13 @@ lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) lit_ty = literalType lit lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) - | isNewTyCon (dataConTyCon con) + | isNewTyCon (dataConTyCon con) -- (DALT1) in Note [DataAlt restrictions] in GHC.Core = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | isUnaryClassTyCon (dataConTyCon con) -- (DALT3) in Note [DataAlt restrictions] in GHC.Core + = zeroUE <$ addErrL (mkUnaryClassDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty = addLoc (CaseAlt alt) $ do - { checkTypeDataConOcc "pattern" con + { checkTypeDataConOcc "pattern" con -- (DALT2) in Note [DataAlt restrictions] in GHC.Core ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) -- Instantiate the universally quantified @@ -3806,6 +3808,11 @@ mkNewTyDataConAltMsg scrut_ty alt text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] +mkUnaryClassDataConAltMsg :: Type -> CoreAlt -> SDoc +mkUnaryClassDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for unary class datacon" + , text "Scrutinee type:" <+> ppr scrut_ty + , text "Alternative:" <+> pprCoreAlt alt ] ------------------------------------------------------ -- Other error messages ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -1584,6 +1584,20 @@ There are a number of wrinkles a black hole when rehydrating interface the interface file. Easiest just to store the bit! See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody. +(UCM13) In Core, a case expression must never pattern-match on a unary class + data constructor (#27071). Since the constructor is erased at runtime, the + only valid form is: + + case d of bndr { DEFAULT -> ...bndr... } + + See (DALT3) Note [DataAlt restrictions] in GHC.Core. + + Generally, class dictionaries are only taken apart by the method + selectors, which are never inlined; see Note [ClassOp/DFun selection] + in GHC.Tc.TyCl.Instance. However the demand analyser can add `seq` forcing + on strict arguments (see Note [Which Ids should be strictified] in + GHC.Core.Utils), so we must be careful not to "fill in" the DEFAULT to mention + the data constructor; see GHC.Core.Utils.refineDefaultAlt. Note [Representing unary classes with newtypes: bad, bad, bad] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -858,8 +858,9 @@ refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts | Alt DEFAULT _ rhs : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives] - , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives] + , not (isNewTyCon tycon) -- (DALT1) in Note [DataAlt restrictions] in GHC.Core + , not (isTypeDataTyCon tycon) -- (DALT2) in Note [DataAlt restrictions] in GHC.Core + , not (isUnaryClassTyCon tycon) -- (DALT3) in Note [DataAlt restrictions] in GHC.Core , Just all_cons <- tyConDataCons_maybe tycon , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type, so we can use @@ -1200,38 +1201,9 @@ with a specific constructor is desirable. `imposs_deflt_cons` argument is populated with constructors which are matched elsewhere. -There are two exceptions where we avoid refining a DEFAULT case: - -* Exception 1: Newtypes - - We can have a newtype, if we are just doing an eval: - - case x of { DEFAULT -> e } - - And we don't want to fill in a default for them! - -* Exception 2: `type data` declarations - - The data constructors for a `type data` declaration (see - Note [Type data declarations] in GHC.Rename.Module) do not exist at the - value level. Nevertheless, it is possible to strictly evaluate a value - whose type is a `type data` declaration. Test case - type-data/should_compile/T2294b.hs contains an example: - - type data T a where - A :: T Int - - f :: T a -> () - f !x = () - - We want to generate the following Core for f: - - f = \(@a) (x :: T a) -> - case x of - __DEFAULT -> () - - Namely, we do _not_ want to match on `A`, as it doesn't exist at the value - level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module +We must not refine the DEFAULT into a DataAlt for newtypes, `type data` +declarations, or unary classes, since none of these have a data constructor +that can appear in a DataAlt. See Note [DataAlt restrictions] in GHC.Core. Note [Combine identical alternatives] ===================================== testsuite/tests/simplCore/should_run/T27071.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -O -fworker-wrapper-cbv #-} +module Main where + +class MyClass a where + myVal :: Int + +instance MyClass Bool where + myVal = 0 + +showMyVal :: forall a. MyClass a => String +showMyVal = show (myVal @a) +{-# NOINLINE showMyVal #-} + +main :: IO () +main = putStrLn (showMyVal @Bool) ===================================== testsuite/tests/simplCore/should_run/T27071.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/simplCore/should_run/all.T ===================================== @@ -121,3 +121,4 @@ test('T25096', normal, compile_and_run, ['-O -dcore-lint']) test('AppIsHNF', normal, compile_and_run, ['-O']) test('T24359b', normal, compile_and_run, ['-O']) test('T23429', normal, compile_and_run, ['-O']) +test('T27071', normal, compile_and_run, ['-O -fworker-wrapper-cbv']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05094993774191ede5c96770d8c91e8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05094993774191ede5c96770d8c91e8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Windows: remove StgAsyncIOResult and fix crash/leaks
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fcf092dd by Luite Stegeman at 2026-03-27T04:44:17-04:00 Windows: remove StgAsyncIOResult and fix crash/leaks In stg_block_async{_void}, a stack slot was reserved for an StgAsyncIOResult. This slot would be filled by the IO manager upon completion of the async call. However, if the blocked thread was interrupted by an async exception, we would end up in an invalid state: - If the blocked computation was never re-entered, the StgAsyncIOResult would never be freed. - If the blocked computation was re-entered, the thread would find an unitialized stack slot for the StgAsyncIOResult, leading to a crash reading its fields, or freeing the pointer. We fix this by removing the StgAsyncIOResult altogether and writing the result directly to the stack. Fixes #26341 - - - - - 17 changed files: - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/Threads.c - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - + testsuite/tests/concurrent/should_run/T26341.hs - + testsuite/tests/concurrent/should_run/T26341.stdout - + testsuite/tests/concurrent/should_run/T26341a.hs - + testsuite/tests/concurrent/should_run/T26341a.stdout - + testsuite/tests/concurrent/should_run/T26341b.hs - + testsuite/tests/concurrent/should_run/T26341b.stdout - testsuite/tests/concurrent/should_run/all.T - utils/deriveConstants/Main.hs Changes: ===================================== rts/HeapStackCheck.cmm ===================================== @@ -703,38 +703,24 @@ stg_block_throwto (P_ tso, P_ exception) } #if defined(mingw32_HOST_OS) -INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares ) +INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ len, W_ errCode ) return () { - W_ len, errC; - - len = TO_W_(StgAsyncIOResult_len(ares)); - errC = TO_W_(StgAsyncIOResult_errCode(ares)); - ccall free(ares "ptr"); - return (len, errC); + return (len, errCode); } stg_block_async { - Sp_adj(-2); - Sp(0) = stg_block_async_info; - BLOCK_GENERIC; -} + W_ eintr; + (eintr) = ccall rts_EINTR(); -/* Used by threadDelay implementation; it would be desirable to get rid of - * this free()'ing void return continuation. - */ -INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares ) - return () -{ - ccall free(ares "ptr"); - return (); -} - -stg_block_async_void -{ - Sp_adj(-2); - Sp(0) = stg_block_async_void_info; + // Fill the stack frame with values that indicate that the operation + // has been interrupted. The IO manager will overwrite these with the + // actual results if the async operation completes. + Sp_adj(-3); + Sp(0) = stg_block_async_info; + Sp(1) = -1; // len: -1 indicates error + Sp(2) = eintr; // errCode: interrupted BLOCK_GENERIC; } ===================================== rts/IOManager.c ===================================== @@ -633,10 +633,8 @@ void scavengeTSOIOManager(StgTSO *tso) #endif /* case IO_MANAGER_WIN32_LEGACY: - * BlockedOn{Read,Write,DoProc} uses block_info.async_result - * The StgAsyncIOResult async_result is allocated on the C heap. - * It'd probably be better if it used the GC heap. If it did we'd - * scavenge it here. + * BlockedOn{Read,Write,DoProc} uses block_info.async_reqID + * which is a plain integer, so nothing to scavenge. */ default: @@ -846,7 +844,7 @@ void syncIOCancel(Capability *cap, StgTSO *tso) case IO_MANAGER_WIN32_LEGACY: removeThreadFromDeQueue(cap, &cap->iomgr->blocked_queue_hd, &cap->iomgr->blocked_queue_tl, tso); - abandonWorkRequest(tso->block_info.async_result->reqID); + abandonWorkRequest(tso->block_info.async_reqID); break; #endif default: @@ -885,12 +883,7 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay) * would make the primops more consistent. */ { - StgAsyncIOResult *ares = stgMallocBytes(sizeof(StgAsyncIOResult), - "syncDelay"); - ares->reqID = addDelayRequest(us_delay); - ares->len = 0; - ares->errCode = 0; - tso->block_info.async_result = ares; + tso->block_info.async_reqID = addDelayRequest(us_delay); /* Having all async-blocked threads reside on the blocked_queue * simplifies matters, so set the status to OnDoProc and put the ===================================== rts/PrimOps.cmm ===================================== @@ -2255,18 +2255,7 @@ stg_delayzh ( W_ us_delay ) (ok) = ccall syncDelay(MyCapability() "ptr", CurrentTSO "ptr", us_delay); if (ok != 0::CBool) (likely: True) { - /* Annoyingly, we cannot be consistent with how we wait and resume the - * blocked thread. The reason is that the win32 legacy I/O manager - * allocates a StgAsyncIOResult struct on the C heap which has to be - * freed when the thread resumes. It's a bit awkward to arrange to - * allocate it on the GC heap instead, so that's how it is for now. - * Sigh. - */ -#if defined(mingw32_HOST_OS) - jump stg_block_async_void(); -#else jump stg_block_noregs(); -#endif } else { jump stg_raisezh(HsIface_heapOverflow_closure(W_[ghc_hs_iface])); } @@ -2276,21 +2265,14 @@ stg_delayzh ( W_ us_delay ) #if defined(mingw32_HOST_OS) stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) { - W_ ares; CInt reqID; #if defined(THREADED_RTS) ccall sbarf("asyncRead# on threaded RTS") never returns; #else - /* could probably allocate this on the heap instead */ - ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, - "stg_asyncReadzh"); (reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr"); - StgAsyncIOResult_reqID(ares) = reqID; - StgAsyncIOResult_len(ares) = 0; - StgAsyncIOResult_errCode(ares) = 0; - StgTSO_block_info(CurrentTSO) = ares; + StgTSO_block_info(CurrentTSO) = reqID; ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32; @@ -2302,21 +2284,14 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) { - W_ ares; CInt reqID; #if defined(THREADED_RTS) ccall sbarf("asyncWrite# on threaded RTS") never returns; #else - ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, - "stg_asyncWritezh"); (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr"); - - StgAsyncIOResult_reqID(ares) = reqID; - StgAsyncIOResult_len(ares) = 0; - StgAsyncIOResult_errCode(ares) = 0; - StgTSO_block_info(CurrentTSO) = ares; + StgTSO_block_info(CurrentTSO) = reqID; ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32; @@ -2328,21 +2303,14 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) stg_asyncDoProczh ( W_ proc, W_ param ) { - W_ ares; CInt reqID; #if defined(THREADED_RTS) ccall sbarf("asyncDoProc# on threaded RTS") never returns; #else - /* could probably allocate this on the heap instead */ - ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, - "stg_asyncDoProczh"); (reqID) = ccall addDoProcRequest(proc "ptr",param "ptr"); - StgAsyncIOResult_reqID(ares) = reqID; - StgAsyncIOResult_len(ares) = 0; - StgAsyncIOResult_errCode(ares) = 0; - StgTSO_block_info(CurrentTSO) = ares; + StgTSO_block_info(CurrentTSO) = reqID; ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); %release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I32; ===================================== rts/RtsSymbols.c ===================================== @@ -30,6 +30,7 @@ #include <shfolder.h> /* SHGetFolderPathW */ #include "IOManager.h" #include "win32/AsyncWinIO.h" +#include "win32/AsyncMIO.h" #endif #if defined(openbsd_HOST_OS) @@ -168,6 +169,7 @@ extern char **environ; SymI_HasProto(__stdio_common_vswprintf_s) \ SymI_HasProto(__stdio_common_vswprintf) \ SymI_HasProto(_errno) \ + SymI_HasProto(rts_EINTR) \ /* see Note [Symbols for MinGW's printf] */ \ SymI_HasProto(_lock_file) \ SymI_HasProto(_unlock_file) \ ===================================== rts/Threads.c ===================================== @@ -926,7 +926,7 @@ printThreadBlockage(StgTSO *tso) switch (ACQUIRE_LOAD(&tso->why_blocked)) { #if defined(mingw32_HOST_OS) case BlockedOnDoProc: - debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID); + debugBelch("is blocked on proc (request: %" FMT_Word ")", tso->block_info.async_reqID); break; #endif #if !defined(THREADED_RTS) ===================================== rts/include/rts/storage/TSO.h ===================================== @@ -37,15 +37,6 @@ typedef StgWord64 StgThreadID; */ typedef unsigned int StgThreadReturnCode; -#if defined(mingw32_HOST_OS) -/* results from an async I/O request + its request ID. */ -typedef struct { - unsigned int reqID; - int len; - int errCode; -} StgAsyncIOResult; -#endif - /* Reason for thread being blocked. See comment above struct StgTso_. */ typedef union { StgClosure *closure; @@ -57,7 +48,7 @@ typedef union { StgAsyncIOOp *aiop; StgTimeoutQueue *timeout; #if defined(mingw32_HOST_OS) - StgAsyncIOResult *async_result; + StgWord async_reqID; #endif #if !defined(THREADED_RTS) StgWord target; ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -379,8 +379,6 @@ RTS_RET(stg_block_putmvar); #if defined(mingw32_HOST_OS) RTS_FUN_DECL(stg_block_async); RTS_RET(stg_block_async); -RTS_FUN_DECL(stg_block_async_void); -RTS_RET(stg_block_async_void); #endif RTS_FUN_DECL(stg_block_stmwait); RTS_FUN_DECL(stg_block_throwto); ===================================== rts/win32/AsyncMIO.c ===================================== @@ -8,16 +8,19 @@ * For the WINIO manager see base in the GHC.Event modules. */ -#if !defined(THREADED_RTS) #include "Rts.h" +#include <errno.h> +#include "win32/AsyncMIO.h" + +#if !defined(THREADED_RTS) + #include "RtsUtils.h" #include <windows.h> #include <stdio.h> #include "Schedule.h" #include "Capability.h" #include "IOManagerInternals.h" -#include "win32/AsyncMIO.h" #include "win32/MIOManager.h" /* @@ -299,14 +302,9 @@ start: case BlockedOnRead: case BlockedOnWrite: case BlockedOnDoProc: - if (tso->block_info.async_result->reqID == rID) { - // Found the thread blocked waiting on request; - // stodgily fill - // in its result block. - tso->block_info.async_result->len = - completedTable[i].len; - tso->block_info.async_result->errCode = - completedTable[i].errCode; + if (tso->block_info.async_reqID == rID) { + HsInt len = completedTable[i].len; + HsInt errCode = completedTable[i].errCode; // Drop the matched TSO from blocked_queue if (prev) { @@ -322,11 +320,14 @@ start: // Terminates the run queue + this inner for-loop. tso->_link = END_TSO_QUEUE; tso->why_blocked = NotBlocked; - // save the StgAsyncIOResult in the - // stg_block_async_info stack frame, because - // the block_info field will be overwritten by - // pushOnRunQueue(). - tso->stackobj->sp[1] = (W_)tso->block_info.async_result; + // For stg_block_async frames (read/write/doProc), + // write len and errCode directly to the stack. + // For stg_block_noregs frames (delay), nothing + // to write. + if (tso->stackobj->sp[0] == (W_)&stg_block_async_info) { + tso->stackobj->sp[1] = (W_)len; + tso->stackobj->sp[2] = (W_)errCode; + } pushOnRunQueue(&MainCapability, tso); break; } @@ -389,3 +390,8 @@ resetAbandonRequestWait( void ) } #endif /* !defined(THREADED_RTS) */ + +HsInt rts_EINTR(void) +{ + return EINTR; +} ===================================== rts/win32/AsyncMIO.h ===================================== @@ -27,3 +27,4 @@ extern int awaitRequests(bool wait); extern void abandonRequestWait(void); extern void resetAbandonRequestWait(void); +extern HsInt rts_EINTR(void); ===================================== testsuite/tests/concurrent/should_run/T26341.hs ===================================== @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -O -fno-full-laziness #-} + +import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread) +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception +import GHC.Exts + +compute :: Int +compute = noinline unsafePerformIO $ do + mainThreadID <- myThreadId + _ <- forkIO $ do + threadDelay 500000 + killThread mainThreadID + threadDelay 1000000 + return 0 + +main = do + catch (print compute) (\(e :: AsyncException) -> print $ "1:" ++ show e) + catch (print compute) (\(e :: AsyncException) -> print $ "2:" ++ show e) + print "done" ===================================== testsuite/tests/concurrent/should_run/T26341.stdout ===================================== @@ -0,0 +1,3 @@ +"1:thread killed" +0 +"done" ===================================== testsuite/tests/concurrent/should_run/T26341a.hs ===================================== @@ -0,0 +1,75 @@ +-- Test that re-evaluating an AP_STACK from an interrupted async I/O call +-- does not crash. On Windows non-threaded RTS, re-entry returns EINTR +-- which readRawBufferPtr converts to IOException Interrupted. On the +-- threaded RTS (any platform), the blocking read is re-attempted and +-- succeeds because we write a byte to the pipe between evaluations. +-- +-- Before the fix for #26341, re-evaluation on Windows would crash or read +-- uninitialized memory from a freed StgAsyncIOResult. +{-# OPTIONS_GHC -O -fno-full-laziness #-} + +import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread, rtsSupportsBoundThreads) +import Control.Exception +import Data.IORef +import Foreign +import Foreign.C +import GHC.Exts +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) +import System.Info (os) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (createPipeFd) + +-- Store the write fd so main can feed data into the pipe between +-- evaluations. On Unix this unblocks the re-entered read; on Windows +-- stg_block_async returns EINTR regardless. +{-# NOINLINE writeFdRef #-} +writeFdRef :: IORef CInt +writeFdRef = unsafePerformIO $ newIORef (-1) + +-- | A thunk whose unsafePerformIO blocks on a pipe read. A forked +-- thread kills the main thread after 200ms, which creates an AP_STACK. +{-# NOINLINE blockedRead #-} +blockedRead :: () +blockedRead = noinline unsafePerformIO $ do + (readFd, writeFd) <- createPipeFd + writeIORef writeFdRef writeFd + buf <- mallocBytes 1 + mainTid <- myThreadId + _ <- forkIO $ do + threadDelay 200000 -- 200ms + killThread mainTid + -- readRawBufferPtr dispatches to asyncReadRawBufferPtr on Windows + -- non-threaded RTS; on Unix it uses threadWaitRead + read(). + _ <- readRawBufferPtr "blockedRead" (FD readFd 0) buf 0 1 + return () + +main :: IO () +main = do + -- First evaluation: the thunk blocks on the pipe read, gets killed. + catch (evaluate blockedRead) + (\(e :: AsyncException) -> putStrLn $ "caught: " ++ show e) + + -- Write a byte so the re-entered read can complete on Unix. + wfd <- readIORef writeFdRef + buf <- mallocBytes 1 + poke buf 0 + _ <- writeRawBufferPtr "unblock" (FD wfd 0) buf 0 1 + + -- Second evaluation: AP_STACK re-enters. + -- Non-threaded Windows: asyncRead returns (-1, EINTR) → IOException + -- Threaded / Unix: read succeeds → returns normally + let expectEINTR = os == "mingw32" && not rtsSupportsBoundThreads + result <- try (evaluate blockedRead) + case result of + Left e + | Just ioe <- fromException e + , ioe_type (ioe :: IOException) == Interrupted + -> putStrLn "re-evaluated ok" + | otherwise + -> putStrLn $ "unexpected: " ++ show e + Right () + | expectEINTR -> putStrLn "unexpected: expected EINTR" + | otherwise -> putStrLn "re-evaluated ok" + + putStrLn "done" ===================================== testsuite/tests/concurrent/should_run/T26341a.stdout ===================================== @@ -0,0 +1,3 @@ +caught: thread killed +re-evaluated ok +done ===================================== testsuite/tests/concurrent/should_run/T26341b.hs ===================================== @@ -0,0 +1,101 @@ +-- Stress test for #26341: repeatedly interrupt async-blocked threads and +-- re-enter their AP_STACKs. Before the fix, re-entering a thunk whose +-- unsafePerformIO was blocked on an async I/O call (Windows non-threaded +-- RTS) would read uninitialized memory or free a dangling pointer, +-- because stg_block_async reserved a stack slot for a heap-allocated +-- StgAsyncIOResult that became invalid after an async exception. +-- +-- This test spawns many concurrent workers, each of which: +-- 1. Creates a pipe. +-- 2. Builds a thunk that blocks on a pipe read via unsafePerformIO. +-- 3. Evaluates the thunk and kills it with an async exception. +-- 4. Re-evaluates the thunk (AP_STACK re-entry). +-- 5. Repeats many times. +-- +-- On threaded RTS / Unix the re-entered read succeeds (we write a byte +-- first). On Windows non-threaded RTS the re-entered async call returns +-- EINTR. Both paths exercise the fixed stack-frame layout. +{-# OPTIONS_GHC -O -fno-full-laziness #-} + +import Control.Concurrent +import Control.Exception +import Foreign +import Foreign.C +import GHC.Exts +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) +import System.IO (hFlush, stdout) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals (c_close) +import System.Process (createPipeFd) + +iterations :: Int +iterations = 200 + +workers :: Int +workers = 4 + +-- Each worker independently performs `iterations` rounds of: +-- block on pipe read → interrupt → re-evaluate the AP_STACK. +worker :: Int -> MVar () -> IO () +worker wid done = do + buf <- mallocBytes 1 + let go 0 = return () + go n = do + (readFd, writeFd) <- createPipeFd + + -- Build a fresh thunk each iteration so we get a new AP_STACK. + let {-# NOINLINE blockedThunk #-} + blockedThunk :: () + blockedThunk = noinline unsafePerformIO $ do + tid <- myThreadId + _ <- forkIO $ do + threadDelay 1000 -- 1ms: tight window + killThread tid + _ <- readRawBufferPtr "stress" (FD readFd 0) buf 0 1 + return () + + -- First evaluation: block and get killed. + catch (evaluate blockedThunk) + (\(_ :: SomeException) -> return ()) + + -- Write a byte so the re-entered read can complete on + -- threaded RTS / Unix. + poke buf 0 + _ <- writeRawBufferPtr "unblock" (FD writeFd 0) buf 0 1 + + -- Second evaluation: AP_STACK re-entry. + result <- try (evaluate blockedThunk) + case result of + Left e + | Just ioe <- fromException e + , ioe_type (ioe :: IOException) == Interrupted + -> return () -- expected on Windows non-threaded + | otherwise + -> throwIO (userError $ + "worker " ++ show wid ++ " iteration " ++ show n ++ + ": unexpected exception: " ++ show e) + Right () -> return () -- expected on threaded / Unix + + -- Close the pipe fds. + _ <- c_close readFd + _ <- c_close writeFd + + go (n - 1) + + go iterations + putMVar done () + +main :: IO () +main = do + dones <- mapM (\wid -> do + done <- newEmptyMVar + _ <- forkIO (worker wid done) + return done + ) [1..workers] + + -- Wait for all workers to finish. + mapM_ takeMVar dones + + putStrLn "stress test passed" + hFlush stdout ===================================== testsuite/tests/concurrent/should_run/T26341b.stdout ===================================== @@ -0,0 +1 @@ +stress test passed ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -309,3 +309,19 @@ test('hs_try_putmvar003', # Check forkIO exception determinism under optimization test('T13330', normal, compile_and_run, ['-O']) + +test('T26341', normal, compile_and_run, ['']) + +# Test EINTR for async I/O interrupted by an exception (#26341) +test('T26341a' + # test uses pipe operations which are not supported by the JS/wasm backends + , when(arch('wasm32') or arch('javascript'), skip) + , compile_and_run, ['-package process']) + +# Stress test: many threads repeatedly interrupt and re-enter async-blocked +# thunks (#26341). Before the fix, this would crash due to dangling +# StgAsyncIOResult pointers on the stack. +test('T26341b' + # test uses pipe operations which are not supported by the JS/wasm backends + , when(arch('wasm32') or arch('javascript'), skip) + , compile_and_run, ['-package process']) ===================================== utils/deriveConstants/Main.hs ===================================== @@ -627,12 +627,7 @@ wanteds os = concat -- Note that this conditional part only affects the C headers. -- That's important, as it means we get the same PlatformConstants -- type on all platforms. - ,if os == Just Windows - then concat [structSize C "StgAsyncIOResult" - ,structField C "StgAsyncIOResult" "reqID" - ,structField C "StgAsyncIOResult" "len" - ,structField C "StgAsyncIOResult" "errCode"] - else [] + ,[] -- struct HsIface ,structField C "HsIface" "Z0T_closure" @@ -759,9 +754,6 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram "", "#define PROFILING", "#define THREADED_RTS", - -- We need to define this if we want StgAsyncIOResult - -- struct to be present after CPP - -- -- FIXME: rts/PosixSource.h should include ghcplatform.h -- which should set this. There is a mismatch host/target -- again... View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcf092dda534cc38637d1f7920aa0da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcf092dda534cc38637d1f7920aa0da… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] STM: don't create a transaction in the rhs of catchRetry# (#26028)
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f8de456f by Sylvain Henry at 2026-03-27T04:43:22-04:00 STM: don't create a transaction in the rhs of catchRetry# (#26028) We don't need to create a transaction for the rhs of (catchRetry#) because contrary to the lhs we don't need to abort it on retry. Moreover it is particularly harmful if we have code such as (#26028): let cN = readTVar vN >> retry tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...)) atomically tree Because it will stack transactions for the rhss and the read-sets of all the transactions will be iteratively merged in O(n^2) after the execution of the most nested retry. This is the second attempt at implementing this. The first attempt triggered segfaults (#26291) and has been reverted. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 12 changed files: - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - rts/STM.h - rts/Schedule.c - + testsuite/tests/lib/stm/T26028.hs - + testsuite/tests/lib/stm/T26028.stdout - + testsuite/tests/lib/stm/T26291a.hs - + testsuite/tests/lib/stm/T26291a.stdout - + testsuite/tests/lib/stm/T26291b.hs - + testsuite/tests/lib/stm/T26291b.stdout - + testsuite/tests/lib/stm/all.T Changes: ===================================== rts/PrimOps.cmm ===================================== @@ -1229,16 +1229,27 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, gcptr trec, outer, arg; trec = StgTSO_trec(CurrentTSO); - outer = StgTRecHeader_enclosing_trec(trec); - (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); - if (r != 0) { - // Succeeded (either first branch or second branch) - StgTSO_trec(CurrentTSO) = outer; - return (ret); - } else { - // Did not commit: abort and restart. - StgTSO_trec(CurrentTSO) = outer; - jump stg_abort(); + if (running_alt_code != 1) { + // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup + // the nested transaction. + // See Note [catchRetry# implementation] + outer = StgTRecHeader_enclosing_trec(trec); + (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); + if (r != 0) { + // Succeeded in first branch + StgTSO_trec(CurrentTSO) = outer; + return (ret); + } else { + // Did not commit: abort and restart. + StgTSO_trec(CurrentTSO) = outer; + jump stg_abort(); + } + } + else { + // nothing to do in the rhs code of catchRetry# lhs rhs, it's already + // using the parent transaction (not a nested one). + // See Note [catchRetry# implementation] + return (ret); } } @@ -1471,21 +1482,26 @@ retry_pop_stack: outer = StgTRecHeader_enclosing_trec(trec); if (frame_type == CATCH_RETRY_FRAME) { - // The retry reaches a CATCH_RETRY_FRAME before the atomic frame - ASSERT(outer != NO_TREC); - // Abort the transaction attempting the current branch - ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); - ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); + // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME + if (!StgCatchRetryFrame_running_alt_code(frame) != 0) { - // Retry in the first branch: try the alternative - ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr"); - StgTSO_trec(CurrentTSO) = trec; + // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested + // transaction. See Note [catchRetry# implementation] + + // check that we have a parent transaction + ASSERT(outer != NO_TREC); + + // Abort the nested transaction + ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); + ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); + + // As we are retrying in the lhs code, we must now try the rhs code + StgTSO_trec(CurrentTSO) = outer; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); jump stg_ap_v_fast [R1]; } else { - // Retry in the alternative code: propagate the retry - StgTSO_trec(CurrentTSO) = outer; + // Retry in the rhs code: propagate the retry Sp = Sp + SIZEOF_StgCatchRetryFrame; goto retry_pop_stack; } ===================================== rts/RaiseAsync.c ===================================== @@ -1043,8 +1043,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, } case CATCH_STM_FRAME: - case CATCH_RETRY_FRAME: - // CATCH frames within an atomically block: abort the + // CATCH_STM frame within an atomically block: abort the // inner transaction and continue. Eventually we will // hit the outer transaction that will get frozen (see // above). @@ -1056,14 +1055,30 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; - debugTraceCap(DEBUG_stm, cap, - "found atomically block delivering async exception"); + debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame"); stmAbortTransaction(cap, trec); stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; }; + case CATCH_RETRY_FRAME: + // CATCH_RETRY frame within an atomically block: if we're executing + // the lhs code, abort the inner transaction and continue; if we're + // executing the rhs, continue (no nested transaction to abort. See + // Note [catchRetry# implementation]). Eventually we will hit the + // outer transaction that will get frozen (see above). + // + // As for the CATCH_STM_FRAME case above, we do not care + // whether the transaction is valid or not because its + // possible validity cannot have caused the exception + // and will not be visible after the abort. + { + debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame"); + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)frame); + break; + }; + default: // see Note [Update async masking state on unwind] in Schedule.c if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { ===================================== rts/STM.c ===================================== @@ -961,6 +961,46 @@ void stmFreeAbortedTRec(Capability *cap, TRACE("%p : stmFreeAbortedTRec done", trec); } +/* +Note [catchRetry# implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +catchRetry# creates a nested transaction for its lhs: +- if the lhs transaction succeeds: + - the lhs transaction is committed + - its read-variables are merged with those of the parent transaction + - the rhs code is ignored +- if the lhs transaction retries: + - the lhs transaction is aborted + - its read-variables are merged with those of the parent transaction + - the rhs code is executed directly in the parent transaction (see #26028). + +So note that: +- lhs code uses a nested transaction +- rhs code doesn't use a nested transaction + +We have to take which case we're in into account (using the running_alt_code +field of the catchRetry frame) in catchRetry's entry code, in retry# +implementation, and also when an async exception is received (to cleanup the +right number of transactions). +*/ + +/* Called when unwinding past a CATCH_RETRY_FRAME. + * Only aborts the transaction if we're executing the lhs (running_alt_code=0), + * because rhs code uses the parent transaction directly with no nested trec. + * See Note [catchRetry# implementation]. + */ +void stmAbortNestedCatchRetryTransaction(Capability *cap, + StgTSO *tso, + StgCatchRetryFrame *frame) { + if (!frame->running_alt_code) { + StgTRecHeader *trec = tso->trec; + StgTRecHeader *outer = trec->enclosing_trec; + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso->trec = outer; + } +} + /*......................................................................*/ void stmCondemnTransaction(Capability *cap, ===================================== rts/STM.h ===================================== @@ -67,6 +67,9 @@ StgTRecHeader *stmStartNestedTransaction(Capability *cap, StgTRecHeader *outer void stmAbortTransaction(Capability *cap, StgTRecHeader *trec); void stmFreeAbortedTRec(Capability *cap, StgTRecHeader *trec); +void stmAbortNestedCatchRetryTransaction(Capability *cap, + StgTSO *tso, + StgCatchRetryFrame *frame); /* * Ensure that a subsequent commit / validation will fail. We use this ===================================== rts/Schedule.c ===================================== @@ -3088,14 +3088,9 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) return STOP_FRAME; case CATCH_RETRY_FRAME: { - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; debugTrace(DEBUG_stm, "found CATCH_RETRY_FRAME at %p during raise", p); - debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p); p = next; continue; } @@ -3248,14 +3243,9 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso) return ATOMICALLY_FRAME; case CATCH_RETRY_FRAME: { - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; debugTrace(DEBUG_stm, "found CATCH_RETRY_FRAME at %p while aborting after orElse", p); - debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; + stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p); p = next; continue; } ===================================== testsuite/tests/lib/stm/T26028.hs ===================================== @@ -0,0 +1,23 @@ +module Main where + +import GHC.Conc + +forever :: IO String +forever = delay 10 >> forever + +terminates :: IO String +terminates = delay 1 >> pure "terminates" + +delay s = threadDelay (1000000 * s) + +async :: IO a -> IO (STM a) +async a = do + var <- atomically (newTVar Nothing) + forkIO (a >>= atomically . writeTVar var . Just) + pure (readTVar var >>= maybe retry pure) + +main :: IO () +main = do + x <- mapM async $ terminates : replicate 50000 forever + r <- atomically (foldr1 orElse x) + print r ===================================== testsuite/tests/lib/stm/T26028.stdout ===================================== @@ -0,0 +1 @@ +"terminates" ===================================== testsuite/tests/lib/stm/T26291a.hs ===================================== @@ -0,0 +1,15 @@ +module Main where + +import Control.Concurrent.STM +import Control.Exception + +main :: IO () +main = do + result <- try @SomeException $ atomically $ + -- LHS retries → CATCH_RETRY_FRAME gets running_alt_code=1, RHS executes. + -- RHS throws → raiseExceptionHelper walks the stack, finds the + -- CATCH_RETRY_FRAME (running_alt_code=1), and must NOT abort tso->trec. + orElse retry (throwSTM (ErrorCall "test")) + case result of + Left _ -> putStrLn "OK" + Right _ -> putStrLn "impossible" ===================================== testsuite/tests/lib/stm/T26291a.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/lib/stm/T26291b.hs ===================================== @@ -0,0 +1,42 @@ +-- Test for the findAtomicallyFrameHelper crash when running_alt_code=1. +-- +-- findAtomicallyFrameHelper is called by stg_abort, which fires when a nested +-- transaction's stmCommitNestedTransaction fails (due to a concurrent TVar +-- write conflicting with the nested trec's read set). If the walk encounters +-- a CATCH_RETRY_FRAME with running_alt_code=1, the old code unconditionally +-- called stmAbortTransaction on tso->trec, which is the *parent* transaction +-- (no nested trec exists for the RHS). That freed the parent trec, leaving +-- tso->trec as garbage; stg_abort then dereferenced it and crashed. +-- +-- The structure that exercises this: +-- outer orElse: LHS retries → RHS runs (outer CATCH_RETRY_FRAME has running_alt_code=1) +-- inner orElse: LHS reads a TVar in a nested trec and tries to commit +-- → if a concurrent writer invalidates the read, stmCommitNestedTransaction fails +-- → stg_abort → findAtomicallyFrameHelper encounters the outer CATCH_RETRY_FRAME +-- (running_alt_code=1) → crash without the fix. +module Main where + +import Control.Concurrent +import Control.Concurrent.STM + +main :: IO () +main = do + tv <- newTVarIO (0 :: Int) + + -- Continuously modify tv to provoke nested-commit failures. + _ <- forkIO $ let loop = atomically (modifyTVar' tv (+1)) >> loop in loop + + -- Run the critical orElse pattern many times. Each iteration the inner LHS + -- reads tv (nested trec) and tries to commit; concurrent writes will + -- occasionally cause the commit to fail and trigger stg_abort. + let loop 0 = return () + loop n = do + _ <- atomically $ + orElse + retry -- outer LHS: always retries + (orElse (readTVar tv) (return 0)) -- outer RHS (running_alt_code=1): + -- inner LHS reads tv (nested trec) + loop (n - 1) + loop (100000 :: Int) + + putStrLn "OK" ===================================== testsuite/tests/lib/stm/T26291b.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/lib/stm/all.T ===================================== @@ -0,0 +1,3 @@ +test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) +test('T26291a', normal, compile_and_run, ['-O2']) +test('T26291b', only_ways(['threaded1']), compile_and_run, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Extend HsExpr with the StarIsType syntax (#26587, #26967)
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 66e5e324 by Vladislav Zavialov at 2026-03-27T04:42:25-04:00 Extend HsExpr with the StarIsType syntax (#26587, #26967) This patch allows kinds of the form `k -> *` and `* -> k` to occur in expression syntax, i.e. to be used as required type arguments. For example: {-# LANGUAGE RequiredTypeArguments, StarIsType #-} x1 = f (* -> * -> *) x2 = f (forall k. k -> *) x3 = f ((* -> *) -> Constraint) Summary of the changes: * Introduce the HsStar constructor of HsExpr and its extension field XStar. It is analogous to HsStarTy in HsType. * Refactor HsStarTy to store the unicode flag as TokStar, defined as type TokStar = EpUniToken "*" "★" -- similar to TokForall, TokRArrow, etc. The token is stored in the extension field and replaces the Bool field. * Extend the `infixexp2` nonterminal to parse `*` as a direct argument of `->`. This is more limited than the full StarIsType syntax, but has the nice property of not conflicting with the multiplication operator `a * b`. Test case: T26967 T26967_tyop - - - - - 37 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/required_type_arguments.rst - + testsuite/tests/vdq-rta/should_compile/T26967.hs - + testsuite/tests/vdq-rta/should_compile/T26967.stderr - + testsuite/tests/vdq-rta/should_compile/T26967_tyop.hs - + testsuite/tests/vdq-rta/should_compile/T26967_tyop.stderr - testsuite/tests/vdq-rta/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66e5e3245a26bdaadfaab5358df04f9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66e5e3245a26bdaadfaab5358df04f9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Remove backwards compatibility pattern synonym `ModLocation`
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b26bb2ea by VeryMilkyJoe at 2026-03-27T04:41:38-04:00 Remove backwards compatibility pattern synonym `ModLocation` Fixes #24932 - - - - - 5 changed files: - compiler/GHC.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Unit/Module/Location.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -79,7 +79,13 @@ module GHC ( ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgLookupModule, ModSummary(..), ms_mod_name, ModLocation(..), - pattern ModLocation, + ml_hs_file, + ml_hi_file, + ml_dyn_hi_file, + ml_obj_file, + ml_dyn_obj_file, + ml_hie_file, + ml_bytecode_file, getModSummary, getModuleGraph, isLoaded, @@ -1575,7 +1581,7 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions -getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags) +getModuleSourceAndFlags :: ModSummary -> IO (FilePath, StringBuffer, DynFlags) getModuleSourceAndFlags m = do case ml_hs_file $ ms_location m of Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m)) ===================================== compiler/GHC/CoreToStg/AddImplicitBinds.hs ===================================== @@ -10,7 +10,7 @@ import GHC.Prelude import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) ) -import GHC.Unit( ModLocation(..) ) +import GHC.Unit( ModLocation(..), ml_hs_file ) import GHC.Core import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId ) ===================================== compiler/GHC/Unit/Module/Location.hs ===================================== @@ -2,22 +2,19 @@ {-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location - ( ModLocation - ( .. - , ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - ) - , pattern ModLocation + ( ModLocation(..) , addBootSuffix , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix , mkFileSrcSpan + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + , ml_bytecode_file ) where @@ -128,33 +125,30 @@ mkFileSrcSpan mod_loc -- Helpers for backwards compatibility -- ---------------------------------------------------------------------------- -{-# COMPLETE ModLocation #-} - -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation -pattern ModLocation - { ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - } <- OsPathModLocation - { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) - , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) - , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) - , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) - , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) - , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) - , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file) - } where - ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file - = OsPathModLocation - { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file - , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file - , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file - , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file - , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file - , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file - , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file - } +ml_hs_file :: ModLocation -> Maybe FilePath +{-# INLINE ml_hs_file #-} +ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath + +ml_hi_file :: ModLocation -> FilePath +{-# INLINE ml_hi_file #-} +ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath + +ml_dyn_hi_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_hi_file #-} +ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath + +ml_obj_file :: ModLocation -> FilePath +{-# INLINE ml_obj_file #-} +ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath + +ml_dyn_obj_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_obj_file #-} +ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath + +ml_hie_file :: ModLocation -> FilePath +{-# INLINE ml_hie_file #-} +ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath + +ml_bytecode_file :: ModLocation -> FilePath +{-# INLINE ml_bytecode_file #-} +ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) = -- with the module summary information let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Load a module graph and report the result ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Test a module graph and report if it matches expected invariant violations testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26bb2ea9516782465a1978d0feeadc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26bb2ea9516782465a1978d0feeadc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 3 commits: Fix assert in Interpreter.c
by Marge Bot (＠marge-bot) 27 Mar '26

27 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 404b71c1 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Fix assert in Interpreter.c If we skip exactly the number of words on the stack we end up on the first word in the next chunk. - - - - - a85bd503 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Support arbitrary size unboxed tuples in bytecode This stores the size (number of words on the stack) of the next expected tuple in the TSO, ctoi_spill_size field, eliminating the need of stg_ctoi_tN frames for each size. Note: On 32 bit platform there is still a bytecode tuple size limit of 255 words on the stack. Fixes #26946 - - - - - e2209031 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Add specialized frames for small tuples Small tuples are now returned more efficiently to the interpreter. They use one less word of stack space and don't need manipulation of the TSO anymore. - - - - - 25 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/StgToByteCode.hs - rts/Apply.cmm - rts/Continuation.c - rts/ContinuationOps.cmm - rts/Interpreter.c - rts/Printer.c - rts/RaiseAsync.c - rts/RtsSymbols.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/Bytecodes.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - + testsuite/tests/bytecode/tuplestress/ByteCode.hs - + testsuite/tests/bytecode/tuplestress/Common.hs-incl - + testsuite/tests/bytecode/tuplestress/Obj.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.stdout - + testsuite/tests/bytecode/tuplestress/all.T - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -973,13 +973,16 @@ return_non_tuple V32 = error "return_non_tuple: vector" return_non_tuple V64 = error "return_non_tuple: vector" {- - we can only handle up to a fixed number of words on the stack, - because we need a stg_ctoi_tN stack frame for each size N. See - Note [unboxed tuple bytecodes and tuple_BCO]. + The maximum number of words that can be spilled on the stack for + a tuple return. This is limited by the encoding of the stack + spill size in the call_info word (used by stg_ret_t): - If needed, you can support larger tuples by adding more in - Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and - raising this limit. + - On 32-bit platforms: 8-bit (bits 24-31), max 255 + - On 64-bit platforms: 40-bit (bits 24-63) + + The stg_ctoi_t frame itself has no size limit since it reads the + spill count from the TSO's ctoi_tuple_spill_words field. See + Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm. Note that the limit is the number of words passed on the stack. If the calling convention passes part of the tuple in registers, the @@ -987,8 +990,10 @@ return_non_tuple V64 = error "return_non_tuple: vector" take multiple words on the stack (for example Double# on a 32 bit platform). -} -maxTupleReturnNativeStackSize :: WordOff -maxTupleReturnNativeStackSize = 62 +maxTupleReturnNativeStackSize :: Platform -> WordOff +maxTupleReturnNativeStackSize platform = case platformWordSize platform of + PW4 -> 255 + PW8 -> 1099511627775 {- Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall @@ -997,9 +1002,10 @@ maxTupleReturnNativeStackSize = 62 See Note [GHCi and native call registers] for more information. -} -mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32 +mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word64 mkNativeCallInfoSig platform NativeCallInfo{..} - | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize + | nativeCallType == NativeTupleReturn + && nativeCallStackSpillSize > maxTupleReturnNativeStackSize platform = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler" (ppr nativeCallStackSpillSize <+> text "stack words." <+> text "Use -fobject-code to get around this limit" @@ -1008,8 +1014,9 @@ mkNativeCallInfoSig platform NativeCallInfo{..} = -- 24 bits for register bitmap assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs)) - -- 8 bits for continuation offset (only for NativeTupleReturn) - assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) + -- continuation offset must fit in available bits above the bitmap + assertPpr (cont_offset <= fromIntegral (maxTupleReturnNativeStackSize platform)) + (text "continuation offset too large:" <+> ppr cont_offset) -- all regs accounted for assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs)) @@ -1023,12 +1030,12 @@ mkNativeCallInfoSig platform NativeCallInfo{..} foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24) where - cont_offset :: Word32 + cont_offset :: Word64 cont_offset | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize | otherwise = 0 -- there is no continuation for primcalls - reg_bit :: Word32 -> (GlobalReg, Int) -> Word32 + reg_bit :: Word64 -> (GlobalReg, Int) -> Word64 reg_bit x (r, n) | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n | otherwise = x ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -488,11 +488,12 @@ bciStackUse PUSH_BCO{} = 1 bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + 3 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) = - -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) - -- tuple - -- (call_info, tuple_bco, stg_ret_t) + -- ctoi frame: small (4 words) or generic (5 words, with old_spill) + -- + tuple data + ret_t frame (3 words) 1 {- profiling only -} + - 7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco + ctoi_frame + 3 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco + where ctoi_frame | nativeCallStackSpillSize info <= mAX_SMALL_TUPLE_CTOI = 4 + | otherwise = 5 bciStackUse (PUSH_PAD8) = 1 -- overapproximation bciStackUse (PUSH_PAD16) = 1 -- overapproximation bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -6,6 +6,8 @@ -- (c) The University of Glasgow 2002-2006 -- +#include "Bytecodes.h" + -- | Bytecode assembler types module GHC.ByteCode.Types ( CompiledByteCode(..), seqCompiledByteCode @@ -13,6 +15,7 @@ module GHC.ByteCode.Types , FFIInfo(..) , RegBitmap(..) , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo + , mAX_SMALL_TUPLE_CTOI , ByteOff(..), WordOff(..), HalfWord(..) , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) , ItblEnv, ItblPtr(..) @@ -160,6 +163,12 @@ voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0 voidPrimCallInfo :: NativeCallInfo voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0 +-- | Maximum nativeCallStackSpillSize for which we use a small +-- stg_ctoi_tN frame (no old_spill slot, no TSO access) instead of +-- the generic stg_ctoi_t frame. +mAX_SMALL_TUPLE_CTOI :: WordOff +mAX_SMALL_TUPLE_CTOI = MAX_SMALL_TUPLE_CTOI + type ItblEnv = NameEnv (Name, ItblPtr) type AddrEnv = NameEnv (Name, AddrPtr) -- We need the Name in the range so we know which ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -1128,7 +1128,7 @@ doCase d s p scrut bndr alts -- 'Simple' tuples with at most one non-void component, -- like (# Word# #) or (# Int#, State# RealWorld #) do not have a -- tuple return frame. This is because (# foo #) and (# foo, Void# #) - -- have the same runtime rep. We have more efficient specialized + -- have the same runtime rep. We have more efficient small -- return frames for the situations with one non-void element. non_void_arg_reps = typeArgReps platform bndr_ty @@ -1146,10 +1146,19 @@ doCase d s p scrut bndr alts -- When an alt is entered, it assumes the returned value is -- on top of the itbl; see Note [Return convention for non-tuple values] -- for details. + -- Whether this tuple return uses a small stg_ctoi_tN frame + -- (no old_spill slot, no TSO access) instead of the generic + -- stg_ctoi_t frame. + small_tuple_frame :: Bool + small_tuple_frame = + ubx_tuple_frame && nativeCallStackSpillSize call_info <= mAX_SMALL_TUPLE_CTOI + ctoi_frame_header_w :: WordOff ctoi_frame_header_w - | ubx_tuple_frame = + | small_tuple_frame = if profiling then 5 else 4 + | ubx_tuple_frame = + if profiling then 6 else 5 | otherwise = 2 -- The size of the ret_*_info frame header, whose frame returns the @@ -1293,10 +1302,16 @@ doCase d s p scrut bndr alts -- case-of-case expressions, which is the only time we can be compiling a -- case expression with s /= 0. - -- unboxed tuples get two more words, the second is a pointer (tuple_bco) + -- unboxed tuples get extra words in the ctoi frame after the + -- info pointer and cont_BCO: + -- call_info, tuple_BCO, [old_spill], [CCCS] + -- tuple_BCO at position 1 is a pointer. + -- Small frames (stg_ctoi_tN) omit the old_spill slot. (extra_pointers, extra_slots) - | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS - | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO + | small_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS + | small_tuple_frame = ([1], 2) -- call_info, tuple_BCO + | ubx_tuple_frame && profiling = ([1], 4) -- call_info, tuple_BCO, old_spill, CCCS + | ubx_tuple_frame = ([1], 3) -- call_info, tuple_BCO, old_spill | otherwise = ([], 0) bitmap_size :: WordOff @@ -1535,14 +1550,12 @@ for the call and and a stack offset. The layout is as follows: list is active. Bit 1 for the second register in the list and so on. - - bit 24-31: Unsigned byte indicating the stack offset + - bit 24+: Unsigned value indicating the stack offset of the continuation in words. For tuple returns this is the number of words returned on the stack. For primcalls this field is unused, since we don't jump to a continuation. -The upper 32 bits on 64 bit platforms are currently unused. - If a register is smaller than a word on the stack (for example a single precision float on a 64 bit system), then the stack slot is padded to a whole word. @@ -1551,8 +1564,8 @@ is padded to a whole word. If a tuple is returned in three registers and an additional two words on the stack, then three bits in the register bitmap - (bits 0-23) would be set. And bit 24-31 would be - 00000010 (two in binary). + (bits 0-23) would be set. And the stack offset (bits 24+) would + encode the value two. The values on the stack before a call to POP_ARG_REGS would be as follows: @@ -1580,7 +1593,7 @@ is padded to a whole word. At this point all the arguments are in place and we are ready to jump to the continuation, the location (offset from Sp) of - which is found by inspecting the value of bits 24-31. In this + which is found by inspecting the value of bits 24+. In this case the offset is two words. On x86_64, the double precision (Dn) and single precision @@ -1734,9 +1747,11 @@ Note [unboxed tuple bytecodes and tuple_BCO] * tuple_BCO: see below The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE - instruction is executed, followed by stg_ctoi_tN_info, with N depending - on the number of stack words used by the tuple in the GHC native calling - convention. N is derived from call_info. + instruction is executed, followed by stg_ctoi_t_info. It also saves + the old ctoi_tuple_spill_words value from the TSO in the frame and sets + the TSO field to the number of stack words used by the tuple in the + GHC native calling convention. This spill count is derived from + call_info. For example if we expect a tuple with three words on the stack, the stack looks as follows after PUSH_ALTS_TUPLE: @@ -1747,12 +1762,13 @@ Note [unboxed tuple bytecodes and tuple_BCO] cont_free_var_2 ... cont_free_var_n + old_spill call_info tuple_BCO cont_BCO - stg_ctoi_t3_info <- Sp + stg_ctoi_t_info <- Sp - If the tuple is returned by object code, stg_ctoi_t3 will deal with + If the tuple is returned by object code, stg_ctoi_t will deal with adjusting the stack pointer and converting the tuple to the bytecode calling convention. See Note [GHCi unboxed tuples stack spills] for more details. ===================================== rts/Apply.cmm ===================================== @@ -719,6 +719,8 @@ for: goto for; } + ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", Words); + // Off we go! TICK_ENT_VIA_NODE(); @@ -776,6 +778,8 @@ for: goto for; } + ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", Words); + // Off we go! TICK_ENT_VIA_NODE(); ===================================== rts/Continuation.c ===================================== @@ -457,6 +457,11 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT } } + // see Note [GHCi unboxed tuples stack spills] + if (info_ptr == &stg_ctoi_t_info) { + tso->ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; + } + // Advance to the next frame. frame += stack_frame_sizeW((StgClosure *)frame); } ===================================== rts/ContinuationOps.cmm ===================================== @@ -200,6 +200,8 @@ stg_CONTINUATION_apply // explicit stack Sp_adj(-new_stack_words); prim %memcpy(Sp, p, WDS(new_stack_words), SIZEOF_W); + ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", new_stack_words); + TICK_UNKNOWN_CALL(); TICK_SLOW_CALL_fast_v(); ===================================== rts/Interpreter.c ===================================== @@ -572,72 +572,6 @@ void interp_shutdown( void ){ #endif -const StgPtr ctoi_tuple_infos[] = { - (StgPtr) &stg_ctoi_t0_info, - (StgPtr) &stg_ctoi_t1_info, - (StgPtr) &stg_ctoi_t2_info, - (StgPtr) &stg_ctoi_t3_info, - (StgPtr) &stg_ctoi_t4_info, - (StgPtr) &stg_ctoi_t5_info, - (StgPtr) &stg_ctoi_t6_info, - (StgPtr) &stg_ctoi_t7_info, - (StgPtr) &stg_ctoi_t8_info, - (StgPtr) &stg_ctoi_t9_info, - (StgPtr) &stg_ctoi_t10_info, - (StgPtr) &stg_ctoi_t11_info, - (StgPtr) &stg_ctoi_t12_info, - (StgPtr) &stg_ctoi_t13_info, - (StgPtr) &stg_ctoi_t14_info, - (StgPtr) &stg_ctoi_t15_info, - (StgPtr) &stg_ctoi_t16_info, - (StgPtr) &stg_ctoi_t17_info, - (StgPtr) &stg_ctoi_t18_info, - (StgPtr) &stg_ctoi_t19_info, - (StgPtr) &stg_ctoi_t20_info, - (StgPtr) &stg_ctoi_t21_info, - (StgPtr) &stg_ctoi_t22_info, - (StgPtr) &stg_ctoi_t23_info, - (StgPtr) &stg_ctoi_t24_info, - (StgPtr) &stg_ctoi_t25_info, - (StgPtr) &stg_ctoi_t26_info, - (StgPtr) &stg_ctoi_t27_info, - (StgPtr) &stg_ctoi_t28_info, - (StgPtr) &stg_ctoi_t29_info, - (StgPtr) &stg_ctoi_t30_info, - (StgPtr) &stg_ctoi_t31_info, - (StgPtr) &stg_ctoi_t32_info, - (StgPtr) &stg_ctoi_t33_info, - (StgPtr) &stg_ctoi_t34_info, - (StgPtr) &stg_ctoi_t35_info, - (StgPtr) &stg_ctoi_t36_info, - (StgPtr) &stg_ctoi_t37_info, - (StgPtr) &stg_ctoi_t38_info, - (StgPtr) &stg_ctoi_t39_info, - (StgPtr) &stg_ctoi_t40_info, - (StgPtr) &stg_ctoi_t41_info, - (StgPtr) &stg_ctoi_t42_info, - (StgPtr) &stg_ctoi_t43_info, - (StgPtr) &stg_ctoi_t44_info, - (StgPtr) &stg_ctoi_t45_info, - (StgPtr) &stg_ctoi_t46_info, - (StgPtr) &stg_ctoi_t47_info, - (StgPtr) &stg_ctoi_t48_info, - (StgPtr) &stg_ctoi_t49_info, - (StgPtr) &stg_ctoi_t50_info, - (StgPtr) &stg_ctoi_t51_info, - (StgPtr) &stg_ctoi_t52_info, - (StgPtr) &stg_ctoi_t53_info, - (StgPtr) &stg_ctoi_t54_info, - (StgPtr) &stg_ctoi_t55_info, - (StgPtr) &stg_ctoi_t56_info, - (StgPtr) &stg_ctoi_t57_info, - (StgPtr) &stg_ctoi_t58_info, - (StgPtr) &stg_ctoi_t59_info, - (StgPtr) &stg_ctoi_t60_info, - (StgPtr) &stg_ctoi_t61_info, - (StgPtr) &stg_ctoi_t62_info, -}; - #if defined(PROFILING) // @@ -710,7 +644,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ // How many words were on the stack stackWords = (StgWord *)frame - (StgWord *) Sp; - ASSERT(offset_words > stackWords); + ASSERT(offset_words >= stackWords); // Recursive, in the very unlikely case we have to traverse two // stack chunks. @@ -1317,10 +1251,12 @@ do_return_nonpointer: things on the stack. Therefore we store the CCCS inside the stg_ctoi_t frame. - If we have a tuple being returned, the stack looks like this: + If we have a tuple being returned, the stack looks like this + for the generic stg_ctoi_t frame: ... - <CCCS> <- to restore, Sp offset <next frame + 4 words> + <CCCS> <- to restore, Sp offset <next frame + 5 words> + old_spill tuple_BCO tuple_info cont_BCO @@ -1331,13 +1267,31 @@ do_return_nonpointer: tuple_info tuple_BCO stg_ret_t <- Sp + + Small frames (stg_ctoi_tN) omit the old_spill slot, + so CCCS is at offset <next frame + 4 words>. */ if(SpW(0) == (W_)&stg_ret_t_info) { - cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + 4); + StgWord cccs_offset = + (ReadSpW(offset) == (W_)&stg_ctoi_t_info) ? 5 : 4; + cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + cccs_offset); } #endif + /* When returning a tuple to a generic stg_ctoi_t frame + (as opposed to a small stg_ctoi_tN frame), restore + tso->ctoi_tuple_spill_words from the frame's old_spill + slot. + + See Note [GHCi unboxed tuples stack spills] in + StgMiscClosures.cmm. */ + if(SpW(0) == (W_)&stg_ret_t_info + && ReadSpW(offset) == (W_)&stg_ctoi_t_info) { + cap->r.rCurrentTSO->ctoi_tuple_spill_words = + ReadSpW(offset + CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET); + } + /* Keep the ret frame and the ctoi frame for run_BCO. * See Note [Stack layout when entering run_BCO] */ goto run_BCO; @@ -2332,22 +2286,47 @@ run_BCO: W_ o_bco = BCO_GET_LARGE_ARG; W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG); W_ o_tuple_bco = BCO_GET_LARGE_ARG; + int tuple_stack_words = tuple_info >> 24; #if defined(PROFILING) SpW(-1) = (W_)cap->r.rCCCS; Sp_subW(1); #endif - SpW(-1) = BCO_PTR(o_tuple_bco); - SpW(-2) = tuple_info; - SpW(-3) = BCO_PTR(o_bco); - int tuple_stack_words = (tuple_info >> 24) & 0xff; - if (tuple_stack_words > 62) { - barf("unsupported tuple size %d", tuple_stack_words); + /* See Note [GHCi unboxed tuples stack spills] in + StgMiscClosures.cmm */ + if (tuple_stack_words <= MAX_SMALL_TUPLE_CTOI) { + /* Use a small info table that encodes the spill + count statically, avoiding access to + TSO->ctoi_tuple_spill_words entirely. + The frame is one word smaller than stg_ctoi_t + (no old_spill slot). */ + static const StgInfoTable *const ctoi_t_small[] = { + &stg_ctoi_t0_info, &stg_ctoi_t1_info, + &stg_ctoi_t2_info, &stg_ctoi_t3_info, + &stg_ctoi_t4_info, &stg_ctoi_t5_info, + &stg_ctoi_t6_info, &stg_ctoi_t7_info, + &stg_ctoi_t8_info + }; + _Static_assert(sizeof(ctoi_t_small) / sizeof(ctoi_t_small[0]) + == MAX_SMALL_TUPLE_CTOI + 1, + "ctoi_t_small must have MAX_SMALL_TUPLE_CTOI + 1 entries"); + SpW(-1) = BCO_PTR(o_tuple_bco); + SpW(-2) = tuple_info; + SpW(-3) = BCO_PTR(o_bco); + SpW(-4) = (W_)ctoi_t_small[tuple_stack_words]; + Sp_subW(4); + } else { + /* Generic path: save/restore ctoi_tuple_spill_words + via the TSO */ + SpW(-1) = cap->r.rCurrentTSO->ctoi_tuple_spill_words; + SpW(-2) = BCO_PTR(o_tuple_bco); + SpW(-3) = tuple_info; + SpW(-4) = BCO_PTR(o_bco); + SpW(-5) = (W_)&stg_ctoi_t_info; + Sp_subW(5); + cap->r.rCurrentTSO->ctoi_tuple_spill_words = tuple_stack_words; } - W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words]; - SpW(-4) = ctoi_t_offset; - Sp_subW(4); NEXT_INSTRUCTION; } ===================================== rts/Printer.c ===================================== @@ -705,6 +705,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_apply_interp_info" ); } else if (c == (StgWord)&stg_ret_t_info) { debugBelch("stg_ret_t_info" ); + } else if (c == (StgWord)&stg_ctoi_t_info) { + debugBelch("stg_ctoi_t_info" ); } else if (c == (StgWord)&stg_ctoi_t0_info) { debugBelch("stg_ctoi_t0_info" ); } else if (c == (StgWord)&stg_ctoi_t1_info) { @@ -723,8 +725,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_ctoi_t7_info" ); } else if (c == (StgWord)&stg_ctoi_t8_info) { debugBelch("stg_ctoi_t8_info" ); - /* there are more stg_ctoi_tN_info frames, - but we don't print them all */ } else { debugBelch("RET_BCO"); } ===================================== rts/RaiseAsync.c ===================================== @@ -1074,6 +1074,11 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, tso->flags |= TSO_BLOCKEX; tso->flags &= ~TSO_INTERRUPTIBLE; } + // see Note [GHCi unboxed tuples stack spills] in + // StgMiscClosures.cmm + if (*frame == (W_)&stg_ctoi_t_info) { + tso->ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; + } break; } ===================================== rts/RtsSymbols.c ===================================== @@ -473,7 +473,16 @@ extern char **environ; SymI_HasDataProto(stg_ret_d_info) \ SymI_HasDataProto(stg_ret_l_info) \ SymI_HasDataProto(stg_ret_t_info) \ - SymI_HasDataProto(stg_ctoi_t) \ + SymI_HasDataProto(stg_ctoi_t_info) \ + SymI_HasDataProto(stg_ctoi_t0_info) \ + SymI_HasDataProto(stg_ctoi_t1_info) \ + SymI_HasDataProto(stg_ctoi_t2_info) \ + SymI_HasDataProto(stg_ctoi_t3_info) \ + SymI_HasDataProto(stg_ctoi_t4_info) \ + SymI_HasDataProto(stg_ctoi_t5_info) \ + SymI_HasDataProto(stg_ctoi_t6_info) \ + SymI_HasDataProto(stg_ctoi_t7_info) \ + SymI_HasDataProto(stg_ctoi_t8_info) \ SymI_HasDataProto(stg_primcall_info) \ SymI_HasDataProto(stg_gc_prim_p) \ SymI_HasDataProto(stg_gc_prim_pp) \ ===================================== rts/Schedule.c ===================================== @@ -3110,6 +3110,11 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) tso->flags |= TSO_BLOCKEX; tso->flags &= ~TSO_INTERRUPTIBLE; } + // see Note [GHCi unboxed tuples stack spills] in + // StgMiscClosures.cmm + if (*p == (StgWord)&stg_ctoi_t_info) { + tso->ctoi_tuple_spill_words = p[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; // restore old_spill + } p = next; continue; } ===================================== rts/StgMiscClosures.cmm ===================================== @@ -230,25 +230,22 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) spilled_2 spilled_3 <- Sp - This makes it difficult to write a procedure that can handle tuples of - any size. + stg_ctoi_t reads the number of spilled words from the + ctoi_tuple_spill_words field in the TSO to skip over the spilled data + on the stack. This field is set by the interpreter when pushing + the stg_ctoi_t frame (bci_PUSH_ALTS_T instruction). The old + value of the TSO field is saved in the frame itself, to handle + nested tuple returns correctly. - To get around this, we use a Cmm procedure that adjusts the stack pointer - to skip over the tuple: - - ... - stg_ctoi_t3 (advances Sp by 3 words, then calls stg_ctoi_t) - spilled_1 - spilled_2 - spilled_3 <- Sp - - When stg_ctoi_t is called, the stack looks like: + When stg_ctoi_t has adjusted Sp and read the frame, the stack + looks like: ... + old_spill tuple_BCO tuple_info cont_BCO (continuation in bytecode) - stg_ctoi_t3 <- Sp + stg_ctoi_t <- Sp spilled_1 spilled_2 spilled_3 @@ -258,10 +255,11 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) stack looks as follows: ... + old_spill tuple_BCO tuple_info cont_BCO - stg_ctoi_t3 + stg_ctoi_t spilled_1 spilled_2 spilled_3 @@ -279,108 +277,52 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) At this point we can safely jump to the interpreter. - */ + We maintain the following invariants around the spill info: -#define MK_STG_CTOI_T(N) INFO_TABLE_RET( \ - stg_ctoi_t ## N, RET_BCO ) \ - { Sp_adj(N); jump stg_ctoi_t SCALAR_ARG_REGS; } - -MK_STG_CTOI_T(0) -MK_STG_CTOI_T(1) -MK_STG_CTOI_T(2) -MK_STG_CTOI_T(3) -MK_STG_CTOI_T(4) -MK_STG_CTOI_T(5) -MK_STG_CTOI_T(6) -MK_STG_CTOI_T(7) -MK_STG_CTOI_T(8) -MK_STG_CTOI_T(9) - -MK_STG_CTOI_T(10) -MK_STG_CTOI_T(11) -MK_STG_CTOI_T(12) -MK_STG_CTOI_T(13) -MK_STG_CTOI_T(14) -MK_STG_CTOI_T(15) -MK_STG_CTOI_T(16) -MK_STG_CTOI_T(17) -MK_STG_CTOI_T(18) -MK_STG_CTOI_T(19) - -MK_STG_CTOI_T(20) -MK_STG_CTOI_T(21) -MK_STG_CTOI_T(22) -MK_STG_CTOI_T(23) -MK_STG_CTOI_T(24) -MK_STG_CTOI_T(25) -MK_STG_CTOI_T(26) -MK_STG_CTOI_T(27) -MK_STG_CTOI_T(28) -MK_STG_CTOI_T(29) - -MK_STG_CTOI_T(30) -MK_STG_CTOI_T(31) -MK_STG_CTOI_T(32) -MK_STG_CTOI_T(33) -MK_STG_CTOI_T(34) -MK_STG_CTOI_T(35) -MK_STG_CTOI_T(36) -MK_STG_CTOI_T(37) -MK_STG_CTOI_T(38) -MK_STG_CTOI_T(39) - -MK_STG_CTOI_T(40) -MK_STG_CTOI_T(41) -MK_STG_CTOI_T(42) -MK_STG_CTOI_T(43) -MK_STG_CTOI_T(44) -MK_STG_CTOI_T(45) -MK_STG_CTOI_T(46) -MK_STG_CTOI_T(47) -MK_STG_CTOI_T(48) -MK_STG_CTOI_T(49) - -MK_STG_CTOI_T(50) -MK_STG_CTOI_T(51) -MK_STG_CTOI_T(52) -MK_STG_CTOI_T(53) -MK_STG_CTOI_T(54) -MK_STG_CTOI_T(55) -MK_STG_CTOI_T(56) -MK_STG_CTOI_T(57) -MK_STG_CTOI_T(58) -MK_STG_CTOI_T(59) - -MK_STG_CTOI_T(60) -MK_STG_CTOI_T(61) -MK_STG_CTOI_T(62) + - tso->ctoi_tuple_spill_words == (frame[CTOI_TUPLE_INFO_OFFSET] >> 24) + where frame is the topmost stg_ctoi_t frame on the tso's stack. + - for each stg_ctoi_t frame, ctoi_t_frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET] + is equal to previous_ctoi_t_frame[CTOI_TUPLE_INFO_OFFSET] >> 24 + + This affects unwinding/capturing/restoring the stack for exceptions + and continuations. + */ /* Convert a tuple return value to be used in bytecode. See Note [GHCi and native call registers] for information on how values are moved between the stack and registers. + + See Note [GHCi unboxed tuples stack spills] for the stack layout. */ -stg_ctoi_t - /* explicit stack */ +INFO_TABLE_RET( stg_ctoi_t, RET_BCO ) { - - W_ tuple_info, tuple_stack; + W_ tuple_spill, tuple_info; P_ tuple_BCO; + W_ old_spill; + + /* read number of spilled stack words from the TSO */ + tuple_spill = StgTSO_ctoi_tuple_spill_words(CurrentTSO); + + /* skip over tuple data on the stack */ + Sp = Sp + WDS(tuple_spill); tuple_info = Sp(2); /* tuple information word */ tuple_BCO = Sp(3); /* bytecode object that returns the tuple in the interpreter */ + old_spill = Sp(4); /* saved ctoi_tuple_spill_words from TSO */ #if defined(PROFILING) - CCCS = Sp(4); + CCCS = Sp(5); #endif - /* number of words spilled on stack */ - tuple_stack = (tuple_info >> 24) & 0xff; + /* restore old spill count in the TSO */ + StgTSO_ctoi_tuple_spill_words(CurrentTSO) = old_spill; - Sp = Sp - WDS(tuple_stack); + /* move Sp back down to include spilled data */ + Sp = Sp - WDS(tuple_spill); PUSH_SCALAR_ARG_REGS(tuple_info); @@ -393,6 +335,59 @@ stg_ctoi_t jump stg_yield_to_interpreter []; } +/* + Small versions of stg_ctoi_t for small spill counts (0..MAX_SMALL_TUPLE_CTOI + words). + + These avoid accessing TSO->ctoi_tuple_spill_words entirely, since the + spill count is known statically from the info table. + + The frame layout is one word smaller than stg_ctoi_t, omitting + the old_spill slot: + + CCCS (profiling only) + tuple_BCO + tuple_info + cont_BCO + stg_ctoi_tN_info (N = spill count, words) + + Exception unwinding code and restoreStackInvariants only match + stg_ctoi_t_info, so these frames are correctly skipped. + + See Note [GHCi unboxed tuples stack spills] for the general design. + */ + +#if defined(PROFILING) +#define CTOI_TN_RESTORE_CCS CCCS = Sp(4); +#else +#define CTOI_TN_RESTORE_CCS +#endif + +#define STG_CTOI_TN_BODY(n) \ + W_ tuple_info; \ + P_ tuple_BCO; \ + Sp = Sp + WDS(n); \ + tuple_info = Sp(2); \ + tuple_BCO = Sp(3); \ + CTOI_TN_RESTORE_CCS \ + Sp = Sp - WDS(n); \ + PUSH_SCALAR_ARG_REGS(tuple_info); \ + Sp_adj(-3); \ + Sp(2) = tuple_info; \ + Sp(1) = tuple_BCO; \ + Sp(0) = stg_ret_t_info; \ + jump stg_yield_to_interpreter []; + +INFO_TABLE_RET( stg_ctoi_t0, RET_BCO ) { STG_CTOI_TN_BODY(0) } +INFO_TABLE_RET( stg_ctoi_t1, RET_BCO ) { STG_CTOI_TN_BODY(1) } +INFO_TABLE_RET( stg_ctoi_t2, RET_BCO ) { STG_CTOI_TN_BODY(2) } +INFO_TABLE_RET( stg_ctoi_t3, RET_BCO ) { STG_CTOI_TN_BODY(3) } +INFO_TABLE_RET( stg_ctoi_t4, RET_BCO ) { STG_CTOI_TN_BODY(4) } +INFO_TABLE_RET( stg_ctoi_t5, RET_BCO ) { STG_CTOI_TN_BODY(5) } +INFO_TABLE_RET( stg_ctoi_t6, RET_BCO ) { STG_CTOI_TN_BODY(6) } +INFO_TABLE_RET( stg_ctoi_t7, RET_BCO ) { STG_CTOI_TN_BODY(7) } +INFO_TABLE_RET( stg_ctoi_t8, RET_BCO ) { STG_CTOI_TN_BODY(8) } + INFO_TABLE_RET( stg_ret_t, RET_BCO ) { W_ tuple_info, tuple_stack; @@ -401,7 +396,7 @@ INFO_TABLE_RET( stg_ret_t, RET_BCO ) Sp_adj(3); /* number of words spilled on stack */ - tuple_stack = (tuple_info >> 24) & 0xff; + tuple_stack = tuple_info >> 24; POP_SCALAR_ARG_REGS(tuple_info); ===================================== rts/Threads.c ===================================== @@ -114,6 +114,8 @@ createThread(Capability *cap, W_ size) ASSIGN_Int64((W_*)&(tso->alloc_limit), 0); + tso->ctoi_tuple_spill_words = 0; + tso->trec = NO_TREC; tso->label = NULL; @@ -1053,3 +1055,38 @@ printThreadQueue(StgTSO *t) } #endif /* DEBUG */ + +/* + * restoreStackInvariants: restore stack invariants + * + * This should be called after restoring a captured stack from + * sp .. sp + words + */ +void +restoreStackInvariants(StgTSO *tso, StgPtr sp, StgWord words) +{ + StgPtr end = sp + words; + StgPtr frame = sp; + + /* + Restore ctoi_tuple_spill_words invariants after adding stack: + + - set the saved value in the last stg_ctoi_t frame to the current + tso->ctoi_tuple_spill_words + - set tso->ctoi_tuple_spill_words to the value in the first stg_ctoi_t frame + + See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm. + */ + StgPtr first_ctoi_frame = NULL, last_ctoi_frame = NULL; + while (frame < end) { + if (*(StgWord*)frame == (StgWord)&stg_ctoi_t_info) { + if(first_ctoi_frame == NULL) first_ctoi_frame = frame; + last_ctoi_frame = frame; + } + frame += stack_frame_sizeW((StgClosure *)frame); + } + if(last_ctoi_frame != NULL) { + last_ctoi_frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET] = tso->ctoi_tuple_spill_words; + tso->ctoi_tuple_spill_words = first_ctoi_frame[CTOI_TUPLE_INFO_OFFSET] >> 24; + } +} ===================================== rts/Threads.h ===================================== @@ -40,6 +40,10 @@ StgBool isThreadBound (StgTSO* tso); void threadStackOverflow (Capability *cap, StgTSO *tso); W_ threadStackUnderflow (Capability *cap, StgTSO *tso); +#define CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET 4 +#define CTOI_TUPLE_INFO_OFFSET 2 +void restoreStackInvariants(StgTSO *tso, StgPtr sp, StgWord words); + #if defined(DEBUG) void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); ===================================== rts/include/rts/Bytecodes.h ===================================== @@ -232,4 +232,10 @@ cases. */ #define INTERP_STACK_CHECK_THRESH 50 +/* Maximum nativeCallStackSpillSize for which we use a small stg_ctoi_tN + frame (no old_spill slot, no TSO access) instead of the generic + stg_ctoi_t frame. Must match the stg_ctoi_tN definitions in + StgMiscClosures.cmm. */ +#define MAX_SMALL_TUPLE_CTOI 8 + /*-------------------------------------------------------------------------*/ ===================================== rts/include/rts/storage/TSO.h ===================================== @@ -186,6 +186,15 @@ typedef struct StgTSO_ { */ StgWord32 tot_stack_size; + /* + * The number of stack words spilled by the current stg_ctoi_t + * frame. This is used by stg_ctoi_t to handle tuple returns from compiled + * to interpreted code. + * + * See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm + */ + StgWord ctoi_tuple_spill_words; + #if defined(TICKY_TICKY) /* TICKY-specific stuff would go here. */ #endif ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -96,7 +96,7 @@ RTS_RET(stg_ctoi_D1); RTS_RET(stg_ctoi_L1); RTS_RET(stg_ctoi_V); -RTS_FUN_DECL(stg_ctoi_t); +RTS_RET(stg_ctoi_t); RTS_RET(stg_ctoi_t0); RTS_RET(stg_ctoi_t1); RTS_RET(stg_ctoi_t2); @@ -106,66 +106,6 @@ RTS_RET(stg_ctoi_t5); RTS_RET(stg_ctoi_t6); RTS_RET(stg_ctoi_t7); RTS_RET(stg_ctoi_t8); -RTS_RET(stg_ctoi_t9); - -RTS_RET(stg_ctoi_t10); -RTS_RET(stg_ctoi_t11); -RTS_RET(stg_ctoi_t12); -RTS_RET(stg_ctoi_t13); -RTS_RET(stg_ctoi_t14); -RTS_RET(stg_ctoi_t15); -RTS_RET(stg_ctoi_t16); -RTS_RET(stg_ctoi_t17); -RTS_RET(stg_ctoi_t18); -RTS_RET(stg_ctoi_t19); - -RTS_RET(stg_ctoi_t20); -RTS_RET(stg_ctoi_t21); -RTS_RET(stg_ctoi_t22); -RTS_RET(stg_ctoi_t23); -RTS_RET(stg_ctoi_t24); -RTS_RET(stg_ctoi_t25); -RTS_RET(stg_ctoi_t26); -RTS_RET(stg_ctoi_t27); -RTS_RET(stg_ctoi_t28); -RTS_RET(stg_ctoi_t29); - -RTS_RET(stg_ctoi_t30); -RTS_RET(stg_ctoi_t31); -RTS_RET(stg_ctoi_t32); -RTS_RET(stg_ctoi_t33); -RTS_RET(stg_ctoi_t34); -RTS_RET(stg_ctoi_t35); -RTS_RET(stg_ctoi_t36); -RTS_RET(stg_ctoi_t37); -RTS_RET(stg_ctoi_t38); -RTS_RET(stg_ctoi_t39); - -RTS_RET(stg_ctoi_t40); -RTS_RET(stg_ctoi_t41); -RTS_RET(stg_ctoi_t42); -RTS_RET(stg_ctoi_t43); -RTS_RET(stg_ctoi_t44); -RTS_RET(stg_ctoi_t45); -RTS_RET(stg_ctoi_t46); -RTS_RET(stg_ctoi_t47); -RTS_RET(stg_ctoi_t48); -RTS_RET(stg_ctoi_t49); - -RTS_RET(stg_ctoi_t50); -RTS_RET(stg_ctoi_t51); -RTS_RET(stg_ctoi_t52); -RTS_RET(stg_ctoi_t53); -RTS_RET(stg_ctoi_t54); -RTS_RET(stg_ctoi_t55); -RTS_RET(stg_ctoi_t56); -RTS_RET(stg_ctoi_t57); -RTS_RET(stg_ctoi_t58); -RTS_RET(stg_ctoi_t59); - -RTS_RET(stg_ctoi_t60); -RTS_RET(stg_ctoi_t61); -RTS_RET(stg_ctoi_t62); RTS_RET(stg_primcall); RTS_RET(stg_apply_interp); ===================================== testsuite/tests/bytecode/tuplestress/ByteCode.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fbyte-code #-} + +module ByteCode where + +import GHC.Exts +import GHC.Word + +#include "Common.hs-incl" ===================================== testsuite/tests/bytecode/tuplestress/Common.hs-incl ===================================== @@ -0,0 +1,492 @@ +-- Stress test definitions for unboxed tuples in the bytecode interpreter. +-- +-- See Note [Unboxed tuple stress test] for an overview. + +-- Note [Unboxed tuple stress test] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- This test exercises the marshalling of unboxed tuples between +-- native code and the bytecode interpreter. It systematically tests +-- various tuple sizes around key boundaries (register capacity, +-- small frame limit), different element types (pointers, Int#, +-- Double#, Float#, Word64#, sub-word types), mixed type combinations, +-- and void components. +-- +-- For each tuple type, a NOINLINE producer and consumer are defined. +-- The main test calls each through all four combinations of +-- bytecode/native producer x bytecode/native consumer. +-- +-- Key boundaries on x86_64: +-- - 6 vanilla registers for pointers and non-pointer words +-- - 6 float/double registers +-- - small_tuple_frame: nativeCallStackSpillSize <= mAX_SMALL_TUPLE_CTOI +-- - generic stg_ctoi_t frame for larger spills + +-- ============================================================ +-- Pure pointer tuples +-- ============================================================ + +{-# NOINLINE p2 #-} +p2 :: a -> a -> (# a, a #) +p2 x1 x2 = (# x1, x2 #) + +{-# NOINLINE p2_a #-} +p2_a :: (a -> a -> (# a, a #)) -> a -> a -> (a, a) +p2_a f x1 x2 = case f x1 x2 of (# y1, y2 #) -> (y1, y2) + +{-# NOINLINE p7 #-} +p7 :: a -> a -> a -> a -> a -> a -> a + -> (# a, a, a, a, a, a, a #) +p7 x1 x2 x3 x4 x5 x6 x7 = + (# x1, x2, x3, x4, x5, x6, x7 #) + +{-# NOINLINE p7_a #-} +p7_a :: (a -> a -> a -> a -> a -> a -> a + -> (# a, a, a, a, a, a, a #)) + -> a -> a -> a -> a -> a -> a -> a + -> (a, a, a, a, a, a, a) +p7_a f x1 x2 x3 x4 x5 x6 x7 = + case f x1 x2 x3 x4 x5 x6 x7 of + (# y1, y2, y3, y4, y5, y6, y7 #) -> + (y1, y2, y3, y4, y5, y6, y7) + +-- ============================================================ +-- Pure Int# tuples +-- ============================================================ + +{-# NOINLINE n2 #-} +n2 :: Int -> Int -> (# Int#, Int# #) +n2 (I# x1) (I# x2) = (# x1, x2 #) + +{-# NOINLINE n2_a #-} +n2_a :: (Int -> Int -> (# Int#, Int# #)) -> Int -> Int -> (Int, Int) +n2_a f x1 x2 = case f x1 x2 of (# y1, y2 #) -> (I# y1, I# y2) + +{-# NOINLINE n7 #-} +n7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int# #) +n7 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) = + (# x1, x2, x3, x4, x5, x6, x7 #) + +{-# NOINLINE n7_a #-} +n7_a :: (Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int# #)) + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (Int, Int, Int, Int, Int, Int, Int) +n7_a f x1 x2 x3 x4 x5 x6 x7 = + case f x1 x2 x3 x4 x5 x6 x7 of + (# y1, y2, y3, y4, y5, y6, y7 #) -> + (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7) + +type TN15 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int# #) + +{-# NOINLINE n15 #-} +n15 :: TN15 +n15 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) (I# x8) + (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) (I# x15) = + (# x1, x2, x3, x4, x5, x6, x7, x8 + , x9, x10, x11, x12, x13, x14, x15 #) + +{-# NOINLINE n15_a #-} +n15_a :: TN15 + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> ((Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int)) +n15_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 = + case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 of + (# y1, y2, y3, y4, y5, y6, y7, y8 + , y9, y10, y11, y12, y13, y14, y15 #) -> + ( (I# y1, I# y2, I# y3, I# y4, I# y5) + , (I# y6, I# y7, I# y8, I# y9, I# y10) + , (I# y11, I# y12, I# y13, I# y14, I# y15) ) + +-- ============================================================ +-- Pure Double# tuples +-- ============================================================ + +{-# NOINLINE d7 #-} +d7 :: Double -> Double -> Double -> Double + -> Double -> Double -> Double + -> (# Double#, Double#, Double#, Double# + , Double#, Double#, Double# #) +d7 (D# x1) (D# x2) (D# x3) (D# x4) (D# x5) (D# x6) (D# x7) = + (# x1, x2, x3, x4, x5, x6, x7 #) + +{-# NOINLINE d7_a #-} +d7_a :: (Double -> Double -> Double -> Double + -> Double -> Double -> Double + -> (# Double#, Double#, Double#, Double# + , Double#, Double#, Double# #)) + -> Double -> Double -> Double -> Double + -> Double -> Double -> Double + -> (Double, Double, Double, Double, Double, Double, Double) +d7_a f x1 x2 x3 x4 x5 x6 x7 = + case f x1 x2 x3 x4 x5 x6 x7 of + (# y1, y2, y3, y4, y5, y6, y7 #) -> + (D# y1, D# y2, D# y3, D# y4, D# y5, D# y6, D# y7) + +-- ============================================================ +-- Pure Float# tuples +-- ============================================================ + +{-# NOINLINE fl7 #-} +fl7 :: Float -> Float -> Float -> Float + -> Float -> Float -> Float + -> (# Float#, Float#, Float#, Float# + , Float#, Float#, Float# #) +fl7 (F# x1) (F# x2) (F# x3) (F# x4) (F# x5) (F# x6) (F# x7) = + (# x1, x2, x3, x4, x5, x6, x7 #) + +{-# NOINLINE fl7_a #-} +fl7_a :: (Float -> Float -> Float -> Float + -> Float -> Float -> Float + -> (# Float#, Float#, Float#, Float# + , Float#, Float#, Float# #)) + -> Float -> Float -> Float -> Float + -> Float -> Float -> Float + -> (Float, Float, Float, Float, Float, Float, Float) +fl7_a f x1 x2 x3 x4 x5 x6 x7 = + case f x1 x2 x3 x4 x5 x6 x7 of + (# y1, y2, y3, y4, y5, y6, y7 #) -> + (F# y1, F# y2, F# y3, F# y4, F# y5, F# y6, F# y7) + +-- ============================================================ +-- Pure Word64# tuples +-- ============================================================ + +{-# NOINLINE w7 #-} +w7 :: Word64 -> Word64 -> Word64 -> Word64 + -> Word64 -> Word64 -> Word64 + -> (# Word64#, Word64#, Word64#, Word64# + , Word64#, Word64#, Word64# #) +w7 (W64# x1) (W64# x2) (W64# x3) (W64# x4) + (W64# x5) (W64# x6) (W64# x7) = + (# x1, x2, x3, x4, x5, x6, x7 #) + +{-# NOINLINE w7_a #-} +w7_a :: (Word64 -> Word64 -> Word64 -> Word64 + -> Word64 -> Word64 -> Word64 + -> (# Word64#, Word64#, Word64#, Word64# + , Word64#, Word64#, Word64# #)) + -> Word64 -> Word64 -> Word64 -> Word64 + -> Word64 -> Word64 -> Word64 + -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64) +w7_a f x1 x2 x3 x4 x5 x6 x7 = + case f x1 x2 x3 x4 x5 x6 x7 of + (# y1, y2, y3, y4, y5, y6, y7 #) -> + (W64# y1, W64# y2, W64# y3, W64# y4, + W64# y5, W64# y6, W64# y7) + +-- ============================================================ +-- Mixed pointer + Int# tuples (interleaved) +-- ============================================================ + +-- 6 elements: 3 pointers + 3 Int# +{-# NOINLINE mpi6 #-} +mpi6 :: Int -> Int -> Int -> Int -> Int -> Int + -> (# Int, Int#, Int, Int#, Int, Int# #) +mpi6 x1 (I# x2) x3 (I# x4) x5 (I# x6) = + (# x1, x2, x3, x4, x5, x6 #) + +{-# NOINLINE mpi6_a #-} +mpi6_a :: (Int -> Int -> Int -> Int -> Int -> Int + -> (# Int, Int#, Int, Int#, Int, Int# #)) + -> Int -> Int -> Int -> Int -> Int -> Int + -> (Int, Int, Int, Int, Int, Int) +mpi6_a f x1 x2 x3 x4 x5 x6 = + case f x1 x2 x3 x4 x5 x6 of + (# y1, y2, y3, y4, y5, y6 #) -> + (y1, I# y2, y3, I# y4, y5, I# y6) + +-- ============================================================ +-- Mixed pointer + Double# tuples (interleaved) +-- ============================================================ + +-- 6 elements: 3 pointers + 3 Double# +{-# NOINLINE mpd6 #-} +mpd6 :: Int -> Double -> Int -> Double -> Int -> Double + -> (# Int, Double#, Int, Double#, Int, Double# #) +mpd6 x1 (D# x2) x3 (D# x4) x5 (D# x6) = + (# x1, x2, x3, x4, x5, x6 #) + +{-# NOINLINE mpd6_a #-} +mpd6_a :: (Int -> Double -> Int -> Double -> Int -> Double + -> (# Int, Double#, Int, Double#, Int, Double# #)) + -> Int -> Double -> Int -> Double -> Int -> Double + -> (Int, Double, Int, Double, Int, Double) +mpd6_a f x1 x2 x3 x4 x5 x6 = + case f x1 x2 x3 x4 x5 x6 of + (# y1, y2, y3, y4, y5, y6 #) -> + (y1, D# y2, y3, D# y4, y5, D# y6) + +-- ============================================================ +-- Mixed all types: pointer + Int# + Double# + Float# +-- ============================================================ + +-- 8 elements: 2 of each type, interleaved +{-# NOINLINE mall8 #-} +mall8 :: Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float + -> (# Int, Int#, Double#, Float#, Int, Int#, Double#, Float# #) +mall8 x1 (I# x2) (D# x3) (F# x4) x5 (I# x6) (D# x7) (F# x8) = + (# x1, x2, x3, x4, x5, x6, x7, x8 #) + +{-# NOINLINE mall8_a #-} +mall8_a :: (Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float + -> (# Int, Int#, Double#, Float#, Int, Int#, Double#, Float# #)) + -> Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float + -> (Int, Int, Double, Float, Int, Int, Double, Float) +mall8_a f x1 x2 x3 x4 x5 x6 x7 x8 = + case f x1 x2 x3 x4 x5 x6 x7 x8 of + (# y1, y2, y3, y4, y5, y6, y7, y8 #) -> + (y1, I# y2, D# y3, F# y4, y5, I# y6, D# y7, F# y8) + +-- ============================================================ +-- Sub-word types: Word8#, Word16#, Word32# +-- ============================================================ + +{-# NOINLINE sub5 #-} +sub5 :: Word8 -> Word16 -> Word32 -> Int -> Int + -> (# Word8#, Word16#, Word32#, Int#, Int #) +sub5 (W8# x1) (W16# x2) (W32# x3) (I# x4) x5 = + (# x1, x2, x3, x4, x5 #) + +{-# NOINLINE sub5_a #-} +sub5_a :: (Word8 -> Word16 -> Word32 -> Int -> Int + -> (# Word8#, Word16#, Word32#, Int#, Int #)) + -> Word8 -> Word16 -> Word32 -> Int -> Int + -> (Word8, Word16, Word32, Int, Int) +sub5_a f x1 x2 x3 x4 x5 = + case f x1 x2 x3 x4 x5 of + (# y1, y2, y3, y4, y5 #) -> + (W8# y1, W16# y2, W32# y3, I# y4, y5) + +-- ============================================================ +-- Void components: (# #) interleaved with real values +-- ============================================================ + +{-# NOINLINE vd6 #-} +vd6 :: Int -> Int -> Int + -> (# Int, (# #), Int, (# #), Int#, (# #) #) +vd6 x1 x2 (I# x3) = (# x1, (# #), x2, (# #), x3, (# #) #) + +{-# NOINLINE vd6_a #-} +vd6_a :: (Int -> Int -> Int + -> (# Int, (# #), Int, (# #), Int#, (# #) #)) + -> Int -> Int -> Int + -> (Int, Int, Int) +vd6_a f x1 x2 x3 = + case f x1 x2 x3 of + (# y1, _, y3, _, y5, _ #) -> (y1, y3, I# y5) + +-- ============================================================ +-- Recursive step functions +-- ============================================================ + +-- 4-element mixed step: each element incremented by a different amount +-- ptr: +1, Int#: +2, Double#: +0.5, Double#: +1.5 +{-# NOINLINE rec_step4 #-} +rec_step4 :: Int -> Int -> Double -> Double + -> (# Int, Int#, Double#, Double# #) +rec_step4 x1 (I# x2) (D# x3) (D# x4) = + (# x1 + 1, x2 +# 2#, x3 +## 0.5##, x4 +## 1.5## #) + +{-# NOINLINE rec_step4_a #-} +rec_step4_a :: (Int -> Int -> Double -> Double + -> (# Int, Int#, Double#, Double# #)) + -> Int -> Int -> Double -> Double + -> (Int, Int, Double, Double) +rec_step4_a f x1 x2 x3 x4 = + case f x1 x2 x3 x4 of + (# y1, y2, y3, y4 #) -> (y1, I# y2, D# y3, D# y4) + +-- ============================================================ +-- Large tuples: boundary and stress sizes +-- ============================================================ + +-- 14 Int#: exactly stg_ctoi_t8 (last small frame, spill = 8 words on x86_64) +type TN14 = Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int# #) + +{-# NOINLINE n14 #-} +n14 :: TN14 +n14 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) + (I# x8) (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) = + (# x1, x2, x3, x4, x5, x6, x7 + , x8, x9, x10, x11, x12, x13, x14 #) + +{-# NOINLINE n14_a #-} +n14_a :: TN14 + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> ((Int,Int,Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int,Int,Int)) +n14_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 = + case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 of + (# y1, y2, y3, y4, y5, y6, y7 + , y8, y9, y10, y11, y12, y13, y14 #) -> + ( (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7) + , (I# y8, I# y9, I# y10, I# y11, I# y12, I# y13, I# y14) ) + +-- 20 Int#: generic frame, large spill, all non-pointer +type TN20 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) + +{-# NOINLINE n20 #-} +n20 :: TN20 +n20 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) + (I# x6) (I# x7) (I# x8) (I# x9) (I# x10) + (I# x11) (I# x12) (I# x13) (I# x14) (I# x15) + (I# x16) (I# x17) (I# x18) (I# x19) (I# x20) = + (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10 + , x11, x12, x13, x14, x15, x16, x17, x18, x19, x20 #) + +{-# NOINLINE n20_a #-} +n20_a :: TN20 + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> ((Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int) + ,(Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int)) +n20_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 + x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 = + case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 + x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 of + (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10 + , y11, y12, y13, y14, y15, y16, y17, y18, y19, y20 #) -> + ( (I# y1, I# y2, I# y3, I# y4, I# y5) + , (I# y6, I# y7, I# y8, I# y9, I# y10) + , (I# y11, I# y12, I# y13, I# y14, I# y15) + , (I# y16, I# y17, I# y18, I# y19, I# y20) ) + +-- 32 Int#: very large generic frame, spill = 26 words +type TN32 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# + , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #) + +{-# NOINLINE n32 #-} +n32 :: TN32 +n32 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) (I# x8) + (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) (I# x15) (I# x16) + (I# x17) (I# x18) (I# x19) (I# x20) (I# x21) (I# x22) (I# x23) (I# x24) + (I# x25) (I# x26) (I# x27) (I# x28) (I# x29) (I# x30) (I# x31) (I# x32) = + (# x1, x2, x3, x4, x5, x6, x7, x8 + , x9, x10, x11, x12, x13, x14, x15, x16 + , x17, x18, x19, x20, x21, x22, x23, x24 + , x25, x26, x27, x28, x29, x30, x31, x32 #) + +{-# NOINLINE n32_a #-} +n32_a :: TN32 + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> ((Int,Int,Int,Int,Int,Int,Int,Int) + ,(Int,Int,Int,Int,Int,Int,Int,Int) + ,(Int,Int,Int,Int,Int,Int,Int,Int) + ,(Int,Int,Int,Int,Int,Int,Int,Int)) +n32_a f x1 x2 x3 x4 x5 x6 x7 x8 + x9 x10 x11 x12 x13 x14 x15 x16 + x17 x18 x19 x20 x21 x22 x23 x24 + x25 x26 x27 x28 x29 x30 x31 x32 = + case f x1 x2 x3 x4 x5 x6 x7 x8 + x9 x10 x11 x12 x13 x14 x15 x16 + x17 x18 x19 x20 x21 x22 x23 x24 + x25 x26 x27 x28 x29 x30 x31 x32 of + (# y1, y2, y3, y4, y5, y6, y7, y8 + , y9, y10, y11, y12, y13, y14, y15, y16 + , y17, y18, y19, y20, y21, y22, y23, y24 + , y25, y26, y27, y28, y29, y30, y31, y32 #) -> + ( (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7, I# y8) + , (I# y9, I# y10, I# y11, I# y12, I# y13, I# y14, I# y15, I# y16) + , (I# y17, I# y18, I# y19, I# y20, I# y21, I# y22, I# y23, I# y24) + , (I# y25, I# y26, I# y27, I# y28, I# y29, I# y30, I# y31, I# y32) ) + +-- 32 mixed: 8 groups of (Int, Int#, Double#, Float#), all register classes +-- spill = 14 words (10 vanilla + 2 double + 2 float) +type TMIX32 = Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> (# Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# + , Int, Int#, Double#, Float# #) + +{-# NOINLINE mix32 #-} +mix32 :: TMIX32 +mix32 x1 (I# x2) (D# x3) (F# x4) + x5 (I# x6) (D# x7) (F# x8) + x9 (I# x10) (D# x11) (F# x12) + x13 (I# x14) (D# x15) (F# x16) + x17 (I# x18) (D# x19) (F# x20) + x21 (I# x22) (D# x23) (F# x24) + x25 (I# x26) (D# x27) (F# x28) + x29 (I# x30) (D# x31) (F# x32) = + (# x1, x2, x3, x4 + , x5, x6, x7, x8 + , x9, x10, x11, x12 + , x13, x14, x15, x16 + , x17, x18, x19, x20 + , x21, x22, x23, x24 + , x25, x26, x27, x28 + , x29, x30, x31, x32 #) + +{-# NOINLINE mix32_a #-} +mix32_a :: TMIX32 + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> Int -> Int -> Double -> Float + -> ((Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float) + ,(Int,Int,Double,Float)) +mix32_a f x1 x2 x3 x4 x5 x6 x7 x8 + x9 x10 x11 x12 x13 x14 x15 x16 + x17 x18 x19 x20 x21 x22 x23 x24 + x25 x26 x27 x28 x29 x30 x31 x32 = + case f x1 x2 x3 x4 x5 x6 x7 x8 + x9 x10 x11 x12 x13 x14 x15 x16 + x17 x18 x19 x20 x21 x22 x23 x24 + x25 x26 x27 x28 x29 x30 x31 x32 of + (# y1, y2, y3, y4 + , y5, y6, y7, y8 + , y9, y10, y11, y12 + , y13, y14, y15, y16 + , y17, y18, y19, y20 + , y21, y22, y23, y24 + , y25, y26, y27, y28 + , y29, y30, y31, y32 #) -> + ( (y1, I# y2, D# y3, F# y4) + , (y5, I# y6, D# y7, F# y8) + , (y9, I# y10, D# y11, F# y12) + , (y13, I# y14, D# y15, F# y16) + , (y17, I# y18, D# y19, F# y20) + , (y21, I# y22, D# y23, F# y24) + , (y25, I# y26, D# y27, F# y28) + , (y29, I# y30, D# y31, F# y32) ) ===================================== testsuite/tests/bytecode/tuplestress/Obj.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fobject-code #-} + +#include "MachDeps.h" + +module Obj where + +import GHC.Exts +import GHC.Word + +#include "Common.hs-incl" ===================================== testsuite/tests/bytecode/tuplestress/TupleStress.hs ===================================== @@ -0,0 +1,631 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fbyte-code #-} + +{- + Stress test for unboxed tuples in the bytecode interpreter. + + Tests various sized tuples with different element types, + focusing on converting tuples between native code and + interpreted code in all four combinations: + ByteCode producer x ByteCode consumer + ByteCode producer x Object consumer + Object producer x ByteCode consumer + Object producer x Object consumer + + See Note [Unboxed tuple stress test] in Common.hs-incl. + -} + +module Main where + +import qualified Obj as O +import qualified ByteCode as B + +import GHC.Exts +import GHC.Word +import Control.Exception (try, evaluate, catch, SomeException) +import Control.Concurrent +import System.IO.Unsafe (unsafePerformIO) + +main :: IO () +main = do + + -- ======================================================== + -- Pure tuple tests: all 4 combinations (BB/BO/OB/OO) + -- ======================================================== + + testX "p7" + B.p7_a O.p7_a + B.p7 O.p7 + (\f -> f (1::Int) 2 3 4 5 6 7) + + testX "n2" + B.n2_a O.n2_a + B.n2 O.n2 + (\f -> f 1 2) + + testX "n7" + B.n7_a O.n7_a + B.n7 O.n7 + (\f -> f 1 2 3 4 5 6 7) + + testX "n15" + B.n15_a O.n15_a + B.n15 O.n15 + (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + + testX "d7" + B.d7_a O.d7_a + B.d7 O.d7 + (\f -> f 1.5 2.5 3.5 4.5 5.5 6.5 7.5) + + testX "fl7" + B.fl7_a O.fl7_a + B.fl7 O.fl7 + (\f -> f 1.25 2.25 3.25 4.25 5.25 6.25 7.25) + + testX "w7" + B.w7_a O.w7_a + B.w7 O.w7 + (\f -> f 100 200 300 400 500 600 700) + + testX "mpi6" + B.mpi6_a O.mpi6_a + B.mpi6 O.mpi6 + (\f -> f 1 2 3 4 5 6) + + testX "mpd6" + B.mpd6_a O.mpd6_a + B.mpd6 O.mpd6 + (\f -> f 1 1.5 2 2.5 3 3.5) + + testX "mall8" + B.mall8_a O.mall8_a + B.mall8 O.mall8 + (\f -> f 1 2 3.0 4.0 5 6 7.0 8.0) + + testX "sub5" + B.sub5_a O.sub5_a + B.sub5 O.sub5 + (\f -> f 42 1000 70000 99 100) + + testX "vd6" + B.vd6_a O.vd6_a + B.vd6 O.vd6 + (\f -> f 11 22 33) + + -- 14 Int#: exactly at stg_ctoi_t8 boundary (last small frame) + testX "n14" + B.n14_a O.n14_a + B.n14 O.n14 + (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14) + + -- 20 Int#: generic frame, all non-pointer + testX "n20" + B.n20_a O.n20_a + B.n20 O.n20 + (\f -> f 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20) + + -- 32 Int#: very large generic frame (spill = 26 words) + testX "n32" + B.n32_a O.n32_a + B.n32 O.n32 + (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32) + + -- 32 mixed (ptr+Int#+Double#+Float#): all register classes (spill = 14) + testX "mix32" + B.mix32_a O.mix32_a + B.mix32 O.mix32 + (\f -> f 1 2 3.0 4.0 5 6 7.0 8.0 9 10 11.0 12.0 + 13 14 15.0 16.0 17 18 19.0 20.0 21 22 23.0 24.0 + 25 26 27.0 28.0 29 30 31.0 32.0) + + -- ======================================================== + -- Loop tests: repeated calls to detect state corruption + -- ======================================================== + + -- Pointer 7-tuple loop, alternating B->O and O->B directions + let loop_p7_ok = and + [ (if even i then O.p7_a B.p7 else B.p7_a O.p7) + i (i+1) (i+2) (i+3) (i+4) (i+5) (i+6) + == (i, i+1, i+2, i+3, i+4, i+5, i+6) + | i <- [0 :: Int, 7 .. 700] + ] + putStrLn $ "loop_p7 " ++ show loop_p7_ok + + -- Mixed ptr+Double# loop + let loop_mpd_ok = and + [ O.mpd6_a B.mpd6 i (fromIntegral i + 0.5) + (i+1) (fromIntegral (i+1) + 0.5) + (i+2) (fromIntegral (i+2) + 0.5) + == ( i, fromIntegral i + 0.5 + , i+1, fromIntegral (i+1) + 0.5 + , i+2, fromIntegral (i+2) + 0.5 ) + | i <- [0 :: Int, 3 .. 300] + ] + putStrLn $ "loop_mpd " ++ show loop_mpd_ok + + -- 32-element Int# loop: exercises very large generic frame + let loop_n32_ok = and + [ B.n32_a O.n32 + i (i+1) (i+2) (i+3) (i+4) (i+5) (i+6) (i+7) + (i+8) (i+9) (i+10) (i+11) (i+12) (i+13) (i+14) (i+15) + (i+16) (i+17) (i+18) (i+19) (i+20) (i+21) (i+22) (i+23) + (i+24) (i+25) (i+26) (i+27) (i+28) (i+29) (i+30) (i+31) + == ( (i,i+1,i+2,i+3,i+4,i+5,i+6,i+7) + , (i+8,i+9,i+10,i+11,i+12,i+13,i+14,i+15) + , (i+16,i+17,i+18,i+19,i+20,i+21,i+22,i+23) + , (i+24,i+25,i+26,i+27,i+28,i+29,i+30,i+31) ) + | i <- [0 :: Int, 32 .. 3200] + ] + putStrLn $ "loop_n32 " ++ show loop_n32_ok + + -- ======================================================== + -- Chain tests: output of one call feeds into the next + -- ======================================================== + + -- 7-tuple chain with arithmetic + let (c1,c2,c3,c4,c5,c6,c7) = O.p7_a B.p7 (10::Int) 20 30 40 50 60 70 + putStrLn $ "chain_arith " ++ show + (B.p7_a O.p7 (c1+c7) (c2+c6) (c3+c5) c4 (c5+c3) (c6+c2) (c7+c1)) + + -- 100 alternating swaps across bytecode/native boundary + putStrLn $ "swap_stress " ++ show (swapStress (100 :: Int) (1 :: Int, 2)) + + -- ======================================================== + -- Recursive tuple tests + -- ======================================================== + + -- 4-element mixed accumulation: 50 steps alternating B/O + -- rec_step4 (x1,x2,x3,x4) = (x1+1, x2+2, x3+0.5, x4+1.5) + -- After 50 steps from (0,0,0,0): (50, 100, 25.0, 75.0) + let recMixed x1 x2 x3 x4 0 = (x1, x2, x3, x4) + recMixed x1 x2 x3 x4 n + | even n = let (a,b,c,d) = B.rec_step4_a O.rec_step4 x1 x2 x3 x4 + in recMixed a b c d (n-1) + | otherwise = let (a,b,c,d) = O.rec_step4_a B.rec_step4 x1 x2 x3 x4 + in recMixed a b c d (n-1) + putStrLn $ "rec_mixed " ++ show + (recMixed (0::Int) (0::Int) (0.0::Double) (0.0::Double) (50::Int)) + + -- Fibonacci via 2-tuples, 30 levels crossing boundaries at each level + let fibCross 0 = B.n2_a O.n2 0 1 + fibCross 1 = O.n2_a B.n2 1 0 + fibCross n = + let (a, b) = fibCross (n-1) + in if even n + then B.n2_a O.n2 (a+b) a + else O.n2_a B.n2 (a+b) a + putStrLn $ "fib_cross " ++ show (fst (fibCross (30::Int))) + + -- ======================================================== + -- Exception tests: verify stack state is restored + -- ======================================================== + + -- Exception in 7-element Int# tuple (small frame), B->O + do r <- tryEval (B.n7_a O.n7 (error "exc") 2 3 4 5 6 7) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.n7_a O.n7 1 2 3 4 5 6 7 == (1,2,3,4,5,6,7) + putStrLn $ "exc_n7_bo " ++ show (threw && ok) + + -- Exception in 15-element Int# tuple (generic frame), B->O + do r <- tryEval (B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.n15_a O.n15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + == ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15)) + putStrLn $ "exc_n15_bo " ++ show (threw && ok) + + -- Exception in mixed ptr+Double# tuple, B->O + do r <- tryEval (B.mpd6_a O.mpd6 1 (error "exc") 2 2.5 3 3.5) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.mpd6_a O.mpd6 1 1.5 2 2.5 3 3.5 == (1,1.5,2,2.5,3,3.5) + putStrLn $ "exc_mpd_bo " ++ show (threw && ok) + + -- Repeated exceptions: throw 50 times, then verify recovery + do let throwOnce = tryEval (B.n7_a O.n7 (error "exc") 2 3 4 5 6 7) + results <- sequence [throwOnce | _ <- [1..50::Int]] + let allThrew = all (\r -> case r of { Left _ -> True; Right _ -> False }) + results + let final = O.n7_a B.n7 10 20 30 40 50 60 70 + putStrLn $ "exc_repeat " ++ show (allThrew && final == (10,20,30,40,50,60,70)) + + -- Exception at stg_ctoi_t8 boundary (14 Int#, last small frame) + do r <- tryEval (B.n14_a O.n14 (error "exc") 2 3 4 5 6 7 + 8 9 10 11 12 13 14) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.n14_a O.n14 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + == ((1,2,3,4,5,6,7),(8,9,10,11,12,13,14)) + putStrLn $ "exc_n14_bo " ++ show (threw && ok) + + -- Exception with 32-element Int# tuple (very large generic frame) + do r <- tryEval (B.n32_a O.n32 (error "exc") 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.n32_a O.n32 1 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32 + == ((1,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16), + (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32)) + putStrLn $ "exc_n32_bo " ++ show (threw && ok) + + -- ======================================================== + -- Nested generic ctoi exception tests + -- ======================================================== + -- Tests that exception unwinding correctly restores + -- ctoi_tuple_spill_words when passing through multiple + -- stg_ctoi_t frames. + -- See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm. + + -- Exception through 2 nested generic ctoi frames (n15 inside n20). + do let l1 = case B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 + of ((a,_,_,_,_),_,_) -> a + r <- tryEval (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20) + let threw = case r of { Left _ -> True; Right _ -> False } + let ok = B.n20_a O.n20 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + == ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20)) + putStrLn $ "exc_nested_2gen " ++ show (threw && ok) + + -- Exception caught between 2 generic ctoi frames. + -- A catch handler sits between ctoi(n20,spill=14) and ctoi(n15,spill=9). + -- The error in O.n15 unwinds through ctoi(n15), which must restore + -- ctoi_tuple_spill_words to the outer frame's spill count before + -- hitting the catch. If the restore is missing, ctoi(n20) reads the + -- wrong number of spill words and corrupts the stack. + do let inner_result :: Int + inner_result = unsafePerformIO $ + catch (evaluate (case B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 + of ((a,_,_,_,_),_,_) -> a)) + (const (return 99) :: SomeException -> IO Int) + result <- evaluate (B.n20_a O.n20 inner_result 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20) + putStrLn $ "exc_catch_between " ++ show + (result == ((99,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20))) + + -- ======================================================== + -- Async exception / AP_STACK replay tests + -- ======================================================== + + apStackTest "async_n7" (42 :: Int) + (\b -> B.n7_a O.n7 b 2 3 4 5 6 7) + (42,2,3,4,5,6,7) + + -- AP_STACK replayed in a third thread (not the killer, not the killed) + do entered <- newEmptyMVar + gate <- newEmptyMVar + resultVar <- newEmptyMVar + let thunk = B.n7_a O.n7 + (unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate) + 2 3 4 5 6 7 + tid <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate 42 + _ <- forkIO $ do + result <- evaluate thunk + putMVar resultVar result + result <- takeMVar resultVar + putStrLn $ "async_other " ++ show (result == (42,2,3,4,5,6,7)) + + -- AP_STACK at stg_ctoi_t8 boundary (14 Int#, last small frame) + apStackTest "async_n14" (42 :: Int) + (\b -> B.n14_a O.n14 b 2 3 4 5 6 7 8 9 10 11 12 13 14) + ((42,2,3,4,5,6,7),(8,9,10,11,12,13,14)) + + -- Nested async: interrupt the AP_STACK replay itself. + -- Round 1: blocks on arg1; Round 2: blocks on arg2; Round 3: completes + do entered1 <- newEmptyMVar + entered2 <- newEmptyMVar + gate1 <- newEmptyMVar + gate2 <- newEmptyMVar + let thunk = B.n7_a O.n7 + (unsafePerformIO $ do + _ <- tryPutMVar entered1 () + takeMVar gate1) + (unsafePerformIO $ do + _ <- tryPutMVar entered2 () + takeMVar gate2) + 3 4 5 6 7 + tid1 <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered1 + killThread tid1 + threadDelay 10000 + putMVar gate1 100 + tid2 <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered2 + killThread tid2 + threadDelay 10000 + putMVar gate2 200 + result <- evaluate thunk + putStrLn $ "async_nested " ++ show (result == (100,200,3,4,5,6,7)) + + -- Async + sync exception combo: async replay, then sync throw, then normal + do entered <- newEmptyMVar + gate <- newEmptyMVar + let thunk = B.n7_a O.n7 + (unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate) + 2 3 4 5 6 7 + tid <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate 42 + rAsync <- evaluate thunk + rSync <- tryEval (B.n7_a O.n7 (error "sync") 2 3 4 5 6 7) + let syncThrew = case rSync of { Left _ -> True; Right _ -> False } + let rNormal = O.n7_a B.n7 10 20 30 40 50 60 70 + putStrLn $ "async_exc_combo " ++ show + (rAsync == (42,2,3,4,5,6,7) && syncThrew && + rNormal == (10,20,30,40,50,60,70)) + + -- Async loop: create, kill, and replay AP_STACKs 20 times + do let oneRound i = do + entered <- newEmptyMVar + gate <- newEmptyMVar + let thunk = B.n7_a O.n7 + (unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate) + (i+1) (i+2) (i+3) (i+4) (i+5) (i+6) + tid <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered + killThread tid + threadDelay 5000 + putMVar gate i + r <- tryEval thunk + return (isRight (i,i+1,i+2,i+3,i+4,i+5,i+6) r) + results <- mapM oneRound [1000 :: Int, 1001 .. 1019] + putStrLn $ "async_loop " ++ show (and results) + + -- ======================================================== + -- Multi-ctoi AP_STACK tests + -- ======================================================== + + -- 2 ctoi frames: B.n2_a->O.n2 inside B.n7_a->O.n7 + apStackTest "async_2ctoi" (42 :: Int) + (\b -> let l1 = case B.n2_a O.n2 b 2 of (a, _) -> a + in B.n7_a O.n7 l1 20 30 40 50 60 70) + (42,20,30,40,50,60,70) + + -- 3 ctoi frames with different sizes: + -- innermost: stg_ctoi_t0 (n2, spill=0) + -- middle: stg_ctoi_t1 (n7, spill=1) + -- outermost: stg_ctoi_t (n15, generic, spill=9) + apStackTest "async_3ctoi" (42 :: Int) + (\b -> let l1 = case B.n2_a O.n2 b 2 of (a, _) -> a + l2 = case B.n7_a O.n7 l1 2 3 4 5 6 7 of (a,_,_,_,_,_,_) -> a + in B.n15_a O.n15 l2 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + ((42,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15)) + + -- Nested async with multi-ctoi: 2 rounds of interruption, + -- each with different numbers of ctoi frames on the stack. + do entered1 <- newEmptyMVar + entered2 <- newEmptyMVar + gate1 <- newEmptyMVar + gate2 <- newEmptyMVar + let blocking1 = unsafePerformIO $ do + _ <- tryPutMVar entered1 () + takeMVar gate1 + let blocking2 = unsafePerformIO $ do + _ <- tryPutMVar entered2 () + takeMVar gate2 + let l1 = case B.n2_a O.n2 blocking1 2 of (a, _) -> a + let thunk = B.n7_a O.n7 l1 blocking2 3 4 5 6 7 + tid1 <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered1 + killThread tid1 + threadDelay 10000 + putMVar gate1 100 + tid2 <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered2 + killThread tid2 + threadDelay 10000 + putMVar gate2 200 + result <- evaluate thunk + putStrLn $ "async_nested_ctoi " ++ show + (result == (100,200,3,4,5,6,7)) + + -- ======================================================== + -- All-generic multi-ctoi AP_STACK tests (32+ element tuples) + -- ======================================================== + + -- Single 32-element generic ctoi frame (spill = 26) + apStackTest "async_n32" (42 :: Int) + (\b -> B.n32_a O.n32 b 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32) + ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16), + (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32)) + + -- 2 generic ctoi frames: n20 (spill=14) inside n32 (spill=26) + apStackTest "async_2gen32" (42 :: Int) + (\b -> let l1 = case B.n20_a O.n20 b 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + of ((a,_,_,_,_),_,_,_) -> a + in B.n32_a O.n32 l1 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32) + ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16), + (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32)) + + -- 2 generic ctoi frames with mixed types: n15 (spill=9) inside mix32 (spill=14) + apStackTest "async_gen_mix" (42 :: Int) + (\b -> let l1 = case B.n15_a O.n15 b 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + of ((a,_,_,_,_),_,_) -> a + in B.mix32_a O.mix32 + 1 l1 3.0 4.0 5 6 7.0 8.0 9 10 11.0 12.0 + 13 14 15.0 16.0 17 18 19.0 20.0 21 22 23.0 24.0 + 25 26 27.0 28.0 29 30 31.0 32.0) + ((1,42,3.0,4.0),(5,6,7.0,8.0),(9,10,11.0,12.0), + (13,14,15.0,16.0),(17,18,19.0,20.0),(21,22,23.0,24.0), + (25,26,27.0,28.0),(29,30,31.0,32.0)) + + -- ======================================================== + -- AP_STACK replay with non-zero base TSO state + -- ======================================================== + -- These tests replay AP_STACKs inside an outer generic ctoi frame, + -- so restoreStackInvariants must patch the saved old_spill in the + -- replayed segment to match the outer frame's spill count. + -- See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm. + + -- AP_STACK with generic ctoi(n15, spill=9) replayed inside + -- ctoi(n20, spill=14). If restoreStackInvariants doesn't patch + -- n15's old_spill to 14, n15's return restores TSO to 0 (from the + -- killed thread's context), and ctoi(n20) reads 0 spill words + -- instead of 14 -> stack corruption. + do entered <- newEmptyMVar + gate <- newEmptyMVar + let innerThunk = B.n15_a O.n15 + (unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate) + 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + tid <- forkIO $ do + _ <- tryEval innerThunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate 42 + -- Force innerThunk (AP_STACK replay) inside generic ctoi(n20) + let l1 = case innerThunk of ((a,_,_,_,_),_,_) -> a + result <- evaluate (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20) + putStrLn $ "async_replay_base " ++ show + (result == ((42,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20))) + + -- AP_STACK with 2 generic ctoi frames (n15+n20) replayed inside + -- ctoi(n32, spill=26). restoreStackInvariants must patch the outermost + -- replayed frame's (n20) old_spill to 26. + do entered <- newEmptyMVar + gate <- newEmptyMVar + let blocking = unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate + let l1 = case B.n15_a O.n15 blocking 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 + of ((a,_,_,_,_),_,_) -> a + let innerThunk = B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + tid <- forkIO $ do + _ <- tryEval innerThunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate 42 + -- Force inside generic ctoi(n32, spill=26); replays 2 inner frames + let l2 = case innerThunk of ((a,_,_,_,_),_,_,_) -> a + result <- evaluate (B.n32_a O.n32 l2 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 16 + 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32) + putStrLn $ "async_replay_2inner " ++ show + (result == ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16), + (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32))) + + -- AP_STACK replay inside ctoi(n20), where the replay triggers an + -- exception caught between the restored ctoi(n15) and outer ctoi(n20). + -- Tests restoreStackInvariants patching AND exception unwinding through + -- the patched frame: if n15's old_spill is wrong, the unwind restores + -- the wrong value, and ctoi(n20) reads the wrong spill count. + do entered <- newEmptyMVar + gate <- newEmptyMVar + let innerThunk = B.n15_a O.n15 + (unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate) + 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + tid <- forkIO $ do + _ <- tryEval innerThunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate (error "exc") + -- Force inside ctoi(n20); replay throws, caught between frames + let l1 :: Int + l1 = unsafePerformIO $ + catch (evaluate innerThunk >>= \r -> + case r of ((a,_,_,_,_),_,_) -> return a) + (const (return 99) :: SomeException -> IO Int) + result <- evaluate (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20) + putStrLn $ "async_replay_catch " ++ show + (result == ((99,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20))) + +-- ======================================================== +-- Helpers +-- ======================================================== + +swapStress :: Int -> (Int, Int) -> (Int, Int) +swapStress n (a, b) + | n <= 0 = (a, b) + | even n = swapStress (n-1) (B.p2_a O.p2 b a) + | otherwise = swapStress (n-1) (O.p2_a B.p2 b a) + +testX :: (Eq a, Show a) + => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO () +testX msg a1 a2 b1 b2 ap = + let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]] + in putStrLn (msg ++ " " ++ show (all (==r) rs) ++ " " ++ show r) + +-- | Evaluate an expression and catch any exception. +tryEval :: a -> IO (Either SomeException a) +tryEval x = try (evaluate x) + +-- | Check that an Either SomeException result is Right with the expected value. +isRight :: Eq a => a -> Either SomeException a -> Bool +isRight expected (Right v) = v == expected +isRight _ (Left _) = False + +-- | Run an AP_STACK replay test. @mkThunk@ receives a blocking value (backed +-- by an MVar) and should build a thunk that forces it during evaluation. +-- The thunk is evaluated in a thread that gets killed (creating an AP_STACK), +-- then the MVar is filled with @unblockVal@ and the AP_STACK is replayed. +apStackTest :: Eq a => String -> b -> (b -> a) -> a -> IO () +apStackTest name unblockVal mkThunk expected = do + entered <- newEmptyMVar + gate <- newEmptyMVar + let blocking = unsafePerformIO $ do + _ <- tryPutMVar entered () + takeMVar gate + let thunk = mkThunk blocking + tid <- forkIO $ do + _ <- tryEval thunk + return () + takeMVar entered + killThread tid + threadDelay 10000 + putMVar gate unblockVal + r <- tryEval thunk + putStrLn $ name ++ " " ++ show (isRight expected r) ===================================== testsuite/tests/bytecode/tuplestress/TupleStress.stdout ===================================== @@ -0,0 +1,46 @@ +p7 True (1,2,3,4,5,6,7) +n2 True (1,2) +n7 True (1,2,3,4,5,6,7) +n15 True ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15)) +d7 True (1.5,2.5,3.5,4.5,5.5,6.5,7.5) +fl7 True (1.25,2.25,3.25,4.25,5.25,6.25,7.25) +w7 True (100,200,300,400,500,600,700) +mpi6 True (1,2,3,4,5,6) +mpd6 True (1,1.5,2,2.5,3,3.5) +mall8 True (1,2,3.0,4.0,5,6,7.0,8.0) +sub5 True (42,1000,70000,99,100) +vd6 True (11,22,33) +n14 True ((1,2,3,4,5,6,7),(8,9,10,11,12,13,14)) +n20 True ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20)) +n32 True ((1,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),(17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32)) +mix32 True ((1,2,3.0,4.0),(5,6,7.0,8.0),(9,10,11.0,12.0),(13,14,15.0,16.0),(17,18,19.0,20.0),(21,22,23.0,24.0),(25,26,27.0,28.0),(29,30,31.0,32.0)) +loop_p7 True +loop_mpd True +loop_n32 True +chain_arith (80,80,80,40,80,80,80) +swap_stress (1,2) +rec_mixed (50,100,25.0,75.0) +fib_cross 832040 +exc_n7_bo True +exc_n15_bo True +exc_mpd_bo True +exc_repeat True +exc_n14_bo True +exc_n32_bo True +exc_nested_2gen True +exc_catch_between True +async_n7 True +async_other True +async_n14 True +async_nested True +async_exc_combo True +async_loop True +async_2ctoi True +async_3ctoi True +async_nested_ctoi True +async_n32 True +async_2gen32 True +async_gen_mix True +async_replay_base True +async_replay_2inner True +async_replay_catch True ===================================== testsuite/tests/bytecode/tuplestress/all.T ===================================== @@ -0,0 +1,10 @@ +test('TupleStress', + [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']), + req_interp, + req_bco, + only_ways(ghci_ways), + extra_ways(ghci_ways), + ], + compile_and_run, + [''] + ) ===================================== utils/deriveConstants/Main.hs ===================================== @@ -476,6 +476,7 @@ wanteds os = concat ,closureField Both "StgTSO" "alloc_limit" ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs" ,closureField Both "StgTSO" "stackobj" + ,closureField Both "StgTSO" "ctoi_tuple_spill_words" ,closureField Both "StgStack" "sp" ,closureFieldOffset Both "StgStack" "stack" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe6e76c5e0155b9b34948957476b0b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe6e76c5e0155b9b34948957476b0b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new tag ghc-9.12.4
by Zubin (＠wz1000) 27 Mar '26

27 Mar '26

Zubin pushed new tag ghc-9.12.4 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/ghc-9.12.4 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/tc-expand] 42 commits: Add 128-bit SIMD support to AArch64 NCG
by Simon Peyton Jones (＠simonpj) 27 Mar '26

27 Mar '26

Simon Peyton Jones pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: 2a218737 by ARATA Mizuki at 2026-03-23T11:11:39-04:00 Add 128-bit SIMD support to AArch64 NCG Changes: - Add `Format` field to vector-capable instructions. These instructions will emit `vN.4s` (for example) as a operand. - Additional constructors for `Operand`: `OpVecLane` represents a vector lane and will be emitted as `vN.<width>[<index>]` (`vN.s[3]` for example). `OpScalarAsVec` represents a scalar, but printed as a vector lane like `vN.<width>[0]` (`vN.s[0]` for example). - Integer quot/rem are implemented in C, like x86. Closes #26536 Metric Increase: T3294 - - - - - 5d6e2be9 by ARATA Mizuki at 2026-03-23T11:11:39-04:00 AArch64 NCG: Improve code generation for floating-point and vector constants Some floating-point constants can be directly encoded using the FMOV instruction. Similarly, a class of vectors with same values can be encoded using FMOV, MOVI, or MVNI. - - - - - c6d262aa by Simon Jakobi at 2026-03-23T11:12:22-04:00 Add regression test for #13729 Closes #13729. - - - - - aa5dfe67 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Check that shift values are valid In GHC's codebase in non-DEBUG builds we silently substitute shiftL/R with unsafeShiftL/R for performance reasons. However we were not checking that the shift value was valid for unsafeShiftL/R, leading to wrong computations, but only in non-DEBUG builds. This patch adds the necessary checks and reports an error when a wrong shift value is passed. - - - - - c8a7b588 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Implement basic value range analysis (#25718) Perform basic value range analysis to try to determine at compile time the result of the application of some comparison primops (ltWord#, etc.). This subsumes the built-in rewrite rules used previously to check if one of the comparison argument was a bound (e.g. (x :: Word8) <= 255 is always True). Our analysis is more powerful and handles type conversions: e.g. word8ToWord x <= 255 is now detected as always True too. We also use value range analysis to filter unreachable alternatives in case-expressions. To support this, we had to allow case-expressions for primitive types to not have a DEFAULT alternative (as was assumed before and checked in Core lint). - - - - - a5ec467e by ARATA Mizuki at 2026-03-26T03:49:49-04:00 rts: Align stack to 64-byte boundary in StgRun on x86 When LLVM spills AVX/AVX-512 vector registers to the stack, it requires 32-byte (__m256) or 64-byte (__m512) alignment. If the stack is not sufficiently aligned, LLVM inserts a realignment prologue that reserves %rbp as a frame pointer, conflicting with GHC's use of %rbp as an STG callee-saved register and breaking the tail-call-based calling convention. Previously, GHC worked around this by lying to LLVM about the stack alignment and rewriting aligned vector loads/stores (VMOVDQA, VMOVAPS) to unaligned ones (VMOVDQU, VMOVUPS) in the LLVM Mangler. This had two problems: - It did not extend to AVX-512, which requires 64-byte alignment. (#26595) - When Haskell calls a C function that takes __m256/__m512 arguments on the stack, the callee requires genuine alignment, which could cause a segfault. (#26822) This patch genuinely aligns the stack to 64 bytes in StgRun by saving the original stack pointer before alignment and restoring it in StgReturn. We now unconditionally advertise 64-byte stack alignment to LLVM for all x86 targets, making rewriteAVX in the LLVM Mangler unnecessary. STG_RUN_STACK_FRAME_SIZE is increased from 48 to 56 bytes on non-Windows x86-64 to store the saved stack pointer. Closes #26595 and #26822 Co-Authored-By: Claude Opus 4.5 <noreply(a)anthropic.com> - - - - - 661da815 by Teo Camarasu at 2026-03-26T03:50:33-04:00 ghc-internal: Float Generics to near top of module graph We remove GHC.Internal.Generics from the critical path of the `ghc-internal` module graph. GHC.Internal.Generics used to be in the middle of the module graph, but now it is nearer the top (built later). This change thins out the module graph and allows us to get rid of the ByteOrder hs-boot file. We implement this by moving Generics instances from the module where the datatype is defined to the GHC.Internal.Generics module. This trades off increasing the compiled size of GHC.Internal.Generics with reducing the dependency footprint of datatype modules. Not all instances are moved to GHC.Internal.Generics. For instance, `GHC.Internal.Control.Monad.Fix` keeps its instance as it is one of the very last modules compiled in `ghc-internal` and so inverting the relationship here would risk adding GHC.Internal.Generics back onto the critical path. We also don't change modules that are re-exported from the `template-haskell` or `ghc-heap`. This is done to make it easy to eventually move `Generics` to `base` once something like #26657 is implemented. Resolves #26930 Metric Decrease: T21839c - - - - - 45428f88 by sheaf at 2026-03-26T03:51:31-04:00 Avoid infinite loop in deep subsumption This commit ensures we only unify after we recur in the deep subsumption code in the FunTy vs non-FunTy case of GHC.Tc.Utils.Unify.tc_sub_type_deep, to avoid falling into an infinite loop. See the new Wrinkle [Avoiding a loop in tc_sub_type_deep] in Note [FunTy vs non-FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify. Fixes #26823 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 2823b039 by Ian Duncan at 2026-03-26T03:52:21-04:00 AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written MOVK (move with keep) modifies only a 16-bit slice of the destination register, so the destination is both read and written. The register allocator must know this to avoid clobbering live values. Update regUsageOfInstr to list the destination in both src and dst sets. No regression test: triggering the misallocation requires specific register pressure around a MOVK sequence, which is difficult to reliably provoke from Haskell source. - - - - - 57b7878d by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #12002 Closes #12002. - - - - - c8f9df2d by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #12046 Closes #12046. Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at> - - - - - 615d72ac by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #13180 Closes #13180. - - - - - 423eebcf by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #11141 Closes #11141. - - - - - 286849a4 by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #11505 Closes #11505. - - - - - 7db149d9 by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression perf test for #13820 Closes #13820. - - - - - e73c4adb by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #10381 Closes #10381. - - - - - 5ebcfb57 by Benjamin Maurer at 2026-03-26T03:54:02-04:00 Generate assembly on x86 for word2float (#22252) We used to emit C function call for MO_UF_Conv primitive. Now emits direct assembly instead. Co-Authored-By: Sylvain Henry <sylvain(a)haskus.fr> Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 5b550754 by Matthew Pickering at 2026-03-26T03:54:51-04:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 - - - - - ef0a1bd2 by mangoiv at 2026-03-26T03:55:34-04:00 release tracking: adopt release tracking ticket from #16816 - - - - - a7f40fd9 by mangoiv at 2026-03-26T03:55:34-04:00 release tracking: add a release tracking ticket Brings the information in the release tracking ticket up to date with https://gitlab.haskell.org/ghc/ghc-hq/-/blob/main/release-management.mkd Resolves #26691 - - - - - 161d3285 by Teo Camarasu at 2026-03-26T03:56:18-04:00 Revert "Set default eventlog-flush-interval to 5s" Flushing the eventlog forces a synchronisation of all the capabilities and there was a worry that this might lead to a performance cost for some highly parallel workloads. This reverts commit 66b96e2a591d8e3d60e74af3671344dfe4061cf2. - - - - - 36eed985 by Cheng Shao at 2026-03-26T03:57:03-04:00 ghc-boot: move GHC.Data.SmallArray to ghc-boot This commit moves `GHC.Data.SmallArray` from the `ghc` library to `ghc-boot`, so that it can be used by `ghci` as well: - The `Binary` (from `ghc`) instance of `SmallArray` is moved to `GHC.Utils.Binary` - Util functions `replicateSmallArrayIO`, `mapSmallArrayIO`, `mapSmallArrayM_`, `imapSmallArrayM_` , `smallArrayFromList` and `smallArrayToList` are added - The `Show` instance is added - The `Binary` (from `binary`) instance is added - - - - - fdf828ae by Cheng Shao at 2026-03-26T03:57:03-04:00 compiler: use `Binary` instance of `BCOByteArray` for bytecode objects This commit defines `Binary` (from `compiler`) instance of `BCOByteArray` which serializes the underlying buffer directly, and uses it directly in bytecode object serialization. Previously we reuse the `Binary` (from `binary`) instance, and this change allows us to avoid double-copying via an intermediate `ByteString` when using `put`/`get` in `binnary`. Also see added comment for explanation. - - - - - 3bf62d0a by Cheng Shao at 2026-03-26T03:57:03-04:00 ghci: use SmallArray directly in ResolvedBCO This patch makes ghci use `SmallArray` directly in `ResolvedBCO` when applicable, making the memory representation more compact and reducing marshaling overhead. Closes #27058. - - - - - 3d6492ce by Wen Kokke at 2026-03-26T03:57:53-04:00 Fix race condition between flushEventLog and start/endEventLogging. This commit changes `flushEventLog` to acquire/release the `state_change` mutex to prevent interleaving with `startEventLogging` and `endEventLogging`. In the current RTS, `flushEventLog` _does not_ acquire this mutex, which may lead to eventlog corruption on the following interleaving: - `startEventLogging` writes the new `EventLogWriter` to `event_log_writer`. - `flushEventLog` flushes some events to `event_log_writer`. - `startEventLogging` writes the eventlog header to `event_log_writer`. This causes the eventlog to be written out in an unreadable state, with one or more events preceding the eventlog header. This commit renames the old function to `flushEventLog_` and defines `flushEventLog` simply as: ```c void flushEventLog(Capability **cap USED_IF_THREADS) { ACQUIRE_LOCK(&state_change_mutex); flushEventLog_(cap); RELEASE_LOCK(&state_change_mutex); } ``` The old function is still needed internally within the compilation unit, where it is used in `endEventLogging` in a context where the `state_change` mutex has already been acquired. I've chosen to mark `flushEventLog_` as static and let other uses of `flushEventLog` within the RTS refer to the new version. There is one use in `hs_init_ghc` via `flushTrace`, where the new locking behaviour should be harmless, and one use in `handle_tick`, which I believe was likely vulnerable to the same race condition, so the new locking behaviour is desirable. I have not added a test. The behaviour is highly non-deterministic and requires a program that concurrently calls `flushEventLog` and `startEventLogging`/`endEventLogging`. I encountered the issue while developing `eventlog-socket` and within that context have verified that my patch likely addresses the issue: a test that used to fail within the first dozen or so runs now has been running on repeat for several hours. - - - - - 7b9a75f0 by Phil Hazelden at 2026-03-26T03:58:37-04:00 Fix build with werror on glibc 2.43. We've been defining `_XOPEN_SOURCE` and `_POSIX_C_SOURCE` to the same values as defined in glibc prior to 2.43. But in 2.43, glibc changes them to new values, which means we get a warning when redefining them. By `#undef`ing them first, we no longer get a warning. Closes #27076. - - - - - fe6e76c5 by Tobias Haslop at 2026-03-26T03:59:30-04:00 Fix broken Haddock link to Bifunctor class in description of Functor class - - - - - 5506b415 by Apoorv Ingle at 2026-03-26T23:42:05+00:00 Work for #25001 Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] ------------------------- Metric Decrease: T9020 ------------------------- * Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr` * Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Kills the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * Makes `splitHsApps` not look through `XExpr` * `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr` * Removes location information from `OrigPat` payload * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Rename `HsThingRn` to `SrcCodeCtxt` * Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack` * Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin` * Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression * Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax * Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * kill `PopErrCtxt` from `XXExprGhcRn` * simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself * fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) * rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location * fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg * Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack * `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex. This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them - The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead` - `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes * wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan * remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails` * trying to remove SrcCodeOrigin by merging it with ErrCtxtMsg * ErrCtxtMsg is now HsCtxt * Landmarks are now just computed on the fly * killed off CodeSrcFlag - - - - - b9243204 by Apoorv Ingle at 2026-03-26T23:42:05+00:00 make HsExpandedRn and HsExpandedTc payload LExpr, add tcExpand for expanding Do expressions before typechecking in tcExpr - - - - - bc589874 by Apoorv Ingle at 2026-03-26T23:42:05+00:00 * make HsExpandedRn and HsExpandedTc payload LExpr, HsExpand to mediate between expansion and typechecking * add tcHsExpand type checking expanded Expressions * remove setInGeneratedCode - - - - - 1119a2cd by Apoorv Ingle at 2026-03-26T23:42:05+00:00 remove srcCodeOrigin references, add some WIP flag - - - - - 2a837369 by Apoorv Ingle at 2026-03-26T23:42:05+00:00 accept callstack001 testcase - - - - - dbf0e1cb by Apoorv Ingle at 2026-03-26T23:42:05+00:00 update Note to include HsExpansion - - - - - 1f31a3d8 by Simon Peyton Jones at 2026-03-26T23:42:05+00:00 Tidying up from Simon - - - - - db5ae568 by Simon Peyton Jones at 2026-03-26T23:42:05+00:00 More from Simon - - - - - 4321764f by Apoorv Ingle at 2026-03-26T23:42:05+00:00 remove unused function - - - - - 62652e92 by Apoorv Ingle at 2026-03-26T23:42:05+00:00 account for rebase changes - - - - - d7f93b98 by Apoorv Ingle at 2026-03-26T23:42:06+00:00 Wrinkle [Why GeneratedSrcSpanDetails in GeneratedSrcSpan] in Note [Typechecking by expansion: overview] - - - - - 54057519 by Apoorv Ingle at 2026-03-26T23:42:06+00:00 replace tcInferAppHead with tcInferExprSigma, remove ds_flag from EValArgQL - - - - - 310927e9 by Simon Peyton Jones at 2026-03-26T23:42:06+00:00 Fixes from Simon [skip ci] ..need documentation. - - - - - 72c9dcaf by Simon Peyton Jones at 2026-03-26T23:42:06+00:00 Fixes from Simon Looking much nicer now - - - - - 678b6eb3 by Simon Peyton Jones at 2026-03-26T23:42:06+00:00 Wibble - - - - - 252 changed files: - + .gitlab/issue_templates/release_tracking.md - compiler/CodeGen.Platform.h - compiler/GHC.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Cmm/Node.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/AArch64/Regs.hs - compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Config.hs - compiler/GHC/CmmToLlvm/Mangler.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - + compiler/GHC/Core/Opt/Range.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Driver/Config/CmmToLlvm.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Prelude/Basic.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - compiler/GHC/Data/SmallArray.hs → libraries/ghc-boot/GHC/Data/SmallArray.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - − libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs-boot - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Messages.c - rts/RtsFlags.c - rts/StgCRun.c - rts/eventlog/EventLog.c - rts/include/rts/Constants.h - rts/include/rts/PosixSource.h - rts/include/stg/Prim.h - rts/prim/vectorQuotRem.c - testsuite/tests/codeGen/should_run/Word2Float32.hs - testsuite/tests/codeGen/should_run/Word2Float32.stdout - testsuite/tests/codeGen/should_run/Word2Float64.hs - testsuite/tests/codeGen/should_run/Word2Float64.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/driver/T13729/A/A.cabal - + testsuite/tests/driver/T13729/A/Setup.hs - + testsuite/tests/driver/T13729/A/TH.hs - + testsuite/tests/driver/T13729/A/Types1.hs - + testsuite/tests/driver/T13729/A/Types2.hs - + testsuite/tests/driver/T13729/B/B.cabal - + testsuite/tests/driver/T13729/B/Main.hs - + testsuite/tests/driver/T13729/B/Setup.hs - + testsuite/tests/driver/T13729/Makefile - + testsuite/tests/driver/T13729/Setup.hs - + testsuite/tests/driver/T13729/all.T - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/ghci064.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/monadfail/MonadFailErrors.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - + testsuite/tests/parser/should_compile/T12002.hs - + testsuite/tests/parser/should_compile/T12002.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - + testsuite/tests/perf/compiler/T13820.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/profiling/should_run/callstack001.stdout - + testsuite/tests/rebindable/T10381.hs - testsuite/tests/rebindable/all.T - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs - + testsuite/tests/simd/should_run/FloatConstant.hs - + testsuite/tests/simd/should_run/FloatConstant.stdout - + testsuite/tests/simd/should_run/IntConstant.hs - + testsuite/tests/simd/should_run/IntConstant.stdout - + testsuite/tests/simd/should_run/StackAlignment32.hs - + testsuite/tests/simd/should_run/StackAlignment32.stdout - + testsuite/tests/simd/should_run/StackAlignment32_main.c - + testsuite/tests/simd/should_run/StackAlignment64.hs - + testsuite/tests/simd/should_run/StackAlignment64.stdout - + testsuite/tests/simd/should_run/StackAlignment64_main.c - testsuite/tests/simd/should_run/all.T - testsuite/tests/simd/should_run/int16x8_shuffle.hs - testsuite/tests/simd/should_run/int16x8_shuffle.stdout - testsuite/tests/simd/should_run/int16x8_shuffle_baseline.hs - testsuite/tests/simd/should_run/int16x8_shuffle_baseline.stdout - testsuite/tests/simd/should_run/int8x16_shuffle.hs - testsuite/tests/simd/should_run/int8x16_shuffle.stdout - testsuite/tests/simd/should_run/int8x16_shuffle_baseline.hs - testsuite/tests/simd/should_run/int8x16_shuffle_baseline.stdout - testsuite/tests/simd/should_run/simd013C.c - + testsuite/tests/simplCore/should_compile/T19166.hs - + testsuite/tests/simplCore/should_compile/T19166.stderr - + testsuite/tests/simplCore/should_compile/T25718.hs - + testsuite/tests/simplCore/should_compile/T25718.stderr - + testsuite/tests/simplCore/should_compile/T25718a.hs - + testsuite/tests/simplCore/should_compile/T25718a.stderr - + testsuite/tests/simplCore/should_compile/T25718b.hs - + testsuite/tests/simplCore/should_compile/T25718b.stderr - + testsuite/tests/simplCore/should_compile/T25718c.hs - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32 - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/T13180/T13180.hs - + testsuite/tests/typecheck/T13180/T13180.hs-boot - + testsuite/tests/typecheck/T13180/T13180.stderr - + testsuite/tests/typecheck/T13180/T13180A.hs - + testsuite/tests/typecheck/T13180/all.T - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - + testsuite/tests/typecheck/should_compile/T11141.hs - + testsuite/tests/typecheck/should_compile/T11141.stderr - + testsuite/tests/typecheck/should_compile/T11505Bar.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs-boot - + testsuite/tests/typecheck/should_compile/T12046.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/T26225.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - + testsuite/tests/typecheck/should_fail/T26823.hs - + testsuite/tests/typecheck/should_fail/T26823.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893b2ba640a22adc06e2c7a04c9ea5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893b2ba640a22adc06e2c7a04c9ea5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/tc-expand] Wibble
by Simon Peyton Jones (＠simonpj) 27 Mar '26

27 Mar '26

Simon Peyton Jones pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: 893b2ba6 by Simon Peyton Jones at 2026-03-26T23:41:25+00:00 Wibble - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Expr.hs Changes: ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -679,17 +679,21 @@ tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) , rcon_con = L loc con_like , rcon_flds = rbinds' } + ; co <- tcSubTypeMono expr actual_res_ty res_ty + -- Check for missing fields. We do this after type-checking to get -- better types in error messages (cf #18869). For example: -- data T a = MkT { x :: a, y :: a } -- r = MkT { y = True } -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. -- - -- NB: to do this really properly we should delay reporting until typechecking is complete, - -- via a new `HoleSort`. But that seems too much work. + -- NB: to do this really properly we should delay reporting until typechecking + -- is complete, via a new `HoleSort`. But that seems too much work. + -- + -- However, it's worth doing it after calling `tcSubTypeMono`, + -- which may do some useful unifications ; checkMissingFields con_like rbinds arg_tys - ; co <- tcSubTypeMono expr actual_res_ty res_ty ; return (mkHsWrapCo co expr') } where orig = OccurrenceOf con_name View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893b2ba640a22adc06e2c7a04c9ea5c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893b2ba640a22adc06e2c7a04c9ea5c… You're receiving this email because of your account on gitlab.haskell.org.

1 0