Simon Peyton Jones pushed to branch wip/T27724 at Glasgow Haskell Compiler / GHC Commits: 9cb0b3e3 by Simon Peyton Jones at 2026-10-13T12:08:17+01:00 More wibbles - - - - - 5 changed files: - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs Changes: ===================================== compiler/GHC/Builtin/WiredIn/Ids.hs ===================================== @@ -247,17 +247,19 @@ seqId = pcRepPolyId seqName ty concs info -- see Note [seqId magic] -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + -- NB: Uses a=alphaTyVar, b=rrPolyTyVar2 + -- Can't use rrPolyTyVar1 because that is called 'a' too. Sigh. ty = - mkInfForAllTy runtimeRep1TyVar - $ mkSpecForAllTys [alphaTyVar, rrPolyTyVar1] - $ mkVisFunTyMany alphaTy (mkVisFunTyMany rrPolyTy1 rrPolyTy1) + mkInfForAllTy runtimeRep2TyVar + $ mkSpecForAllTys [alphaTyVar, rrPolyTyVar2] + $ mkVisFunTyMany alphaTy (mkVisFunTyMany rrPolyTy2 rrPolyTy2) - [x,y] = mkTemplateLocals [alphaTy, rrPolyTy1] - rhs = mkLams ([runtimeRep1TyVar, alphaTyVar, rrPolyTyVar1, x, y]) $ - Case (Var x) x rrPolyTy1 [Alt DEFAULT [] (Var y)] + [x,y] = mkTemplateLocals [alphaTy, rrPolyTy2] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, rrPolyTyVar2, x, y]) $ + Case (Var x) x rrPolyTy2 [Alt DEFAULT [] (Var y)] concs = mkRepPolyIdConcreteTyVars - [ ((rrPolyTy1, mkArgPos 1 Top), runtimeRep1TyVar)] + [ ((rrPolyTy2, mkArgPos 2 Top), runtimeRep2TyVar)] arity = 2 ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1228,18 +1228,8 @@ simplExprF1 env (App fun arg) cont = do { cont' <- pushAppCont env fun arg cont ; simplExprF env fun cont' } simplExprF1 env (Cast body co) cont - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} - simplCoercion env co - - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont -- See Note [Optimising reflexivity] - else pushCast env co1 cont - -- True <=> co1 is optimised - - ; {-#SCC "simplCast-simplExprF" #-} - simplExprF env body cont1 } - + = do { cont1 <- pushInCast env co cont + ; simplExprF env body cont1 } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1710,7 +1700,7 @@ on each successive composition -- that's at least quadratic. So: unfolding (seInlineDepth > 0), then instead of /optimising/ it again, just /substitute/ which is cheaper. See `simplCoercion`. -* In `pushCast` if we combine this new coercion with an existing one, +* In `pushOutCast` if we combine this new coercion with an existing one, we build a CastIt for (co1 ; co2) with sc_opt=False. * When unpacking a CastIt, in `rebuild`, we optimise the (presumably @@ -1724,7 +1714,7 @@ on each successive composition -- that's at least quadratic. So: Note [The sc_cast field of ApplyToVal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the `ApplyToVal` case of `pushCast` we want to push an `OutCoercion` into the +In the `ApplyToVal` case of `pushOutCast` we want to push an `OutCoercion` into the argument. But the argument may or may not have been simplified (see Note [StaticEnv]) so we definitely can't just wrap the cast around the argument. Instead we store it in the `sc_cast` field -- this is the whole reason for the `sc_cast` field. @@ -1755,14 +1745,25 @@ addCastMCo (MCo co) cont = CastIt { sc_co = co, sc_opt = False, sc_cont = cont } pushCastMCo :: SimplEnv -> MOutCoercion -> SimplCont -> SimplM SimplCont pushCastMCo _env MRefl cont = return cont -pushCastMCo env (MCo co) cont = pushCast env co cont +pushCastMCo env (MCo co) cont = pushOutCast env co cont + +pushInCast :: SimplEnv -> InCoercion -> SimplCont -> SimplM SimplCont +pushInCast env co cont + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} + simplCoercion env co + + ; if isReflCo co1 + then return cont -- See Note [Optimising reflexivity] + else {-#SCC "simplCast-addCoerce" #-} + pushOutCast env co1 cont + } -pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont -pushCast env co cont +pushOutCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont +pushOutCast env co cont = go co True cont where - -- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) + -- ToDo: pushOutCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) -- will do lots of unnecessary work. go :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont go co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] @@ -2294,7 +2295,7 @@ simplOutExpr env expr cont | Cast e co <- expr -- The inlined expression may be (x |> co) -- and the cast may cancel with `cont` - = do { cont' <- pushCast env co cont + = do { cont' <- pushOutCast env co cont ; simplOutExpr env e cont' } | (Var v, args) <- collectArgs expr @@ -2384,7 +2385,7 @@ simplOutId env noinline_fun cont = do { -- Push any arguments in `the_call` onto `encl_app_cont` let push_args :: InExpr -> SimplCont -> SimplM (InExpr, SimplCont) -- push_args just pushes multiple arguments onto the continuation - push_args (Cast f co) cont = do { cont' <- pushCast arg_se co cont + push_args (Cast f co) cont = do { cont' <- pushInCast arg_se co cont ; push_args f cont' } push_args (App f a) cont = do { cont' <- pushAppCont arg_se f a cont ; push_args f cont' } ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1265,28 +1265,37 @@ isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey isLazyExpr _ = False eliminateMagicCall :: Id -> [ArgInfo] -> Maybe (CoreExpr, [ArgInfo]) -eliminateMagicCall f (AIApp Type{} : AIApp arg : args) - | f `hasKey` lazyIdKey = Just (arg,args) - -- Replace (lazy a) with a, and - -- See Note [lazyId magic] in GHC.Types.Id.Make - | f `hasKey` nospecIdKey = Just (arg,args) - -- Replace (nospec a) with a - -- See Note [nospecId magic] in GHC.Types.Id.Make - -eliminateMagicCall f (AIApp Type{} : AIApp (Type arg_ty) : rest_args) +eliminateMagicCall f all_args + -- Replace (lazy a) with a, and + -- See Note [lazyId magic] in GHC.Types.Id.Make + | f `hasKey` lazyIdKey + , AIApp Type{} : AIApp arg : args <- all_args + = Just (arg,args) + + -- Replace (nospec a) with a + -- See Note [nospecId magic] in GHC.Types.Id.Make + | f `hasKey` nospecIdKey + , AIApp Type{} : AIApp arg : args <- all_args + = Just (arg,args) + + -- Replace (noinline a) with a + -- See Note [noinlineId magic] in GHC.Types.Id.Make | isNoinlineId f - = case rest_args of - (AIApp arg : args) -> Just (arg, args) - -- Replace (noinline a) with a - -- See Note [noinlineId magic] in GHC.Types.Id.Make - - _ -> Just (Lam x (Var x), rest_args) - -- Unsaturated (noinline @rep @ty) generates a lambda - where - x = mkTemplateLocal 0 arg_ty + = case all_args of + AIApp Type{} : AIApp (Type {}) : AIApp arg : args + -> -- noinline @rep @ty e --> e + Just (arg,args) -- Applied to a value argument + + AIApp Type{} : AIApp (Type arg_ty) : args + -> -- noinline @rep @ty --> \(x:ty).x + Just (Lam x (Var x), args) -- Type args only, make a lambda + where + x = mkTemplateLocal 0 arg_ty + _ -> pprPanic "Un-applied noinline" (ppr all_args) -eliminateMagicCall _ _ = Nothing + | otherwise + = Nothing {- Note [runRW magic] ~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} @@ -336,6 +337,12 @@ import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export import GHC.Internal.Tuple (maxTupleSize) import GHC.Internal.Box (Box) +{- ********************************************************************** +* * +* Some list functions +* * +********************************************************************** -} + -- | 'the' ensures that all the elements of the list are identical -- and then returns that unique element the :: Eq a => [a] -> a @@ -369,8 +376,11 @@ groupByFB c n eq xs0 = groupByFBCore xs0 where (ys, zs) = span (eq x) xs --- ----------------------------------------------------------------------------- --- tracing +{- ********************************************************************** +* * +* Tracing +* * +********************************************************************** -} traceEvent :: String -> IO () traceEvent = GHC.Internal.Debug.Trace.traceEventIO @@ -398,6 +408,11 @@ data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr ) +{- ********************************************************************** +* * +* Mutable variables and arrays +* * +********************************************************************** -} -- | An implementation of the old @atomicModifyMutVar#@ primop in -- terms of the new 'atomicModifyMutVar2#' primop, for backwards ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -40,6 +41,13 @@ module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(. import GHC.Internal.Prim (State#, realWorld#, RealWorld, Int#) import GHC.Internal.Types +{- ********************************************************************** +* * +* inline and noinline + +* * +********************************************************************** -} + -- | The call @inline f@ arranges that @f@ is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the -- right-hand side of @f@'s definition. This allows the programmer to @@ -73,10 +81,18 @@ noinline :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a {-# NOINLINE noinline #-} -- See Note [noinlineId magic] in GHC.Builtin.WiredIn.Ids -noinline = noinline -- Never called, eliminated in CorePrep - -- We can't conveniently call `error` here because - -- GHC.Internal.Err depends on GHC.Internal.Magic.noinline! - -- Hence this silly loop. +noinline = case () of {} + -- `noinline` should never be called -- it is eliminated in CorePrep + -- We can't conveniently call 'error' here, so we sneakly use an empty case + -- case () of {} + -- which expands to a call to GHC.Internal.Control.Exception.Base.patError + + +{- ********************************************************************** +* * +* lazy +* * +********************************************************************** -} -- | The 'lazy' function restrains strictness analysis a little. The -- call @lazy e@ means the same as @e@, but 'lazy' has a magical @@ -104,6 +120,12 @@ lazy x = x -- Result: happiness +{- ********************************************************************** +* * +* oneShot +* * +********************************************************************** -} + -- | The 'oneShot' function can be used to give a hint to the compiler that its -- argument will be called at most once, which may (or may not) enable certain -- optimizations. It can be useful to improve the performance of code in continuation @@ -122,6 +144,13 @@ oneShot f = f -- Implementation note: This is wired in in GHC.Types.Id.Make, so the code here is -- mostly there to have a place for the documentation. + +{- ********************************************************************** +* * +* runRW# +* * +********************************************************************** -} + -- | Apply a function to a @'State#' 'RealWorld'@ token. When manually applying -- a function to `realWorld#`, it is necessary to use @NOINLINE@ to prevent -- semantically undesirable floating. `runRW#` is inlined, but only very late @@ -136,6 +165,13 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# + +{- ********************************************************************** +* * +* DataToTag and dataToTag# +* * +********************************************************************** -} + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors @@ -154,6 +190,13 @@ type DataToTag :: forall {lev :: Levity}. TYPE (BoxedRep lev) -> Constraint class DataToTag a where dataToTag# :: a -> Int# + +{- ********************************************************************** +* * +* considerAccessible +* * +********************************************************************** -} + -- | Semantically, @considerAccessible = True@. But it has special meaning -- to the pattern-match checker, which will never flag the clause in which -- 'considerAccessible' occurs as a guard as redundant or inaccessible. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9cb0b3e3648a3e644a8780e111e12774... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9cb0b3e3648a3e644a8780e111e12774... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help