October 2025 - ghc-commits

[Git][ghc/ghc][wip/T23162-spj] Improve tracking of RewriterSets
by Simon Peyton Jones (＠simonpj) 15 Oct '25

15 Oct '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 5cf99a78 by Simon Peyton Jones at 2025-10-14T21:28:29+01:00 Improve tracking of RewriterSets A bit experimental. Avoids taking the free coercion holes of a coercion, which can be expensive if the coercion is the result of a huge rewrite. The rewriter returns the RewriterSet! - - - - - 12 changed files: - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-} @@ -41,6 +42,11 @@ module GHC.Core.TyCo.Rep ( CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, KindMCoercion, + -- RewriterSet + -- RewriterSet(..) is exported concretely only for zonkRewriterSet + RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, elemRewriterSet, + addRewriter, unitRewriterSet, unionRewriterSet, delRewriterSet, + -- * Functions over types mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, @@ -78,6 +84,7 @@ import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstr -- friends: import GHC.Types.Var import GHC.Types.Var.Set( elemVarSet ) +import GHC.Types.Unique.Set import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -93,6 +100,7 @@ import GHC.Utils.Binary -- libraries import qualified Data.Data as Data hiding ( TyCon ) +import Data.Coerce import Data.IORef ( IORef ) -- for CoercionHole import Control.DeepSeq @@ -1672,7 +1680,7 @@ holes `HoleCo`, which get filled in later. {- ********************************************************************** %* * - Coercion holes + Coercion holes and RewriterSets %* * %********************************************************************* -} @@ -1681,7 +1689,7 @@ data CoercionHole = CoercionHole { ch_co_var :: CoVar -- See Note [CoercionHoles and coercion free variables] - , ch_ref :: IORef (Maybe Coercion) + , ch_ref :: IORef (Maybe (Coercion, RewriterSet)) } coHoleCoVar :: CoercionHole -> CoVar @@ -1702,6 +1710,33 @@ instance Outputable CoercionHole where instance Uniquable CoercionHole where getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv + +-- | A RewriterSet stores a set of CoercionHoles that have been used to rewrite +-- a constraint. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +newtype RewriterSet = RewriterSet (UniqSet CoercionHole) + deriving newtype (Outputable, Semigroup, Monoid) + +emptyRewriterSet :: RewriterSet +emptyRewriterSet = RewriterSet emptyUniqSet + +unitRewriterSet :: CoercionHole -> RewriterSet +unitRewriterSet = coerce (unitUniqSet @CoercionHole) + +elemRewriterSet :: CoercionHole -> RewriterSet -> Bool +elemRewriterSet = coerce (elementOfUniqSet @CoercionHole) + +delRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet +delRewriterSet = coerce (delOneFromUniqSet @CoercionHole) + +unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet +unionRewriterSet = coerce (unionUniqSets @CoercionHole) + +isEmptyRewriterSet :: RewriterSet -> Bool +isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) + +addRewriter :: RewriterSet -> CoercionHole -> RewriterSet +addRewriter = coerce (addOneToUniqSet @CoercionHole) + {- Note [Coercion holes] ~~~~~~~~~~~~~~~~~~~~~~~~ During typechecking, constraint solving for type classes works by @@ -1777,6 +1812,15 @@ constraint from floating] in GHC.Tc.Solver, item (4): Here co2 is a CoercionHole. But we /must/ know that it is free in co1, because that's all that stops it floating outside the implication. + +Note [CoercionHoles and RewriterSets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constraint C carries a set of "rewriters", a set of Wanted CoercionHoles that have been +used to rewrite C; see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. + +If C is an equality constraint and is solved, we track its RewriterSet in the filled +CoercionHole, so that it can be inherited by other constraints that have C in /their/ +rewriters. See zonkRewriterSet. -} ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -1327,7 +1327,7 @@ addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest -> do { -- See Note [Deferred errors for coercion holes] let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm - ; fillCoercionHole hole (mkCoVarCo co_var) } } + ; fillCoercionHole hole (mkCoVarCo co_var, emptyRewriterSet) } } addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given mkSolverErrorTerm :: CtLoc -> Type -- of the error term ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -1481,7 +1481,7 @@ in `getRuleQuantCts`. Why not? do { ev_id <- newEvVar pred ; fillCoercionHole hole (mkCoVarCo ev_id) ; return ev_id } - But that led to new complications becuase of the side effect on the coercion + But that led to new complications because of the side effect on the coercion hole. Much easier just to side-step the issue entirely by not quantifying over equalities. ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -296,7 +296,7 @@ solveImplicationUsingUnsatGiven go_simple ct = case ctEvidence ct of CtWanted (WantedCt { ctev_pred = pty, ctev_dest = dest }) -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty - ; setWantedEvTerm dest EvNonCanonical $ EvExpr ev_expr } + ; setWantedDict dest EvNonCanonical $ EvExpr ev_expr } _ -> return () -- | Create an evidence expression for an arbitrary constraint using ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -476,7 +476,7 @@ solveEqualityDict ev cls tys ; co <- wrapUnifierAndEmit ev role $ \uenv -> uType uenv t1 t2 -- Set d :: (t1~t2) = Eq# co - ; setWantedEvTerm dest EvCanonical $ + ; setWantedDict dest EvCanonical $ evDictApp cls tys [Coercion co] ; stopWith ev "Solved wanted lifted equality" } ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -485,7 +485,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel -- See Note [Solving forall equalities] can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev + | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_rewriters = rws, ctev_loc = loc }) <- ev = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2 flags1 = binderFlags bndrs1 flags2 = binderFlags bndrs2 @@ -567,9 +567,9 @@ can_eq_nc_forall ev eq_rel s1 s2 , ic_wanted = emptyWC { wc_simple = wanteds } } ; if solved - then do { zonked_all_co <- zonkCo all_co - -- ToDo: explain this zonk - ; setWantedEq orig_dest zonked_all_co + then do { -- all_co <- zonkCo all_co + -- -- ToDo: explain this zonk + setWantedEq orig_dest rws all_co ; stopWith ev "Polytype equality: solved" } else canEqSoftFailure IrredShapeReason ev s1 s2 } } @@ -809,7 +809,7 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy equalities] can_eq_app ev s1 t1 s2 t2 - | CtWanted (WantedCt { ctev_dest = dest }) <- ev + | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws }) <- ev = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1 , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2 , text "vis:" <+> ppr (isNextArgVisible s1) ]) @@ -824,7 +824,7 @@ can_eq_app ev s1 t1 s2 t2 ; co_t <- uType arg_env t1 t2 ; co_s <- uType uenv s1 s2 ; return (mkAppCo co_s co_t) } - ; setWantedEq dest co + ; setWantedEq dest rws co ; stopWith ev "Decomposed [W] AppTy" } -- If there is a ForAll/(->) mismatch, the use of the Left coercion @@ -1374,7 +1374,7 @@ canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2) do { traceTcS "canDecomposableTyConAppOK" (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) ; case ev of - CtWanted (WantedCt { ctev_dest = dest }) + CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws }) -- new_locs and tc_roles are both infinite, so we are -- guaranteed that cos has the same length as tys1 and tys2 -- See Note [Fast path when decomposing TyConApps] @@ -1382,7 +1382,7 @@ canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2) do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2 -- zipWith4M: see Note [Work-list ordering] ; return (mkTyConAppCo role tc cos) } - ; setWantedEq dest co } + ; setWantedEq dest rws co } CtGiven (GivenCt { ctev_evar = evar }) | let pred_ty = mkEqPred eq_rel ty1 ty2 @@ -1432,7 +1432,7 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) = do { traceTcS "canDecomposableFunTy" (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) ; case ev of - CtWanted (WantedCt { ctev_dest = dest }) + CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws }) -> do { co <- wrapUnifierAndEmit ev Nominal $ \ uenv -> do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc InvisibleMultiplicity `setUEnvRole` funRole role SelMult @@ -1443,7 +1443,7 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) ; arg <- uType (uenv `setUEnvRole` funRole role SelArg) a1 a2 ; res <- uType (uenv `setUEnvRole` funRole role SelRes) r1 r2 ; return (mkNakedFunCo role af mult arg res) } - ; setWantedEq dest co } + ; setWantedEq dest rws co } CtGiven (GivenCt { ctev_evar = evar }) | let pred_ty = mkEqPred eq_rel ty1 ty2 @@ -2652,7 +2652,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs ; let co = maybeSymCo swapped $ lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co - ; setWantedEq dest co + ; setWantedEq dest rewriters' co ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev , ppr nlhs , ppr nrhs ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Tc.Solver.Monad ( newWantedNC, newWantedEvVarNC, newBoundEvVarId, unifyTyVar, reportFineGrainUnifications, reportCoarseGrainUnifications, - setEvBind, setWantedEq, + setEvBind, setWantedEq, setWantedDict, setWantedEvTerm, setEvBindIfWanted, newEvVar, newGivenEv, emitNewGivens, emitChildEqs, checkReductionDepth, @@ -457,16 +457,15 @@ kickOutAfterUnification tv_set ; traceTcS "kickOutAfterUnification" (ppr tv_set $$ text "n_kicked =" <+> ppr n_kicked) ; return n_kicked } -kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS () +kickOutAfterFillingCoercionHole :: CoercionHole -> RewriterSet -> TcS () -- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty] -- in GHC.Tc.Solver.Equality -- -- It's possible that this could just go ahead and unify, but could there -- be occurs-check problems? Seems simpler just to kick out. -kickOutAfterFillingCoercionHole hole co +kickOutAfterFillingCoercionHole hole new_holes = do { ics <- getInertCans - ; new_holes <- liftZonkTcS $ TcM.freeHolesOfCoercion co - ; let (kicked_out, ics') = kick_out new_holes ics + ; let (kicked_out, ics') = kick_out ics n_kicked = length kicked_out ; unless (n_kicked == 0) $ @@ -479,14 +478,14 @@ kickOutAfterFillingCoercionHole hole co ; setInertCans ics' } where - kick_out :: RewriterSet -> InertCans -> ([EqCt], InertCans) - kick_out new_holes ics@(IC { inert_eqs = eqs }) + kick_out :: InertCans -> ([EqCt], InertCans) + kick_out ics@(IC { inert_eqs = eqs }) = (eqs_to_kick, ics { inert_eqs = eqs_to_keep }) where - (eqs_to_kick, eqs_to_keep) = transformAndPartitionTyVarEqs (kick_out_eq new_holes) eqs + (eqs_to_kick, eqs_to_keep) = transformAndPartitionTyVarEqs kick_out_eq eqs - kick_out_eq :: RewriterSet -> EqCt -> Either EqCt EqCt - kick_out_eq new_holes eq_ct@(EqCt { eq_ev = ev, eq_lhs = lhs }) + kick_out_eq :: EqCt -> Either EqCt EqCt + kick_out_eq eq_ct@(EqCt { eq_ev = ev, eq_lhs = lhs }) | CtWanted (wev@(WantedCt { ctev_rewriters = rewriters })) <- ev , TyVarLHS tv <- lhs , isMetaTyVar tv @@ -1951,27 +1950,32 @@ addUsedCoercion co = do { ev_binds_var <- getTcEvBindsVar ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) } --- | Equalities only -setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS () -setWantedEq (HoleDest hole) co +setWantedEq :: HasDebugCallStack => TcEvDest -> RewriterSet -> TcCoercion -> TcS () +-- ^ Equalities only +setWantedEq (HoleDest hole) rewriters co = do { addUsedCoercion co - ; fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) + ; fillCoercionHole hole rewriters co } +setWantedEq (EvVarDest ev) _ _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) --- | Good for both equalities and non-equalities -setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) _canonical tm +setWantedDict :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () +-- ^ Dictionaries only +setWantedDict (EvVarDest ev_id) canonical tm + = setEvBind (mkWantedEvBind ev_id canonical tm) +setWantedDict (HoleDest h) _ _ = pprPanic "setWantedEq: HoleDest" (ppr h) + +setWantedEvTerm :: TcEvDest -> RewriterSet -> CanonicalEvidence -> EvTerm -> TcS () +-- ^ Good for both equalities and non-equalities +setWantedEvTerm (EvVarDest ev_id) _rewriters canonical tm + = setEvBind (mkWantedEvBind ev_id canonical tm) +setWantedEvTerm (HoleDest hole) rewriters _canonical tm | Just co <- evTermCoercion_maybe tm = do { addUsedCoercion co - ; fillCoercionHole hole co } + ; fillCoercionHole hole rewriters co } | otherwise = -- See Note [Yukky eq_sel for a HoleDest] do { let co_var = coHoleCoVar hole ; setEvBind (mkWantedEvBind co_var EvCanonical tm) - ; fillCoercionHole hole (mkCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) canonical tm - = setEvBind (mkWantedEvBind ev_id canonical tm) + ; fillCoercionHole hole rewriters (mkCoVarCo co_var) } {- Note [Yukky eq_sel for a HoleDest] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1992,16 +1996,17 @@ We even re-use the CoHole's Id for this binding! Yuk! -} -fillCoercionHole :: CoercionHole -> Coercion -> TcS () -fillCoercionHole hole co - = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole co } +fillCoercionHole :: CoercionHole -> RewriterSet -> Coercion -> TcS () +fillCoercionHole hole rewriters co + = do { wrapTcS $ TcM.fillCoercionHole hole (co, rewriters) + ; kickOutAfterFillingCoercionHole hole rewriters } setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS () setEvBindIfWanted ev canonical tm = case ev of - CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest canonical tm - _ -> return () + CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) + -> setWantedEvTerm dest rewriters canonical tm + _ -> return () newTcEvBinds :: TcS EvBindsVar newTcEvBinds = wrapTcS TcM.newTcEvBinds ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -1666,7 +1666,7 @@ solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs -- NB: even if it is fully solved we must return it, because it is -- carrying a record of which evidence variables are used -- See Note [Free vars of EvFun] in GHC.Tc.Types.Evidence - do { setWantedEvTerm dest EvCanonical $ + do { setWantedDict dest EvCanonical $ EvFun { et_tvs = skol_tvs, et_given = given_ev_vars , et_binds = TcEvBinds ev_binds_var , et_body = wantedCtEvEvId wanted_ev } @@ -1761,7 +1761,7 @@ finish_rewrite ev_rw_role = ctEvRewriteRole ev ; mb_new_ev <- newWanted loc rewriters' new_pred ; massert (coercionRole co == ev_rw_role) - ; setWantedEvTerm dest EvCanonical $ + ; setWantedEvTerm dest rewriters' EvCanonical $ evCast (getEvExpr mb_new_ev) $ downgradeRole Representational ev_rw_role (mkSymCo co) ; case mb_new_ev of @@ -1833,7 +1833,8 @@ runTcPluginsWanted wanted where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of - CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest EvCanonical ev + CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) + -> setWantedEvTerm dest rewriters EvCanonical ev -- TODO: plugins should be able to signal non-canonicity _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -90,8 +90,8 @@ module GHC.Tc.Types.Constraint ( -- RewriterSet -- RewriterSet(..) is exported concretely only for zonkRewriterSet RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, elemRewriterSet, - addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts, - delRewriterSet, + addRewriter, unitRewriterSet, unionRewriterSet, delRewriterSet, + rewriterSetFromCts, wrapType, @@ -128,7 +128,6 @@ import GHC.Tc.Types.CtLoc import GHC.Builtin.Names import GHC.Types.Var.Set -import GHC.Types.Unique.Set import GHC.Types.Name.Reader import GHC.Utils.FV @@ -140,7 +139,6 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Data.Bag import Control.Monad ( when ) -import Data.Coerce import Data.List ( intersperse ) import Data.Maybe ( mapMaybe, isJust ) import GHC.Data.Maybe ( firstJust, firstJusts ) @@ -2395,6 +2393,16 @@ wantedCtHasNoRewriters (WantedCt { ctev_rewriters = rws }) setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs } +rewriterSetFromCts :: Bag Ct -> RewriterSet +-- Take a bag of Wanted equalities, and collect them as a RewriterSet +rewriterSetFromCts cts + = foldr add emptyRewriterSet cts + where + add ct rw_set = + case ctEvidence ct of + CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole + _ -> rw_set + ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ })) = Coercion $ ctEvCoercion (CtWanted ev) @@ -2488,50 +2496,6 @@ isGiven :: CtEvidence -> Bool isGiven (CtGiven {}) = True isGiven _ = False -{- -************************************************************************ -* * - RewriterSet -* * -************************************************************************ --} - --- | Stores a set of CoercionHoles that have been used to rewrite a constraint. --- See Note [Wanteds rewrite Wanteds]. -newtype RewriterSet = RewriterSet (UniqSet CoercionHole) - deriving newtype (Outputable, Semigroup, Monoid) - -emptyRewriterSet :: RewriterSet -emptyRewriterSet = RewriterSet emptyUniqSet - -unitRewriterSet :: CoercionHole -> RewriterSet -unitRewriterSet = coerce (unitUniqSet @CoercionHole) - -elemRewriterSet :: CoercionHole -> RewriterSet -> Bool -elemRewriterSet = coerce (elementOfUniqSet @CoercionHole) - -delRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet -delRewriterSet = coerce (delOneFromUniqSet @CoercionHole) - -unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet -unionRewriterSet = coerce (unionUniqSets @CoercionHole) - -isEmptyRewriterSet :: RewriterSet -> Bool -isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) - -addRewriter :: RewriterSet -> CoercionHole -> RewriterSet -addRewriter = coerce (addOneToUniqSet @CoercionHole) - -rewriterSetFromCts :: Bag Ct -> RewriterSet --- Take a bag of Wanted equalities, and collect them as a RewriterSet -rewriterSetFromCts cts - = foldr add emptyRewriterSet cts - where - add ct rw_set = - case ctEvidence ct of - CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole - _ -> rw_set - {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -360,15 +360,14 @@ newCoercionHole pred_ty ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } -- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do - when debugIsOn $ do - cts <- readTcRef ref - whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) - traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) - writeTcRef ref (Just co) - +fillCoercionHole :: CoercionHole -> (Coercion, RewriterSet) -> TcM () +fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co + = do { when debugIsOn $ + do { cts <- readTcRef ref + ; whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) } + ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) + ; writeTcRef ref (Just co) } {- ********************************************************************** * @@ -1546,8 +1545,8 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co go_co dv (HoleCo hole) = do m_co <- liftZonkM (unpackCoercionHole_maybe hole) case m_co of - Just co -> go_co dv co - Nothing -> go_cv dv (coHoleCoVar hole) + Just (co,_) -> go_co dv co + Nothing -> go_cv dv (coHoleCoVar hole) go_co dv (CoVarCo cv) = go_cv dv cv ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -43,8 +43,6 @@ module GHC.Tc.Zonk.TcType -- * Coercion holes , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe - , freeHolesOfCoercion - -- * Tidying , tcInitTidyEnv, tcInitOpenTidyEnv @@ -241,8 +239,8 @@ zonkCo :: Coercion -> ZonkM Coercion hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) = do { contents <- readTcRef ref ; case contents of - Just co -> do { co' <- zonkCo co - ; checkCoercionHole cv co' } + Just (co,_) -> do { co' <- zonkCo co + ; checkCoercionHole cv co' } Nothing -> do { cv' <- zonkCoVar cv ; return $ HoleCo (hole { ch_co_var = cv' }) } } @@ -592,26 +590,12 @@ zonkRewriterSet (RewriterSet set) go :: CoercionHole -> UnfilledCoercionHoleMonoid -> UnfilledCoercionHoleMonoid go hole m_acc = freeHolesOfHole hole `mappend` m_acc -freeHolesOfCoercion :: Coercion -> ZonkM RewriterSet -freeHolesOfCoercion co = unUCHM (freeHolesOfCo co) - freeHolesOfHole :: CoercionHole -> UnfilledCoercionHoleMonoid freeHolesOfHole hole = UCHM $ do { m_co <- unpackCoercionHole_maybe hole ; case m_co of Nothing -> return (unitRewriterSet hole) -- Not filled - Just co -> unUCHM (freeHolesOfCo co) } -- Filled: look inside - -freeHolesOfTy :: Type -> UnfilledCoercionHoleMonoid -freeHolesOfCo :: Coercion -> UnfilledCoercionHoleMonoid -(freeHolesOfTy, _, freeHolesOfCo, _) = foldTyCo freeHolesFolder () - -freeHolesFolder :: TyCoFolder () UnfilledCoercionHoleMonoid -freeHolesFolder = TyCoFolder { tcf_view = noView - , tcf_tyvar = \ _ tv -> freeHolesOfTy (tyVarKind tv) - , tcf_covar = \ _ cv -> freeHolesOfTy (varType cv) - , tcf_hole = \ _ h -> freeHolesOfHole h - , tcf_tycobinder = \ _ _ _ -> () } + Just (_co,holes) -> zonkRewriterSet holes } newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: ZonkM RewriterSet } @@ -641,11 +625,11 @@ unpackCoercionHole :: CoercionHole -> ZonkM Coercion unpackCoercionHole hole = do { contents <- unpackCoercionHole_maybe hole ; case contents of - Just co -> return co + Just (co,_) -> return co Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } -- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion) +unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe (Coercion,RewriterSet)) unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -488,8 +488,8 @@ zonkCoHole :: CoercionHole -> ZonkTcM Coercion zonkCoHole hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) = do { contents <- readTcRef ref ; case contents of - Just co -> do { co' <- zonkCoToCo co - ; lift $ liftZonkM $ checkCoercionHole cv co' } + Just (co,_) -> do { co' <- zonkCoToCo co + ; lift $ liftZonkM $ checkCoercionHole cv co' } -- This next case should happen only in the presence of -- (undeferred) type errors. Originally, I put in a panic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cf99a788eb64bf7289aa4fa0546a95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cf99a788eb64bf7289aa4fa0546a95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: T22859: Increase threadDelay for small machines
by Marge Bot (＠marge-bot) 15 Oct '25

15 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00 T22859: Increase threadDelay for small machines The previously used thread delay led to failures on my RISC-V test setups. - - - - - 14040f51 by Hai / @BestYeen at 2025-10-14T15:29:49-04:00 Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again. - - - - - 1defb8b3 by Hai / @BestYeen at 2025-10-14T15:29:55-04:00 Update occurrences of return to pure and add a sample for redefining :m to mean :main - - - - - 27731704 by Cheng Shao at 2025-10-14T15:29:56-04:00 testsuite: fix T3586 for non-SSE3 platforms `T3586.hs` contains `-fvia-C -optc-msse3` which I think is a best-effort basis to harvest the C compiler's auto vectorization optimizations via the C backend back when the test was added. The `-fvia-C` part is now a deprecated no-op because GHC can't fall back to the C backend on a non-unregisterised build, and `-optc-msse3` might actually cause the test to fail on non x86/x64 platforms, e.g. recent builds of wasi-sdk would report `wasm32-wasi-clang: error: unsupported option '-msse3' for target 'wasm32-unknown-wasi'`. So this patch cleans up this historical cruft. `-fvia-C` is removed, and `-optc-msse3` is only passed when cpuid contains `pni` (which indicates support of SSE3). - - - - - 7 changed files: - docs/users_guide/ghci.rst - m4/fptools_alex.m4 - m4/fptools_happy.m4 - testsuite/driver/cpu_features.py - testsuite/tests/perf/should_run/T3586.hs - testsuite/tests/perf/should_run/all.T - testsuite/tests/rts/T22859.hs Changes: ===================================== docs/users_guide/ghci.rst ===================================== @@ -403,7 +403,7 @@ it can be *instantiated* to ``IO a``. For example .. code-block:: none - ghci> return True + ghci> pure True True Furthermore, GHCi will print the result of the I/O action if (and only @@ -419,7 +419,7 @@ For example, remembering that ``putStrLn :: String -> IO ()``: ghci> putStrLn "hello" hello - ghci> do { putStrLn "hello"; return "yes" } + ghci> do { putStrLn "hello"; pure "yes" } hello "yes" @@ -443,12 +443,12 @@ prompt must be in the ``IO`` monad. .. code-block:: none - ghci> x <- return 42 + ghci> x <- pure 42 ghci> print x 42 ghci> -The statement ``x <- return 42`` means “execute ``return 42`` in the +The statement ``x <- pure 42`` means “execute ``pure 42`` in the ``IO`` monad, and bind the result to ``x``\ ”. We can then use ``x`` in future statements, for example to print it as we did above. @@ -2389,7 +2389,7 @@ commonly used commands. .. code-block:: none - ghci> let date _ = Data.Time.getZonedTime >>= print >> return "" + ghci> let date _ = Data.Time.getZonedTime >>= print >> pure "" ghci> :def date date ghci> :date 2017-04-10 12:34:56.93213581 UTC @@ -2399,16 +2399,16 @@ commonly used commands. .. code-block:: none - ghci> let mycd d = System.Directory.setCurrentDirectory d >> return "" + ghci> let mycd d = System.Directory.setCurrentDirectory d >> pure "" ghci> :def mycd mycd ghci> :mycd .. - Or I could define a simple way to invoke "``ghc --make Main``" + Or we could define a simple way to invoke "``ghc --make Main``" in the current directory: .. code-block:: none - ghci> :def make (\_ -> return ":! ghc --make Main") + ghci> :def make (\_ -> pure ":! ghc --make Main") We can define a command that reads GHCi input from a file. This might be useful for creating a set of bindings that we want to @@ -2430,6 +2430,15 @@ commonly used commands. a double colon (eg ``::load``). It's not possible to redefine the commands ``:{``, ``:}`` and ``:!``. + For historical reasons, ``:m`` in ghci is shorthand for ``:module``. + If we want to override that to mean ``:main``, in a way that also + works when the implicit Prelude is deactivated, we can do it like + this using ``:def!``: + + .. code-block:: none + + ghci> :def! m \_ -> Prelude.pure ":main" + .. ghci-cmd:: :delete; * | ⟨num⟩ ... Delete one or more breakpoints by number (use :ghci-cmd:`:show breaks` to @@ -2912,7 +2921,7 @@ commonly used commands. .. code-block:: none - *ghci> :def cond \expr -> return (":cmd if (" ++ expr ++ ") then return \"\" else return \":continue\"") + *ghci> :def cond \expr -> pure (":cmd if (" ++ expr ++ ") then pure \"\" else pure \":continue\"") *ghci> :set stop 0 :cond (x < 3) To ignore breakpoints for a specified number of iterations use ===================================== m4/fptools_alex.m4 ===================================== @@ -23,10 +23,16 @@ changequote([, ])dnl ]) if test ! -f compiler/GHC/Parser/Lexer.hs || test ! -f compiler/GHC/Cmm/Lexer.hs then + if test x"$fptools_cv_alex_version" != x; then + fptools_cv_alex_version_display="version $fptools_cv_alex_version"; + else + fptools_cv_alex_version_display="none"; + fi; + failure_msg="Alex version >= 3.2.6 && < 4 is required to compile GHC. (Found: $fptools_cv_alex_version_display)" FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[3.2.6], - [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[] + [AC_MSG_ERROR([$failure_msg])])[] FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-ge],[4.0.0], - [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[] + [AC_MSG_ERROR([$failure_msg])])[] fi AlexVersion=$fptools_cv_alex_version; AC_SUBST(AlexVersion) ===================================== m4/fptools_happy.m4 ===================================== @@ -13,8 +13,7 @@ AC_DEFUN([FPTOOLS_HAPPY], AC_SUBST(HappyCmd,$HAPPY) AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version, changequote(, )dnl -[ -if test x"$HappyCmd" != x; then +[if test x"$HappyCmd" != x; then fptools_cv_happy_version=`"$HappyCmd" -v | grep 'Happy Version' | sed -e 's/Happy Version $[^ ]*$.*/\1/g'` ; else @@ -24,7 +23,12 @@ changequote([, ])dnl ]) if test ! -f compiler/GHC/Parser.hs || test ! -f compiler/GHC/Cmm/Parser.hs then - failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.2 is required to compile GHC" + if test x"$fptools_cv_happy_version" != x; then + fptools_cv_happy_version_display="version $fptools_cv_happy_version"; + else + fptools_cv_happy_version_display="none"; + fi; + failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.2 is required to compile GHC. (Found: $fptools_cv_happy_version_display)" FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.20.0], [AC_MSG_ERROR([$failure_msg])])[] FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[1.21.0], @@ -32,7 +36,6 @@ then [AC_MSG_ERROR([$failure_msg])])[])[] FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[2.2.0], [AC_MSG_ERROR([$failure_msg])])[] - fi HappyVersion=$fptools_cv_happy_version; AC_SUBST(HappyVersion) ===================================== testsuite/driver/cpu_features.py ===================================== @@ -8,7 +8,7 @@ SUPPORTED_CPU_FEATURES = { # These aren't comprehensive; they are only CPU features that we care about # x86: - 'sse', 'sse2', 'sse3', 'ssse3', 'sse4_1', 'sse4_2', + 'sse', 'sse2', 'sse3', 'pni', 'ssse3', 'sse4_1', 'sse4_2', 'avx', 'avx2', 'avx512f', 'fma', 'popcnt', 'bmi1', 'bmi2' ===================================== testsuite/tests/perf/should_run/T3586.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fvia-C -optc-O3 -fexcess-precision -optc-msse3 #-} +{-# OPTIONS -optc-O3 -fexcess-precision #-} import Control.Monad.ST import Data.Array.ST ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -43,6 +43,7 @@ test('T3586', [collect_runtime_residency(2), collect_stats('bytes allocated', 5), only_ways(['normal']), + when(have_cpu_feature('pni') or have_cpu_feature('sse3'), extra_hc_opts('-optc-msse3')), ], compile_and_run, ['-O']) ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -42,7 +42,7 @@ main = do takeMVar started readMVar done hFlush stderr - threadDelay 1000 + threadDelay 50000 -- default behaviour: -- kill it after the limit is exceeded hPutStrLn stderr "default behaviour" @@ -68,5 +68,5 @@ main = do hPutStrLn stderr "kill and log" setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3") runWorker - threadDelay 1000 + threadDelay 50000 hPutStrLn stderr "done" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4aa6bc1006e4ca9206170274bdb94… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4aa6bc1006e4ca9206170274bdb94… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26166] WIP: more wasm fixes
by Cheng Shao (＠TerrorJack) 15 Oct '25

15 Oct '25

Cheng Shao pushed to branch wip/T26166 at Glasgow Haskell Compiler / GHC Commits: 677325ce by Cheng Shao at 2025-10-14T20:40:17+02:00 WIP: more wasm fixes - - - - - 4 changed files: - compiler/GHC/HsToCore/Foreign/Wasm.hs - rts/wasm/JSFFI.c - rts/wasm/scheduler.cmm - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/HsToCore/Foreign/Wasm.hs ===================================== @@ -664,7 +664,7 @@ dsWasmJSExport' sync m_fn_id co ext_name = do -- again here. Sync -> [finally_id, flushStdHandles_id] Async -> [top_handler_id, promiseRes_id] - extern_closure_decls = vcat $ map mk_extern_closure_decl gc_root_closures + extern_closure_decls = vcat $ map mk_extern_closure_decl $ top_handler_id : gc_root_closures cstub_attr = text "__attribute__" <> parens ===================================== rts/wasm/JSFFI.c ===================================== @@ -109,6 +109,9 @@ __attribute__((constructor(102))) static void __ghc_wasm_jsffi_init(void) { RtsConfig __conf = defaultRtsConfig; __conf.rts_opts_enabled = RtsOptsAll; __conf.rts_hs_main = false; +#if defined(__PIC__) + __conf.keep_cafs = 1; +#endif hs_init_ghc((int *)&argc, &argv, __conf); // See Note [threadDelay on wasm] for details. rts_JSFFI_flag = HS_BOOL_TRUE; ===================================== rts/wasm/scheduler.cmm ===================================== @@ -113,8 +113,8 @@ // JavaScript main thread. #define BUSY_YIELD_NS 15000000 -import CLOSURE ghczminternal_GHCziInternalziTuple_Z0T_closure; #if !defined(UnregisterisedCompiler) +import CLOSURE ghc_hs_iface; import CLOSURE stg_scheduler_loop_epoch; import CLOSURE stg_scheduler_loop_tid; #endif @@ -139,7 +139,7 @@ stg_scheduler_loopzh () // Only meant to be run from a "main thread" (aka bound to an InCall // frame), not from a forked thread! if (StgTSO_bound(CurrentTSO) == NULL) { - return (ghczminternal_GHCziInternalziTuple_Z0T_closure); + return (HsIface_Z0T_closure(W_[ghc_hs_iface])); } // Entering the scheduler loop for the first time. @@ -154,7 +154,7 @@ stg_scheduler_loopzh () // Someone else is running the loop, not my business anymore. if (I64[stg_scheduler_loop_tid] != StgTSO_id(CurrentTSO)) { - return (ghczminternal_GHCziInternalziTuple_Z0T_closure); + return (HsIface_Z0T_closure(W_[ghc_hs_iface])); } work: @@ -180,7 +180,7 @@ work: cleanup: I64[stg_scheduler_loop_tid] = 0 :: I64; - return (ghczminternal_GHCziInternalziTuple_Z0T_closure); + return (HsIface_Z0T_closure(W_[ghc_hs_iface])); } // After creating a new thread with only a stop frame on the stack, ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1100,22 +1100,11 @@ class DyLD { continue; } if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) { + init(); this.rts_init(); delete this.rts_init; - // At this point the RTS symbols in linear memory are fixed - // and constructors are run, especially the one in JSFFI.c - // that does GHC RTS initialization for any code that links - // JSFFI.o. Luckily no Haskell computation or gc has taken - // place yet, so we must set keepCAFs=1 right now! Otherwise, - // any BCO created by later TH splice or ghci expression may - // refer to any CAF that's not reachable from GC roots (here - // our only entry point is defaultServer) and the CAF could - // have been GC'ed! (#26106) - // - // We call it here instead of in RTS C code, since we only - // want keepCAFs=1 for ghci, not user code. - this.exportFuncs.setKeepCAFs(); + continue; } init(); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/677325ce2fcefb926a9143d8c707b13… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/677325ce2fcefb926a9143d8c707b13… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add submodules for template-haskell-lift and template-haskell-quasiquoter
by Marge Bot (＠marge-bot) 15 Oct '25

15 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1be30772 by Teo Camarasu at 2025-10-14T12:58:30-04:00 Add submodules for template-haskell-lift and template-haskell-quasiquoter These two new boot libraries expose stable subsets of the template-haskell interface. This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696 Work towards #25262 - - - - - 79e88cd9 by Sven Tennie at 2025-10-14T12:58:30-04:00 T22859: Increase threadDelay for small machines The previously used thread delay led to failures on my RISC-V test setups. - - - - - f923c64f by Hai / @BestYeen at 2025-10-14T12:58:37-04:00 Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again. - - - - - 9c13d7f9 by Hai / @BestYeen at 2025-10-14T12:58:43-04:00 Update occurrences of return to pure and add a sample for redefining :m to mean :main - - - - - f4aa6bc1 by Cheng Shao at 2025-10-14T12:58:44-04:00 testsuite: fix T3586 for non-SSE3 platforms `T3586.hs` contains `-fvia-C -optc-msse3` which I think is a best-effort basis to harvest the C compiler's auto vectorization optimizations via the C backend back when the test was added. The `-fvia-C` part is now a deprecated no-op because GHC can't fall back to the C backend on a non-unregisterised build, and `-optc-msse3` might actually cause the test to fail on non x86/x64 platforms, e.g. recent builds of wasi-sdk would report `wasm32-wasi-clang: error: unsupported option '-msse3' for target 'wasm32-unknown-wasi'`. So this patch cleans up this historical cruft. `-fvia-C` is removed, and `-optc-msse3` is only passed when cpuid contains `pni` (which indicates support of SSE3). - - - - - 14 changed files: - .gitmodules - docs/users_guide/ghci.rst - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - + libraries/template-haskell-lift - + libraries/template-haskell-quasiquoter - m4/fptools_alex.m4 - m4/fptools_happy.m4 - testsuite/driver/cpu_features.py - testsuite/tests/perf/should_run/T3586.hs - testsuite/tests/perf/should_run/all.T - testsuite/tests/rts/T22859.hs Changes: ===================================== .gitmodules ===================================== @@ -118,3 +118,9 @@ [submodule "libraries/file-io"] path = libraries/file-io url = https://gitlab.haskell.org/ghc/packages/file-io.git +[submodule "libraries/template-haskell-lift"] + path = libraries/template-haskell-lift + url = https://gitlab.haskell.org/ghc/template-haskell-lift.git +[submodule "libraries/template-haskell-quasiquoter"] + path = libraries/template-haskell-quasiquoter + url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git ===================================== docs/users_guide/ghci.rst ===================================== @@ -403,7 +403,7 @@ it can be *instantiated* to ``IO a``. For example .. code-block:: none - ghci> return True + ghci> pure True True Furthermore, GHCi will print the result of the I/O action if (and only @@ -419,7 +419,7 @@ For example, remembering that ``putStrLn :: String -> IO ()``: ghci> putStrLn "hello" hello - ghci> do { putStrLn "hello"; return "yes" } + ghci> do { putStrLn "hello"; pure "yes" } hello "yes" @@ -443,12 +443,12 @@ prompt must be in the ``IO`` monad. .. code-block:: none - ghci> x <- return 42 + ghci> x <- pure 42 ghci> print x 42 ghci> -The statement ``x <- return 42`` means “execute ``return 42`` in the +The statement ``x <- pure 42`` means “execute ``pure 42`` in the ``IO`` monad, and bind the result to ``x``\ ”. We can then use ``x`` in future statements, for example to print it as we did above. @@ -2389,7 +2389,7 @@ commonly used commands. .. code-block:: none - ghci> let date _ = Data.Time.getZonedTime >>= print >> return "" + ghci> let date _ = Data.Time.getZonedTime >>= print >> pure "" ghci> :def date date ghci> :date 2017-04-10 12:34:56.93213581 UTC @@ -2399,16 +2399,16 @@ commonly used commands. .. code-block:: none - ghci> let mycd d = System.Directory.setCurrentDirectory d >> return "" + ghci> let mycd d = System.Directory.setCurrentDirectory d >> pure "" ghci> :def mycd mycd ghci> :mycd .. - Or I could define a simple way to invoke "``ghc --make Main``" + Or we could define a simple way to invoke "``ghc --make Main``" in the current directory: .. code-block:: none - ghci> :def make (\_ -> return ":! ghc --make Main") + ghci> :def make (\_ -> pure ":! ghc --make Main") We can define a command that reads GHCi input from a file. This might be useful for creating a set of bindings that we want to @@ -2430,6 +2430,15 @@ commonly used commands. a double colon (eg ``::load``). It's not possible to redefine the commands ``:{``, ``:}`` and ``:!``. + For historical reasons, ``:m`` in ghci is shorthand for ``:module``. + If we want to override that to mean ``:main``, in a way that also + works when the implicit Prelude is deactivated, we can do it like + this using ``:def!``: + + .. code-block:: none + + ghci> :def! m \_ -> Prelude.pure ":main" + .. ghci-cmd:: :delete; * | ⟨num⟩ ... Delete one or more breakpoints by number (use :ghci-cmd:`:show breaks` to @@ -2912,7 +2921,7 @@ commonly used commands. .. code-block:: none - *ghci> :def cond \expr -> return (":cmd if (" ++ expr ++ ") then return \"\" else return \":continue\"") + *ghci> :def cond \expr -> pure (":cmd if (" ++ expr ++ ") then pure \"\" else pure \":continue\"") *ghci> :set stop 0 :cond (x < 3) To ignore breakpoints for a specified number of iterations use ===================================== hadrian/src/Packages.hs ===================================== @@ -9,7 +9,7 @@ module Packages ( ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, iserv, iservProxy, libffi, mtl, osString, parsec, pretty, primitive, process, remoteIserv, rts, - runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, + runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, timeout, transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, @@ -39,7 +39,7 @@ ghcPackages = , ghcCompact, ghcConfig, ghcExperimental, ghcHeap, ghcInternal, ghci, ghciWrapper, ghcPkg, ghcPrim , ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline, hsc2hs , hp2ps, hpc, hpcBin, integerGmp, iserv, libffi, mtl, osString - , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell + , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell, thLift, thQuasiquoter , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon @@ -56,7 +56,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count ghcCompact, ghcConfig, ghcExperimental, ghcHeap, ghci, ghcInternal, ghciWrapper, ghcPkg, ghcPrim, ghcToolchain, ghcToolchainBin, haddockLibrary, haddockApi, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, iserv, iservProxy, remoteIserv, libffi, mtl, - osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, + osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, transformers, unlit, unix, win32, xhtml, timeout, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace @@ -124,6 +124,8 @@ runGhc = util "runghc" semaphoreCompat = lib "semaphore-compat" stm = lib "stm" templateHaskell = lib "template-haskell" +thLift = lib "template-haskell-lift" +thQuasiquoter = lib "template-haskell-quasiquoter" terminfo = lib "terminfo" text = lib "text" time = lib "time" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -106,6 +106,8 @@ stage0Packages = do , runGhc , semaphoreCompat -- depends on , time -- depends on win32 + , thLift -- new library not yet present for boot compilers + , thQuasiquoter -- new library not yet present for boot compilers , unlit , if windowsHost then win32 else unix -- We must use the in-tree `Win32` as the version ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs ===================================== @@ -20,7 +20,7 @@ -- | This module gives the definition of the 'Lift' class. -- -- This is an internal module. --- Please import "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead! +-- Please import "Language.Haskell.TH.Lift", "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead! module GHC.Internal.TH.Lift ( Lift(..) @@ -71,6 +71,9 @@ import GHC.Internal.ForeignPtr -- > deriving Lift -- -- Representation-polymorphic since /template-haskell-2.16.0.0/. +-- +-- This is exposed both from the @template-haskell-lift@ and @template-haskell@ packages. +-- Consider importing it from the more stable @template-haskell-lift@ if you don't need the full breadth of the @template-haskell@ interface. class Lift (t :: TYPE r) where -- | Turn a value into a Template Haskell expression, suitable for use in -- a splice. ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs ===================================== @@ -31,6 +31,9 @@ import GHC.Internal.Base hiding (Type) -- @QuasiQuoter@ that is only intended to be used in certain splice -- contexts, the unused fields should just 'fail'. This is most easily -- accomplished using 'namedefaultQuasiQuoter' or 'defaultQuasiQuoter'. +-- +-- This is exposed both from the @template-haskell-quasiquoter@ and @template-haskell@ packages. +-- Consider importing it from the more stable @template-haskell-quasiquoter@ if you don't need the full breadth of the @template-haskell@ interface. data QuasiQuoter = QuasiQuoter { -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@ quoteExp :: String -> Q Exp, ===================================== libraries/template-haskell-lift ===================================== @@ -0,0 +1 @@ +Subproject commit e0b2a7eefcd1b7247af63ab4a691d3161eada284 ===================================== libraries/template-haskell-quasiquoter ===================================== @@ -0,0 +1 @@ +Subproject commit a47506eca032b139d9779fb8210d408c81d3fbd6 ===================================== m4/fptools_alex.m4 ===================================== @@ -23,10 +23,16 @@ changequote([, ])dnl ]) if test ! -f compiler/GHC/Parser/Lexer.hs || test ! -f compiler/GHC/Cmm/Lexer.hs then + if test x"$fptools_cv_alex_version" != x; then + fptools_cv_alex_version_display="version $fptools_cv_alex_version"; + else + fptools_cv_alex_version_display="none"; + fi; + failure_msg="Alex version >= 3.2.6 && < 4 is required to compile GHC. (Found: $fptools_cv_alex_version_display)" FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[3.2.6], - [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[] + [AC_MSG_ERROR([$failure_msg])])[] FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-ge],[4.0.0], - [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[] + [AC_MSG_ERROR([$failure_msg])])[] fi AlexVersion=$fptools_cv_alex_version; AC_SUBST(AlexVersion) ===================================== m4/fptools_happy.m4 ===================================== @@ -13,8 +13,7 @@ AC_DEFUN([FPTOOLS_HAPPY], AC_SUBST(HappyCmd,$HAPPY) AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version, changequote(, )dnl -[ -if test x"$HappyCmd" != x; then +[if test x"$HappyCmd" != x; then fptools_cv_happy_version=`"$HappyCmd" -v | grep 'Happy Version' | sed -e 's/Happy Version $[^ ]*$.*/\1/g'` ; else @@ -24,7 +23,12 @@ changequote([, ])dnl ]) if test ! -f compiler/GHC/Parser.hs || test ! -f compiler/GHC/Cmm/Parser.hs then - failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.2 is required to compile GHC" + if test x"$fptools_cv_happy_version" != x; then + fptools_cv_happy_version_display="version $fptools_cv_happy_version"; + else + fptools_cv_happy_version_display="none"; + fi; + failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.2 is required to compile GHC. (Found: $fptools_cv_happy_version_display)" FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.20.0], [AC_MSG_ERROR([$failure_msg])])[] FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[1.21.0], @@ -32,7 +36,6 @@ then [AC_MSG_ERROR([$failure_msg])])[])[] FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[2.2.0], [AC_MSG_ERROR([$failure_msg])])[] - fi HappyVersion=$fptools_cv_happy_version; AC_SUBST(HappyVersion) ===================================== testsuite/driver/cpu_features.py ===================================== @@ -8,7 +8,7 @@ SUPPORTED_CPU_FEATURES = { # These aren't comprehensive; they are only CPU features that we care about # x86: - 'sse', 'sse2', 'sse3', 'ssse3', 'sse4_1', 'sse4_2', + 'sse', 'sse2', 'sse3', 'pni', 'ssse3', 'sse4_1', 'sse4_2', 'avx', 'avx2', 'avx512f', 'fma', 'popcnt', 'bmi1', 'bmi2' ===================================== testsuite/tests/perf/should_run/T3586.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fvia-C -optc-O3 -fexcess-precision -optc-msse3 #-} +{-# OPTIONS -optc-O3 -fexcess-precision #-} import Control.Monad.ST import Data.Array.ST ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -43,6 +43,7 @@ test('T3586', [collect_runtime_residency(2), collect_stats('bytes allocated', 5), only_ways(['normal']), + when(have_cpu_feature('pni') or have_cpu_feature('sse3'), extra_hc_opts('-optc-msse3')), ], compile_and_run, ['-O']) ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -42,7 +42,7 @@ main = do takeMVar started readMVar done hFlush stderr - threadDelay 1000 + threadDelay 50000 -- default behaviour: -- kill it after the limit is exceeded hPutStrLn stderr "default behaviour" @@ -68,5 +68,5 @@ main = do hPutStrLn stderr "kill and log" setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3") runWorker - threadDelay 1000 + threadDelay 50000 hPutStrLn stderr "done" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90cde9c3c2627343034742cdab070d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90cde9c3c2627343034742cdab070d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26502] rts: Eliminate uses of implicit constant arrays
by Ben Gamari (＠bgamari) 15 Oct '25

15 Oct '25

Ben Gamari pushed to branch wip/T26502 at Glasgow Haskell Compiler / GHC Commits: 064107a5 by Ben Gamari at 2025-10-14T12:04:48-04:00 rts: Eliminate uses of implicit constant arrays Folding of `const`-sized variable-length arrays to a constant-length array is a gnu extension which clang complains about. Closes #26502. - - - - - 2 changed files: - rts/Printer.c - rts/posix/OSMem.c Changes: ===================================== rts/Printer.c ===================================== @@ -1033,8 +1033,8 @@ findPtr(P_ p, int follow) { uint32_t g, n; bdescr *bd; - const int arr_size = 1024; - StgPtr arr[arr_size]; +#define ARR_SIZE 1024 + StgPtr arr[ARR_SIZE]; int i = 0; searched = 0; @@ -1044,24 +1044,24 @@ findPtr(P_ p, int follow) // just before a block is used. for (n = 0; n < getNumCapabilities(); n++) { bd = nurseries[i].blocks; - i = findPtrBlocks(p,bd,arr,arr_size,i); - if (i >= arr_size) return; + i = findPtrBlocks(p,bd,arr,ARR_SIZE,i); + if (i >= ARR_SIZE) return; } #endif for (g = 0; g < RtsFlags.GcFlags.generations; g++) { bd = generations[g].blocks; - i = findPtrBlocks(p,bd,arr,arr_size,i); + i = findPtrBlocks(p,bd,arr,ARR_SIZE,i); bd = generations[g].large_objects; - i = findPtrBlocks(p,bd,arr,arr_size,i); - if (i >= arr_size) return; + i = findPtrBlocks(p,bd,arr,ARR_SIZE,i); + if (i >= ARR_SIZE) return; for (n = 0; n < getNumCapabilities(); n++) { i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list, - arr, arr_size, i); + arr, ARR_SIZE, i); i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd, - arr, arr_size, i); + arr, ARR_SIZE, i); } - if (i >= arr_size) return; + if (i >= ARR_SIZE) return; } if (follow && i == 1) { debugBelch("-->\n"); ===================================== rts/posix/OSMem.c ===================================== @@ -585,7 +585,7 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len) } #endif - const int MAX_ATTEMPTS = 256; +#define MAX_ATTEMPTS 256 void *bad_allocs[MAX_ATTEMPTS]; size_t bad_alloc_lens[MAX_ATTEMPTS]; memset(bad_allocs, 0, sizeof(void*) * MAX_ATTEMPTS); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/064107a57b90a2981049e3158b5904f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/064107a57b90a2981049e3158b5904f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26502
by Ben Gamari (＠bgamari) 15 Oct '25

15 Oct '25

Ben Gamari pushed new branch wip/T26502 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26502 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26166] fixup! rts: Avoid static symbol references to ghc-internal
by Rodrigo Mesquita (＠alt-romes) 14 Oct '25

14 Oct '25

Rodrigo Mesquita pushed to branch wip/T26166 at Glasgow Haskell Compiler / GHC Commits: aa4a109c by Rodrigo Mesquita at 2025-10-14T15:58:03+01:00 fixup! rts: Avoid static symbol references to ghc-internal - - - - - 1 changed file: - rts/include/stg/Prim.h Changes: ===================================== rts/include/stg/Prim.h ===================================== @@ -145,8 +145,6 @@ W_ hs_mulIntMayOflo(W_ a, W_ b); /* rts/prim/int64x2minmax and rts/prim/vectorQuotRem */ #if defined(__SSE2__) -#include <stdint.h> -#include <string.h> #include <emmintrin.h> __m128i hs_minInt64X2(__m128i, __m128i); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa4a109cff86a0dd851589aacc3f71d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa4a109cff86a0dd851589aacc3f71d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26484
by Ben Gamari (＠bgamari) 14 Oct '25

14 Oct '25

Ben Gamari pushed new branch wip/T26484 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26484 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26166] fixup! rts: Avoid static symbol references to ghc-internal
by Rodrigo Mesquita (＠alt-romes) 14 Oct '25

14 Oct '25

Rodrigo Mesquita pushed to branch wip/T26166 at Glasgow Haskell Compiler / GHC Commits: 23c18667 by Rodrigo Mesquita at 2025-10-14T15:30:44+01:00 fixup! rts: Avoid static symbol references to ghc-internal - - - - - 1 changed file: - rts/include/rts/Types.h Changes: ===================================== rts/include/rts/Types.h ===================================== @@ -13,9 +13,6 @@ #pragma once -#include <stddef.h> -#include <stdbool.h> - typedef struct StgClosure_ StgClosure; typedef struct StgInfoTable_ StgInfoTable; typedef struct StgTSO_ StgTSO; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23c1866749512248dde44efe0fd0b29… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23c1866749512248dde44efe0fd0b29… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: T22859: Increase threadDelay for small machines
by Marge Bot (＠marge-bot) 14 Oct '25

14 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00 T22859: Increase threadDelay for small machines The previously used thread delay led to failures on my RISC-V test setups. - - - - - 90cde9c3 by Rodrigo Mesquita at 2025-10-14T09:07:29-04:00 Move code-gen aux symbols from ghc-internal to rts These symbols were all previously defined in ghc-internal and made the dependency structure awkward, where the rts may refer to some of these symbols and had to work around that circular dependency the way described in #26166. Moreover, the code generator will produce code that uses these symbols! Therefore, they should be available in the rts: PRINCIPLE: If the code generator may produce code which uses this symbol, then it should be defined in the rts rather than, say, ghc-internal. That said, the main motivation is towards fixing #26166. Towards #26166. Pre-requisite of !14892 - - - - - 20 changed files: - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/ghc-internal.cabal.in - rts/RtsSymbols.c - rts/include/stg/Prim.h - libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c - libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c - libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c - libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c - libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c - libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c - libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c - libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c - libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c - libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c - libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c - libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c - libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c - rts/rts.cabal - testsuite/tests/rts/T22859.hs Changes: ===================================== compiler/GHC/CmmToAsm/Wasm/FromCmm.hs ===================================== @@ -438,7 +438,7 @@ lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable" -- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to --- @hs_mulIntMayOflo@ function in @ghc-prim/cbits/mulIntMayOflo@, +-- @hs_mulIntMayOflo@ function in @rts/prim/mulIntMayOflo@, -- otherwise it's quite non-trivial to implement as inline assembly. lower_MO_MulMayOflo :: CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w) ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -287,9 +287,6 @@ ghcInternalArgs = package ghcInternal ? do , builder (Cabal Flags) ? flag NeedLibatomic `cabalFlag` "need-atomic" - , builder (Cc CompileC) ? (not <$> flag CcLlvmBackend) ? - input "**/cbits/atomic.c" ? arg "-Wno-sync-nand" - ] -- | RTS-specific command line arguments. @@ -413,6 +410,9 @@ rtsPackageArgs = package rts ? do , input "**/RetainerProfile.c" ? flag CcLlvmBackend ? arg "-Wno-incompatible-pointer-types" + + , input "**/prim/atomic.c" ? (not <$> flag CcLlvmBackend) ? + arg "-Wno-sync-nand" ] mconcat ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -442,20 +442,7 @@ Library cbits/sysconf.c cbits/fs.c cbits/strerror.c - cbits/atomic.c - cbits/bswap.c - cbits/bitrev.c - cbits/clz.c - cbits/ctz.c cbits/debug.c - cbits/int64x2minmax.c - cbits/longlong.c - cbits/mulIntMayOflo.c - cbits/pdep.c - cbits/pext.c - cbits/popcnt.c - cbits/vectorQuotRem.c - cbits/word2float.c cbits/Stack_c.c cmm-sources: ===================================== rts/RtsSymbols.c ===================================== @@ -1016,6 +1016,116 @@ extern char **environ; #define RTS_FINI_ARRAY_SYMBOLS #endif +#define SymI_HasProtoAllSizes(symbol) \ + SymI_HasProto(symbol##8) \ + SymI_HasProto(symbol##16) \ + SymI_HasProto(symbol##32) \ + SymI_HasProto(symbol##64) + +#if !defined(arm_HOST_ARCH) +#define RTS_ATOMICS_SYMBOLS \ + SymI_HasProtoAllSizes(hs_atomic_add) \ + SymI_HasProtoAllSizes(hs_atomic_sub) \ + SymI_HasProtoAllSizes(hs_atomic_and) \ + SymI_HasProtoAllSizes(hs_atomic_nand) \ + SymI_HasProtoAllSizes(hs_atomic_or) \ + SymI_HasProtoAllSizes(hs_atomic_xor) \ + SymI_HasProtoAllSizes(hs_cmpxchg) \ + SymI_HasProtoAllSizes(hs_xchg) \ + SymI_HasProtoAllSizes(hs_atomicread) \ + SymI_HasProtoAllSizes(hs_atomicwrite) +#else +// No atomics on arm32. See e9abcad4cc3 +#define RTS_ATOMICS_SYMBOLS +#endif + +// In rts/longlong.c +#if WORD_SIZE_IN_BITS < 64 +#define RTS_SYMBOLS_LONGLONG \ + SymI_HasProto(hs_eq64) \ + SymI_HasProto(hs_ne64) \ + SymI_HasProto(hs_gtWord64) \ + SymI_HasProto(hs_geWord64) \ + SymI_HasProto(hs_ltWord64) \ + SymI_HasProto(hs_leWord64) \ + SymI_HasProto(hs_gtInt64) \ + SymI_HasProto(hs_geInt64) \ + SymI_HasProto(hs_ltInt64) \ + SymI_HasProto(hs_leInt64) \ + SymI_HasProto(hs_neg64) \ + SymI_HasProto(hs_add64) \ + SymI_HasProto(hs_sub64) \ + SymI_HasProto(hs_mul64) \ + SymI_HasProto(hs_remWord64) \ + SymI_HasProto(hs_quotWord64) \ + SymI_HasProto(hs_remInt64) \ + SymI_HasProto(hs_quotInt64) \ + SymI_HasProto(hs_and64) \ + SymI_HasProto(hs_or64) \ + SymI_HasProto(hs_xor64) \ + SymI_HasProto(hs_not64) \ + SymI_HasProto(hs_uncheckedShiftL64) \ + SymI_HasProto(hs_uncheckedShiftRL64) \ + SymI_HasProto(hs_uncheckedIShiftRA64) \ + SymI_HasProto(hs_intToInt64) \ + SymI_HasProto(hs_int64ToInt) \ + SymI_HasProto(hs_wordToWord64) \ + SymI_HasProto(hs_word64ToWord) +#else +#define RTS_SYMBOLS_LONGLONG +#endif + +// rts/prim/vectorQuotRem.c and rts/prim/int64x2minmax +#if defined(__SSE2__) +#define RTS_SYMBOLS_VECTORQUOTREM \ + SymI_HasProto(hs_quotInt8X16) \ + SymI_HasProto(hs_quotInt16X8) \ + SymI_HasProto(hs_quotInt32X4) \ + SymI_HasProto(hs_quotInt64X2) \ + SymI_HasProto(hs_quotWord8X16) \ + SymI_HasProto(hs_quotWord16X8) \ + SymI_HasProto(hs_quotWord32X4) \ + SymI_HasProto(hs_quotWord64X2) \ + SymI_HasProto(hs_remInt8X16) \ + SymI_HasProto(hs_remInt16X8) \ + SymI_HasProto(hs_remInt32X4) \ + SymI_HasProto(hs_remInt64X2) \ + SymI_HasProto(hs_remWord8X16) \ + SymI_HasProto(hs_remWord16X8) \ + SymI_HasProto(hs_remWord32X4) \ + SymI_HasProto(hs_remWord64X2) +#define RTS_SYMBOLS_INT64X2MINMAX \ + SymI_HasProto(hs_minInt64X2) \ + SymI_HasProto(hs_maxInt64X2) \ + SymI_HasProto(hs_minWord64X2) \ + SymI_HasProto(hs_maxWord64X2) +#else +#define RTS_SYMBOLS_VECTORQUOTREM +#define RTS_SYMBOLS_INT64X2MINMAX +#endif + +// Symbols on files in rts/prim/* +#define RTS_SYMBOLS_PRIM \ + RTS_ATOMICS_SYMBOLS \ + RTS_SYMBOLS_INT64X2MINMAX \ + RTS_SYMBOLS_LONGLONG \ + RTS_SYMBOLS_VECTORQUOTREM \ + SymI_HasProtoAllSizes(hs_bitrev) \ + SymI_HasProto(hs_bswap16) \ + SymI_HasProto(hs_bswap32) \ + SymI_HasProto(hs_bswap64) \ + SymI_HasProtoAllSizes(hs_clz) \ + SymI_HasProtoAllSizes(hs_ctz) \ + SymI_HasProto(hs_mulIntMayOflo) \ + SymI_HasProtoAllSizes(hs_pdep) \ + SymI_HasProtoAllSizes(hs_pext) \ + SymI_HasProtoAllSizes(hs_pext) \ + SymI_HasProto(hs_popcnt) \ + SymI_HasProtoAllSizes(hs_popcnt) \ + SymI_HasProto(hs_word2float32) \ + SymI_HasProto(hs_word2float64) + + /* entirely bogus claims about types of these symbols */ #define SymI_NeedsProto(vvv) extern void vvv(void); #define SymI_NeedsDataProto(vvv) extern StgWord vvv[]; @@ -1038,6 +1148,7 @@ RTS_ARCH_LIBGCC_SYMBOLS RTS_FINI_ARRAY_SYMBOLS RTS_LIBFFI_SYMBOLS RTS_ARM_OUTLINE_ATOMIC_SYMBOLS +RTS_SYMBOLS_PRIM #undef SymI_NeedsProto #undef SymI_NeedsDataProto @@ -1081,6 +1192,7 @@ RtsSymbolVal rtsSyms[] = { RTS_FINI_ARRAY_SYMBOLS RTS_LIBFFI_SYMBOLS RTS_ARM_OUTLINE_ATOMIC_SYMBOLS + RTS_SYMBOLS_PRIM SymI_HasDataProto(nonmoving_write_barrier_enabled) { 0, 0, STRENGTH_NORMAL, SYM_TYPE_CODE } /* sentinel */ }; ===================================== rts/include/stg/Prim.h ===================================== @@ -2,7 +2,10 @@ * * (c) The GHC Team, 2014-2014 * - * Declarations for C fallback primitives implemented by 'ghc-internal' package. + * This header collects the declarations for all the C fallback implementations + * used by the code generator to lower certain primops and sometimes by the RTS. + * + * Corresponding C files are in rts/prim/ * * Do not #include this file directly: #include "Rts.h" instead. * @@ -13,7 +16,7 @@ #pragma once -/* libraries/ghc-internal/cbits/atomic.c */ +/* rts/prim/atomic.c */ StgWord hs_atomic_add8(StgWord x, StgWord val); StgWord hs_atomic_add16(StgWord x, StgWord val); StgWord hs_atomic_add32(StgWord x, StgWord val); @@ -55,12 +58,12 @@ StgWord hs_xchg16(StgWord x, StgWord val); StgWord hs_xchg32(StgWord x, StgWord val); StgWord64 hs_xchg64(StgWord x, StgWord64 val); -/* libraries/ghc-internal/cbits/bswap.c */ +/* rts/prim/bswap.c */ StgWord16 hs_bswap16(StgWord16 x); StgWord32 hs_bswap32(StgWord32 x); StgWord64 hs_bswap64(StgWord64 x); -/* libraries/ghc-internal/cbits/bitrev.c +/* rts/prim/bitrev.c This was done as part of issue #16164. See Note [Bit reversal primop] for more details about the implementation.*/ StgWord hs_bitrev8(StgWord x); @@ -68,7 +71,7 @@ StgWord16 hs_bitrev16(StgWord16 x); StgWord32 hs_bitrev32(StgWord32 x); StgWord64 hs_bitrev64(StgWord64 x); -/* libraries/ghc-internal/cbits/longlong.c */ +/* rts/prim/longlong.c */ #if WORD_SIZE_IN_BITS < 64 StgInt hs_eq64 (StgWord64 a, StgWord64 b); StgInt hs_ne64 (StgWord64 a, StgWord64 b); @@ -101,41 +104,75 @@ StgWord64 hs_wordToWord64 (StgWord w); StgWord hs_word64ToWord (StgWord64 w); #endif -/* libraries/ghc-internal/cbits/pdep.c */ +/* rts/prim/pdep.c */ StgWord64 hs_pdep64(StgWord64 src, StgWord64 mask); StgWord hs_pdep32(StgWord src, StgWord mask); StgWord hs_pdep16(StgWord src, StgWord mask); StgWord hs_pdep8(StgWord src, StgWord mask); -/* libraries/ghc-internal/cbits/pext.c */ +/* rts/prim/pext.c */ StgWord64 hs_pext64(StgWord64 src, StgWord64 mask); StgWord hs_pext32(StgWord src, StgWord mask); StgWord hs_pext16(StgWord src, StgWord mask); StgWord hs_pext8(StgWord src, StgWord mask); -/* libraries/ghc-internal/cbits/popcnt.c */ +/* rts/prim/popcnt.c */ StgWord hs_popcnt8(StgWord x); StgWord hs_popcnt16(StgWord x); StgWord hs_popcnt32(StgWord x); StgWord hs_popcnt64(StgWord64 x); StgWord hs_popcnt(StgWord x); -/* libraries/ghc-internal/cbits/word2float.c */ +/* rts/prim/word2float.c */ StgFloat hs_word2float32(StgWord x); StgDouble hs_word2float64(StgWord x); -/* libraries/ghc-internal/cbits/clz.c */ +/* rts/prim/clz.c */ StgWord hs_clz8(StgWord x); StgWord hs_clz16(StgWord x); StgWord hs_clz32(StgWord x); StgWord hs_clz64(StgWord64 x); -/* libraries/ghc-internal/cbits/ctz.c */ +/* rts/prim/ctz.c */ StgWord hs_ctz8(StgWord x); StgWord hs_ctz16(StgWord x); StgWord hs_ctz32(StgWord x); StgWord hs_ctz64(StgWord64 x); +/* rts/prim/mulIntMayOflo.c */ +W_ hs_mulIntMayOflo(W_ a, W_ b); + + +/* rts/prim/int64x2minmax and rts/prim/vectorQuotRem */ +#if defined(__SSE2__) +#include <stdint.h> +#include <string.h> +#include <emmintrin.h> + +__m128i hs_minInt64X2(__m128i, __m128i); +__m128i hs_maxInt64X2(__m128i, __m128i); +__m128i hs_minWord64X2(__m128i, __m128i); +__m128i hs_maxWord64X2(__m128i, __m128i); + +__m128i hs_quotInt8X16(__m128i, __m128i); +__m128i hs_quotInt16X8(__m128i, __m128i); +__m128i hs_quotInt32X4(__m128i, __m128i); +__m128i hs_quotInt64X2(__m128i, __m128i); +__m128i hs_quotWord8X16(__m128i, __m128i); +__m128i hs_quotWord16X8(__m128i, __m128i); +__m128i hs_quotWord32X4(__m128i, __m128i); +__m128i hs_quotWord64X2(__m128i, __m128i); +__m128i hs_remInt8X16(__m128i, __m128i); +__m128i hs_remInt16X8(__m128i, __m128i); +__m128i hs_remInt32X4(__m128i, __m128i); +__m128i hs_remInt64X2(__m128i, __m128i); +__m128i hs_remWord8X16(__m128i, __m128i); +__m128i hs_remWord16X8(__m128i, __m128i); +__m128i hs_remWord32X4(__m128i, __m128i); +__m128i hs_remWord64X2(__m128i, __m128i); + +#endif + /* bitcasts, instead of creating a new C file we static inline these here. We * use __builtin_memcpy instead of memcpy from string.h to avoid function * prototype conflicts that occur in the C backend with the inclusion of ===================================== libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c ===================================== @@ -12,90 +12,66 @@ // FetchAddByteArrayOp_Int -extern StgWord hs_atomic_add8(StgWord x, StgWord val); -StgWord -hs_atomic_add8(StgWord x, StgWord val) +StgWord hs_atomic_add8(StgWord x, StgWord val) { return __sync_fetch_and_add((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_add16(StgWord x, StgWord val); -StgWord -hs_atomic_add16(StgWord x, StgWord val) +StgWord hs_atomic_add16(StgWord x, StgWord val) { return __sync_fetch_and_add((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_add32(StgWord x, StgWord val); -StgWord -hs_atomic_add32(StgWord x, StgWord val) +StgWord hs_atomic_add32(StgWord x, StgWord val) { return __sync_fetch_and_add((volatile StgWord32 *) x, (StgWord32) val); } -extern StgWord64 hs_atomic_add64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_add64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_add64(StgWord x, StgWord64 val) { return __sync_fetch_and_add((volatile StgWord64 *) x, val); } // FetchSubByteArrayOp_Int -extern StgWord hs_atomic_sub8(StgWord x, StgWord val); -StgWord -hs_atomic_sub8(StgWord x, StgWord val) +StgWord hs_atomic_sub8(StgWord x, StgWord val) { return __sync_fetch_and_sub((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_sub16(StgWord x, StgWord val); -StgWord -hs_atomic_sub16(StgWord x, StgWord val) +StgWord hs_atomic_sub16(StgWord x, StgWord val) { return __sync_fetch_and_sub((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_sub32(StgWord x, StgWord val); -StgWord -hs_atomic_sub32(StgWord x, StgWord val) +StgWord hs_atomic_sub32(StgWord x, StgWord val) { return __sync_fetch_and_sub((volatile StgWord32 *) x, (StgWord32) val); } -extern StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_sub64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val) { return __sync_fetch_and_sub((volatile StgWord64 *) x, val); } // FetchAndByteArrayOp_Int -extern StgWord hs_atomic_and8(StgWord x, StgWord val); -StgWord -hs_atomic_and8(StgWord x, StgWord val) +StgWord hs_atomic_and8(StgWord x, StgWord val) { return __sync_fetch_and_and((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_and16(StgWord x, StgWord val); -StgWord -hs_atomic_and16(StgWord x, StgWord val) +StgWord hs_atomic_and16(StgWord x, StgWord val) { return __sync_fetch_and_and((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_and32(StgWord x, StgWord val); -StgWord -hs_atomic_and32(StgWord x, StgWord val) +StgWord hs_atomic_and32(StgWord x, StgWord val) { return __sync_fetch_and_and((volatile StgWord32 *) x, (StgWord32) val); } -extern StgWord64 hs_atomic_and64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_and64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_and64(StgWord x, StgWord64 val) { return __sync_fetch_and_and((volatile StgWord64 *) x, val); } @@ -167,9 +143,7 @@ hs_atomic_and64(StgWord x, StgWord64 val) #pragma GCC diagnostic ignored "-Wsync-nand" #endif -extern StgWord hs_atomic_nand8(StgWord x, StgWord val); -StgWord -hs_atomic_nand8(StgWord x, StgWord val) +StgWord hs_atomic_nand8(StgWord x, StgWord val) { #if USE_SYNC_FETCH_AND_NAND return __sync_fetch_and_nand((volatile StgWord8 *) x, (StgWord8) val); @@ -178,9 +152,7 @@ hs_atomic_nand8(StgWord x, StgWord val) #endif } -extern StgWord hs_atomic_nand16(StgWord x, StgWord val); -StgWord -hs_atomic_nand16(StgWord x, StgWord val) +StgWord hs_atomic_nand16(StgWord x, StgWord val) { #if USE_SYNC_FETCH_AND_NAND return __sync_fetch_and_nand((volatile StgWord16 *) x, (StgWord16) val); @@ -189,9 +161,7 @@ hs_atomic_nand16(StgWord x, StgWord val) #endif } -extern StgWord hs_atomic_nand32(StgWord x, StgWord val); -StgWord -hs_atomic_nand32(StgWord x, StgWord val) +StgWord hs_atomic_nand32(StgWord x, StgWord val) { #if USE_SYNC_FETCH_AND_NAND return __sync_fetch_and_nand((volatile StgWord32 *) x, (StgWord32) val); @@ -200,9 +170,7 @@ hs_atomic_nand32(StgWord x, StgWord val) #endif } -extern StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_nand64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val) { #if USE_SYNC_FETCH_AND_NAND return __sync_fetch_and_nand((volatile StgWord64 *) x, val); @@ -215,96 +183,72 @@ hs_atomic_nand64(StgWord x, StgWord64 val) // FetchOrByteArrayOp_Int -extern StgWord hs_atomic_or8(StgWord x, StgWord val); -StgWord -hs_atomic_or8(StgWord x, StgWord val) +StgWord hs_atomic_or8(StgWord x, StgWord val) { return __sync_fetch_and_or((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_or16(StgWord x, StgWord val); -StgWord -hs_atomic_or16(StgWord x, StgWord val) +StgWord hs_atomic_or16(StgWord x, StgWord val) { return __sync_fetch_and_or((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_or32(StgWord x, StgWord val); -StgWord -hs_atomic_or32(StgWord x, StgWord val) +StgWord hs_atomic_or32(StgWord x, StgWord val) { return __sync_fetch_and_or((volatile StgWord32 *) x, (StgWord32) val); } -extern StgWord64 hs_atomic_or64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_or64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_or64(StgWord x, StgWord64 val) { return __sync_fetch_and_or((volatile StgWord64 *) x, val); } // FetchXorByteArrayOp_Int -extern StgWord hs_atomic_xor8(StgWord x, StgWord val); -StgWord -hs_atomic_xor8(StgWord x, StgWord val) +StgWord hs_atomic_xor8(StgWord x, StgWord val) { return __sync_fetch_and_xor((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_xor16(StgWord x, StgWord val); -StgWord -hs_atomic_xor16(StgWord x, StgWord val) +StgWord hs_atomic_xor16(StgWord x, StgWord val) { return __sync_fetch_and_xor((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_xor32(StgWord x, StgWord val); -StgWord -hs_atomic_xor32(StgWord x, StgWord val) +StgWord hs_atomic_xor32(StgWord x, StgWord val) { return __sync_fetch_and_xor((volatile StgWord32 *) x, (StgWord32) val); } -extern StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val); -StgWord64 -hs_atomic_xor64(StgWord x, StgWord64 val) +StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val) { return __sync_fetch_and_xor((volatile StgWord64 *) x, val); } // CasByteArrayOp_Int -extern StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new); -StgWord -hs_cmpxchg8(StgWord x, StgWord old, StgWord new) +StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new) { StgWord8 expected = (StgWord8) old; __atomic_compare_exchange_n((StgWord8 *) x, &expected, (StgWord8) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST); return expected; } -extern StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new); -StgWord -hs_cmpxchg16(StgWord x, StgWord old, StgWord new) +StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new) { StgWord16 expected = (StgWord16) old; __atomic_compare_exchange_n((StgWord16 *) x, &expected, (StgWord16) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST); return expected; } -extern StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new); -StgWord -hs_cmpxchg32(StgWord x, StgWord old, StgWord new) +StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new) { StgWord32 expected = (StgWord32) old; __atomic_compare_exchange_n((StgWord32 *) x, &expected, (StgWord32) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST); return expected; } -extern StgWord64 hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new); -StgWord64 -hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new) +StgWord64 hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new) { StgWord64 expected = (StgWord64) old; __atomic_compare_exchange_n((StgWord64 *) x, &expected, (StgWord64) new, false, __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST); @@ -313,31 +257,23 @@ hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new) // Atomic exchange operations -extern StgWord hs_xchg8(StgWord x, StgWord val); -StgWord -hs_xchg8(StgWord x, StgWord val) +StgWord hs_xchg8(StgWord x, StgWord val) { return (StgWord) __atomic_exchange_n((StgWord8 *) x, (StgWord8) val, __ATOMIC_SEQ_CST); } -extern StgWord hs_xchg16(StgWord x, StgWord val); -StgWord -hs_xchg16(StgWord x, StgWord val) +StgWord hs_xchg16(StgWord x, StgWord val) { return (StgWord) __atomic_exchange_n((StgWord16 *)x, (StgWord16) val, __ATOMIC_SEQ_CST); } -extern StgWord hs_xchg32(StgWord x, StgWord val); -StgWord -hs_xchg32(StgWord x, StgWord val) +StgWord hs_xchg32(StgWord x, StgWord val) { return (StgWord) __atomic_exchange_n((StgWord32 *) x, (StgWord32) val, __ATOMIC_SEQ_CST); } //GCC provides this even on 32bit, but StgWord is still 32 bits. -extern StgWord64 hs_xchg64(StgWord x, StgWord64 val); -StgWord64 -hs_xchg64(StgWord x, StgWord64 val) +StgWord64 hs_xchg64(StgWord x, StgWord64 val) { return (StgWord64) __atomic_exchange_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST); } @@ -352,30 +288,22 @@ hs_xchg64(StgWord x, StgWord64 val) // primitives which the GCC documentation claims "usually" implies a full // barrier. -extern StgWord hs_atomicread8(StgWord x); -StgWord -hs_atomicread8(StgWord x) +StgWord hs_atomicread8(StgWord x) { return __atomic_load_n((StgWord8 *) x, __ATOMIC_SEQ_CST); } -extern StgWord hs_atomicread16(StgWord x); -StgWord -hs_atomicread16(StgWord x) +StgWord hs_atomicread16(StgWord x) { return __atomic_load_n((StgWord16 *) x, __ATOMIC_SEQ_CST); } -extern StgWord hs_atomicread32(StgWord x); -StgWord -hs_atomicread32(StgWord x) +StgWord hs_atomicread32(StgWord x) { return __atomic_load_n((StgWord32 *) x, __ATOMIC_SEQ_CST); } -extern StgWord64 hs_atomicread64(StgWord x); -StgWord64 -hs_atomicread64(StgWord x) +StgWord64 hs_atomicread64(StgWord x) { return __atomic_load_n((StgWord64 *) x, __ATOMIC_SEQ_CST); } @@ -384,30 +312,22 @@ hs_atomicread64(StgWord x) // Implies a full memory barrier (see compiler/GHC/Builtin/primops.txt.pp) // __ATOMIC_SEQ_CST: Full barrier (see hs_atomicread8 above). -extern void hs_atomicwrite8(StgWord x, StgWord val); -void -hs_atomicwrite8(StgWord x, StgWord val) +void hs_atomicwrite8(StgWord x, StgWord val) { __atomic_store_n((StgWord8 *) x, (StgWord8) val, __ATOMIC_SEQ_CST); } -extern void hs_atomicwrite16(StgWord x, StgWord val); -void -hs_atomicwrite16(StgWord x, StgWord val) +void hs_atomicwrite16(StgWord x, StgWord val) { __atomic_store_n((StgWord16 *) x, (StgWord16) val, __ATOMIC_SEQ_CST); } -extern void hs_atomicwrite32(StgWord x, StgWord val); -void -hs_atomicwrite32(StgWord x, StgWord val) +void hs_atomicwrite32(StgWord x, StgWord val) { __atomic_store_n((StgWord32 *) x, (StgWord32) val, __ATOMIC_SEQ_CST); } -extern void hs_atomicwrite64(StgWord x, StgWord64 val); -void -hs_atomicwrite64(StgWord x, StgWord64 val) +void hs_atomicwrite64(StgWord x, StgWord64 val) { __atomic_store_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST); } ===================================== libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c ===================================== @@ -27,7 +27,6 @@ For more information on how the below bit-twiddling functions came to be, see page. */ -extern StgWord hs_bitrev8(StgWord x); StgWord hs_bitrev8(StgWord x) { @@ -37,7 +36,6 @@ hs_bitrev8(StgWord x) return x; } -extern StgWord16 hs_bitrev16(StgWord16 x); StgWord16 hs_bitrev16(StgWord16 x) { @@ -48,7 +46,6 @@ hs_bitrev16(StgWord16 x) return x; } -extern StgWord32 hs_bitrev32(StgWord32 x); StgWord32 hs_bitrev32(StgWord32 x) { @@ -60,7 +57,6 @@ hs_bitrev32(StgWord32 x) return x; } -extern StgWord64 hs_bitrev64(StgWord64 x); StgWord64 hs_bitrev64(StgWord64 x) { ===================================== libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c ===================================== @@ -1,13 +1,11 @@ #include "Rts.h" -extern StgWord16 hs_bswap16(StgWord16 x); StgWord16 hs_bswap16(StgWord16 x) { return ((x >> 8) | (x << 8)); } -extern StgWord32 hs_bswap32(StgWord32 x); StgWord32 hs_bswap32(StgWord32 x) { @@ -15,7 +13,6 @@ hs_bswap32(StgWord32 x) (x << 24) | ((x & 0xff00) << 8)); } -extern StgWord64 hs_bswap64(StgWord64 x); StgWord64 hs_bswap64(StgWord64 x) { ===================================== libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c ===================================== ===================================== libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c ===================================== ===================================== libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c ===================================== @@ -1,4 +1,5 @@ #if defined(__SSE2__) +#include "Rts.h" #include <stdint.h> #include <string.h> #include <emmintrin.h> ===================================== libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c ===================================== ===================================== libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c ===================================== ===================================== libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c ===================================== ===================================== libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c ===================================== ===================================== libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c ===================================== @@ -13,14 +13,12 @@ static const unsigned char popcount_tab[] = 3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,4,5,5,6,5,6,6,7,5,6,6,7,6,7,7,8, }; -extern StgWord hs_popcnt8(StgWord x); StgWord hs_popcnt8(StgWord x) { return popcount_tab[(unsigned char)x]; } -extern StgWord hs_popcnt16(StgWord x); StgWord hs_popcnt16(StgWord x) { @@ -28,7 +26,6 @@ hs_popcnt16(StgWord x) popcount_tab[(unsigned char)(x >> 8)]; } -extern StgWord hs_popcnt32(StgWord x); StgWord hs_popcnt32(StgWord x) { @@ -38,7 +35,6 @@ hs_popcnt32(StgWord x) popcount_tab[(unsigned char)(x >> 24)]; } -extern StgWord hs_popcnt64(StgWord64 x); StgWord hs_popcnt64(StgWord64 x) { @@ -54,7 +50,6 @@ hs_popcnt64(StgWord64 x) #if WORD_SIZE_IN_BITS == 32 -extern StgWord hs_popcnt(StgWord x); StgWord hs_popcnt(StgWord x) { @@ -66,7 +61,6 @@ hs_popcnt(StgWord x) #elif WORD_SIZE_IN_BITS == 64 -extern StgWord hs_popcnt(StgWord x); StgWord hs_popcnt(StgWord x) { ===================================== libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c ===================================== @@ -1,4 +1,5 @@ #if defined(__SSE2__) +#include "Rts.h" #include <stdint.h> #include <string.h> #include <emmintrin.h> ===================================== libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c ===================================== @@ -1,13 +1,11 @@ #include "Rts.h" -extern StgFloat hs_word2float32(StgWord x); StgFloat hs_word2float32(StgWord x) { return x; } -extern StgDouble hs_word2float64(StgWord x); StgDouble hs_word2float64(StgWord x) { ===================================== rts/rts.cabal ===================================== @@ -529,6 +529,19 @@ library sm/Storage.c sm/Sweep.c fs.c + prim/atomic.c + prim/bitrev.c + prim/bswap.c + prim/clz.c + prim/ctz.c + prim/int64x2minmax.c + prim/longlong.c + prim/mulIntMayOflo.c + prim/pdep.c + prim/pext.c + prim/popcnt.c + prim/vectorQuotRem.c + prim/word2float.c -- I wish we had wildcards..., this would be: -- *.c hooks/**/*.c sm/**/*.c eventlog/**/*.c linker/**/*.c ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -42,7 +42,7 @@ main = do takeMVar started readMVar done hFlush stderr - threadDelay 1000 + threadDelay 50000 -- default behaviour: -- kill it after the limit is exceeded hPutStrLn stderr "default behaviour" @@ -68,5 +68,5 @@ main = do hPutStrLn stderr "kill and log" setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3") runWorker - threadDelay 1000 + threadDelay 50000 hPutStrLn stderr "done" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7deec054e6e55f101a032138d8bfa6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7deec054e6e55f101a032138d8bfa6… You're receiving this email because of your account on gitlab.haskell.org.

1 0