- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/26635] hadrian: Don't include the package hash in the haddock directory
by Zubin (＠wz1000) 31 Mar '26

31 Mar '26

Zubin pushed to branch wip/26635 at Glasgow Haskell Compiler / GHC Commits: b14f8557 by Zubin Duggal at 2026-03-31T11:06:16+05:30 hadrian: Don't include the package hash in the haddock directory Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html` The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not part of a standard cabal substitution. Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it. Fixes #26635 - - - - - 4 changed files: - hadrian/bindist/Makefile - hadrian/src/CommandLine.hs - hadrian/src/Context.hs - hadrian/src/Settings/Builders/Cabal.hs Changes: ===================================== hadrian/bindist/Makefile ===================================== @@ -205,7 +205,7 @@ update_package_db: install_bin install_lib $(INSTALL_DATA) mk/system-cxx-std-lib-1.0.conf "$(DESTDIR)$(ActualLibsDir)/package.conf.d" @echo "Updating the package DB" $(foreach p, $(PKG_CONFS),\ - $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/.conf//g'))) + $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/-[0-9a-zA-Z]*\.conf$$//'))) '$(DESTDIR)$(ActualBinsDir)/$(CrossCompilePrefix)ghc-pkg' --global-package-db "$(DESTDIR)$(ActualLibsDir)/package.conf.d" recache .PHONY: install_mingw ===================================== hadrian/src/CommandLine.hs ===================================== @@ -114,7 +114,7 @@ data DocArgs = DocArgs } deriving (Eq, Show) defaultDocArgs :: DocArgs -defaultDocArgs = DocArgs { docsBaseUrl = "../%pkgid%" } +defaultDocArgs = DocArgs { docsBaseUrl = "../%pkg%" } readConfigure :: Either String (CommandLineArgs -> CommandLineArgs) readConfigure = Left "hadrian --configure has been deprecated (see #20167). Please run ./boot; ./configure manually" ===================================== hadrian/src/Context.hs ===================================== @@ -120,7 +120,9 @@ pkgSetupConfigFile context = pkgSetupConfigDir context <&> (-/- "setup-config") pkgHaddockFile :: Context -> Action FilePath pkgHaddockFile Context {..} = do root <- buildRoot - version <- pkgUnitId stage package + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + version <- pkgSimpleIdentifier package return $ root -/- "doc/html/libraries" -/- version -/- pkgName package <.> "haddock" -- | Path to the registered ghc-pkg library file of a given 'Context', e.g.: ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -83,6 +83,9 @@ commonCabalArgs :: Stage -> Args commonCabalArgs stage = do pkg <- getPackage package_id <- expr $ pkgUnitId stage pkg + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + package_simple_id <- expr $ pkgSimpleIdentifier pkg let prefix = "${pkgroot}" ++ (if windowsHost then "" else "/..") mconcat [ -- Don't strip libraries when cross compiling. -- TODO: We need to set @--with-strip=(stripCmdPath :: Action FilePath)@, @@ -110,7 +113,7 @@ commonCabalArgs stage = do -- -- This doesn't hold if we move the @doc@ folder anywhere else. , arg "--htmldir" - , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_id + , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_simple_id -- These trigger a need on each dependency, so every important to need -- them in parallel or it linearises the build of Ghc and GhcPkg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b14f855709525859abced979857308b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b14f855709525859abced979857308b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/romes/27131
by Rodrigo Mesquita (＠alt-romes) 31 Mar '26

31 Mar '26

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

1 0

[Git][ghc/ghc][wip/T26831] 3 commits: Refactor eta-expansion in Prep
by Simon Peyton Jones (＠simonpj) 31 Mar '26

31 Mar '26

Simon Peyton Jones pushed to branch wip/T26831 at Glasgow Haskell Compiler / GHC Commits: f7d18c8d by Simon Peyton Jones at 2026-03-31T13:19:11+01:00 Refactor eta-expansion in Prep The Prep pass does eta-expansion but I found cases where it was doing bad things. So I refactored and simplified it quite a bit. In the new design * There is no distinction between `rhs` and `body`; in particular, lambdas can now appear anywhere, rather than just as the RHS of a let-binding. * This change led to a significant simplification of Prep, and a more straightforward explanation of eta-expansion. See the new Note [Eta expansion] * The consequences is that CoreToStg needs to handle naked lambdas. This is very easy; but it does need a unique supply, which forces some simple refactoring. Having a unique supply to hand is probably a good thing anyway. - - - - - cad8a1e5 by Simon Peyton Jones at 2026-03-31T13:19:11+01:00 Clarify Note [Interesting dictionary arguments] Ticket #26831 ended up concluding that the code for GHC.Core.Opt.Specialise.interestingDict was good, but the commments were a bit inadequate. This commit improves the comments slightly. - - - - - 1cd8fe23 by Simon Peyton Jones at 2026-03-31T13:19:11+01:00 Make inlining a bit more eager for overloaded functions If we have f d = ... (class-op d x y) ... we should be eager to inline `f`, because that may change the higher order call (class-op d x y) into a call to a statically known function. See the discussion on #26831. Even though this does a bit /more/ inlining, compile times decrease by an average of 0.4%. Compile time changes: DsIncompleteRecSel3(normal) 431,786,104 -2.2% ManyAlternatives(normal) 670,883,768 -1.6% ManyConstructors(normal) 3,758,493,832 -2.6% GOOD MultilineStringsPerf(normal) 29,900,576 -2.8% T14052Type(ghci) 1,047,600,848 -1.2% T17836(normal) 392,852,328 -5.2% T18478(normal) 442,785,768 -1.4% T21839c(normal) 341,536,992 -14.1% GOOD T3064(normal) 174,086,152 +5.3% BAD T5631(normal) 506,867,800 +1.0% hard_hole_fits(normal) 209,530,736 -1.3% info_table_map_perf(normal) 19,523,093,184 -1.2% parsing001(normal) 377,810,528 -1.1% pmcOrPats(normal) 60,075,264 -0.5% geo. mean -0.4% minimum -14.1% maximum +5.3% Runtime changes haddock.Cabal(normal) 27,351,988,792 -0.7% haddock.base(normal) 26,997,212,560 -0.6% haddock.compiler(normal) 219,531,332,960 -1.0% Metric Decrease: ManyConstructors T17949 T21839c Metric Increase: T3064 - - - - - 18 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - testsuite/tests/arityanal/should_compile/Arity01.stderr - testsuite/tests/arityanal/should_compile/Arity05.stderr - testsuite/tests/arityanal/should_compile/Arity08.stderr - testsuite/tests/arityanal/should_compile/Arity11.stderr - testsuite/tests/arityanal/should_compile/Arity14.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -807,16 +807,23 @@ the former has an additional type binder. Hmmm.... Note [Eta expanding primops] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - STG requires that primop applications be saturated. This makes code generation significantly simpler since otherwise we would need to define a calling convention for curried applications that can accommodate representation polymorphism. -To ensure saturation, CorePrep eta expands all primop applications as -described in Note [Eta expansion of hasNoBinding things in CorePrep] in +To ensure saturation, CorePrep eta expands all primop applications +as described in Note [Eta expansion of unsaturated calls] in GHC.Core.Prep. +Side note: this decision is somewhat in flux: see comments with `hasNoBinding`. +The question is: do we generate a trivial wrapper for each primop + (+#) x y = (+#) x y +and now we can call that wrapper unsaturated. But in practice we +might never call it because in practice Prep eta-expands all partial +applications! + + Historical Note: For a short period around GHC 8.8 we rewrote unsaturated primop applications to ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2551,9 +2551,6 @@ This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand a PAP. If eta-expanding is bad, then eta-reducing is good! -Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep -Note [No eta reduction needed in rhsToBody]. - But note that we don't want to eta-reduce \x y. f <expensive> x y to ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -3247,9 +3247,14 @@ case we can clearly specialise. But there are wrinkles: (ID6) The Main Plan says that it's worth specialising if the argument is an application of a dictionary contructor. But what if the dictionary has no methods? Then we - gain nothing by specialising, unless the /superclasses/ are interesting. A case - in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class - with N superclasses and no methods. + gain nothing by specialising, unless the /superclasses/ are interesting. + + So if there are no methods, we recursively call `interestingDict` on the + superclasses. Why recurse? If we have + \d1 d2. f (CTuple d1 d2) + If `d1 and `d2` are uninteresting dictionaries, then so is (CTuple d1 d2). + (Remember: a constraint tuple is just a class with N superclasses and no methods.) + See discussion on #26831. (ID7) A unary (single-method) class is currently represented by (meth |> co). We will unwrap the cast (see (ID5)) and then want to reply "yes" if the method ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -165,6 +165,7 @@ computeCbvInfo fun_id rhs map mkMark val_args cbv_bndr | any isMarkedCbv cbv_marks + -- isMarkedCbv: see (CBV2) in Note [CBV Function Ids: overview] = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks -- seqList: avoid retaining the original rhs @@ -176,6 +177,7 @@ computeCbvInfo fun_id rhs -- We don't set CBV marks on functions which take unboxed tuples or sums as -- arguments. Doing so would require us to compute the result of unarise -- here in order to properly determine argument positions at runtime. + -- See (CBV1) in Note [CBV Function Ids: overview] -- -- In practice this doesn't matter much. Most "interesting" functions will -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -779,22 +779,28 @@ litSize _other = 0 -- Must match size of nullary constructors classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize -- See (IA1) in Note [Interesting arguments] in GHC.Core.Opt.Simplify.Utils -classOpSize opts cls top_args args - | isUnaryClass cls - = sizeZero -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon - | otherwise - = case args of - [] -> sizeZero - (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0 +classOpSize _opts _cls _top_args [] + = sizeZero -- A non-applied classop +classOpSize opts cls top_args (dict_arg:other_val_args) + = SizeIs size (arg_discount dict_arg) 0 where - size other_args = 20 + (10 * length other_args) + size | isUnaryClass cls = 0 -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon + | otherwise = 20 + (10 * length other_val_args) -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function - -- The actual discount is rather arbitrarily chosen - arg_discount (Var dict) | dict `elem` top_args - = unitBag (dict, unfoldingDictDiscount opts) - arg_discount _ = emptyBag + arg_discount (Cast arg _co) = arg_discount arg + arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount) + arg_discount _ = emptyBag + + -- If we have (class-op d arg1 .. argn) then it's super-good to inline + -- to expose `d`; not only can we do the dictionary selection + -- (class-op d), but that will likely expose a lambda which we can then + -- apply. In that case (n > 0), we add `unfoldingFunAppDiscount`. + -- See the discussion on #26831, esp "Delicate inlining". + dict_discount + | null other_val_args = unfoldingDictDiscount opts + | otherwise = unfoldingDictDiscount opts + unfoldingFunAppDiscount opts -- | The size of a function call callSize ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -39,6 +39,8 @@ import GHC.Types.Basic ( Arity, TypeOrConstraint(..) ) import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.IPE +import GHC.Types.Unique.Supply +import GHC.Types.Unique import GHC.Unit.Module import GHC.Platform ( Platform ) @@ -49,297 +51,309 @@ import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic +import GHC.Data.FastString import Control.Monad (ap) --- Note [Live vs free] --- ~~~~~~~~~~~~~~~~~~~ --- --- The two are not the same. Liveness is an operational property rather --- than a semantic one. A variable is live at a particular execution --- point if it can be referred to directly again. In particular, a dead --- variable's stack slot (if it has one): --- --- - should be stubbed to avoid space leaks, and --- - may be reused for something else. --- --- There ought to be a better way to say this. Here are some examples: --- --- let v = [q] \[x] -> e --- in --- ...v... (but no q's) --- --- Just after the `in', v is live, but q is dead. If the whole of that --- let expression was enclosed in a case expression, thus: --- --- case (let v = [q] \[x] -> e in ...v...) of --- alts[...q...] --- --- (ie `alts' mention `q'), then `q' is live even after the `in'; because --- we'll return later to the `alts' and need it. --- --- Let-no-escapes make this a bit more interesting: --- --- let-no-escape v = [q] \ [x] -> e --- in --- ...v... --- --- Here, `q' is still live at the `in', because `v' is represented not by --- a closure but by the current stack state. In other words, if `v' is --- live then so is `q'. Furthermore, if `e' mentions an enclosing --- let-no-escaped variable, then its free variables are also live if `v' is. +{- Note [Live vs free] +~~~~~~~~~~~~~~~~~~~~~~ +The two are not the same. Liveness is an operational property rather +than a semantic one. A variable is live at a particular execution +point if it can be referred to directly again. In particular, a dead +variable's stack slot (if it has one): --- Note [What are these SRTs all about?] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider the Core program, --- --- fibs = go 1 1 --- where go a b = let c = a + c --- in c : go b c --- add x = map (\y -> x*y) fibs --- --- In this case we have a CAF, 'fibs', which is quite large after evaluation and --- has only one possible user, 'add'. Consequently, we want to ensure that when --- all references to 'add' die we can garbage collect any bit of 'fibs' that we --- have evaluated. --- --- However, how do we know whether there are any references to 'fibs' still --- around? Afterall, the only reference to it is buried in the code generated --- for 'add'. The answer is that we record the CAFs referred to by a definition --- in its info table, namely a part of it known as the Static Reference Table --- (SRT). --- --- Since SRTs are so common, we use a special compact encoding for them in: we --- produce one table containing a list of CAFs in a module and then include a --- bitmap in each info table describing which entries of this table the closure --- references. --- --- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. + - should be stubbed to avoid space leaks, and + - may be reused for something else. --- Note [What is a non-escaping let] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- NB: Nowadays this is recognized by the occurrence analyser by turning a --- "non-escaping let" into a join point. The following is then an operational --- account of join points. --- --- Consider: --- --- let x = fvs \ args -> e --- in --- if ... then x else --- if ... then x else ... --- --- `x' is used twice (so we probably can't unfold it), but when it is --- entered, the stack is deeper than it was when the definition of `x' --- happened. Specifically, if instead of allocating a closure for `x', --- we saved all `x's fvs on the stack, and remembered the stack depth at --- that moment, then whenever we enter `x' we can simply set the stack --- pointer(s) to these remembered (compile-time-fixed) values, and jump --- to the code for `x'. --- --- All of this is provided x is: --- 1. non-updatable; --- 2. guaranteed to be entered before the stack retreats -- ie x is not --- buried in a heap-allocated closure, or passed as an argument to --- something; --- 3. all the enters have exactly the right number of arguments, --- no more no less; --- 4. all the enters are tail calls; that is, they return to the --- caller enclosing the definition of `x'. --- --- Under these circumstances we say that `x' is non-escaping. --- --- An example of when (4) does not hold: --- --- let x = ... --- in case x of ...alts... --- --- Here, `x' is certainly entered only when the stack is deeper than when --- `x' is defined, but here it must return to ...alts... So we can't just --- adjust the stack down to `x''s recalled points, because that would lost --- alts' context. --- --- Things can get a little more complicated. Consider: --- --- let y = ... --- in let x = fvs \ args -> ...y... --- in ...x... --- --- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a --- non-escaping way in ...y..., then `y' is non-escaping. --- --- `x' can even be recursive! Eg: --- --- letrec x = [y] \ [v] -> if v then x True else ... --- in --- ...(x b)... +There ought to be a better way to say this. Here are some examples: --- Note [Cost-centre initialization plan] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, --- and the fields were then fixed by a separate pass `stgMassageForProfiling`. --- We now initialize these correctly. The initialization works like this: --- --- - For non-top level bindings always use `currentCCS`. --- --- - For top-level bindings, check if the binding is a CAF --- --- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF --- and use it. Note that these new cost centres need to be --- collected to be able to generate cost centre initialization --- code, so `coreToTopStgRhs` now returns `CollectedCCs`. --- --- If -fcaf-all is not enabled, use "all CAFs" cost centre. --- --- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor --- do we set CCCS from it; so we just slam in --- dontCareCostCentre. - --- Note [Coercion tokens] --- ~~~~~~~~~~~~~~~~~~~~~~ --- In coreToStgArgs, we drop type arguments completely, but we replace --- coercions with a special coercionToken# placeholder. Why? Consider: --- --- f :: forall a. Int ~# Bool -> a --- f = /\a. \(co :: Int ~# Bool) -> error "impossible" --- --- If we erased the coercion argument completely, we’d end up with just --- f = error "impossible", but then f `seq` () would be ⊥! --- --- This is an artificial example, but back in the day we *did* treat --- coercion lambdas like type lambdas, and we had bug reports as a --- result. So now we treat coercion lambdas like value lambdas, but we --- treat coercions themselves as zero-width arguments — coercionToken# --- has representation VoidRep — which gets the best of both worlds. --- --- (For the gory details, see also the (unpublished) paper, “Practical --- aspects of evidence-based compilation in System FC.”) + let v = [q] \[x] -> e + in + ...v... (but no q's) --- Note [Saturation of data constructors in STG] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We guarantee that `StgConApp` is an exactly-saturated application of a data --- constructor worker. --- --- * If the data constructor is /under/-saturated we just fall through to build --- a `StgApp`. Remember, data constructor workers have a regular top-level definition --- (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply --- that function. --- --- * If the data constructor is /over/-saturated, which can happen (see #23865) we again --- fall through to `StgApp`. That will fail horribly at runtime (by applying data --- constructor to an argument) but it should be in dead code, and at least the compiler --- itself won't crash. (We could inject an error-thunk instead.) +Just after the `in', v is live, but q is dead. If the whole of that +let expression was enclosed in a case expression, thus: + + case (let v = [q] \[x] -> e in ...v...) of + alts[...q...] + +(ie `alts' mention `q'), then `q' is live even after the `in'; because +we'll return later to the `alts' and need it. + +Let-no-escapes make this a bit more interesting: + + let-no-escape v = [q] \ [x] -> e + in + ...v... + +Here, `q' is still live at the `in', because `v' is represented not by +a closure but by the current stack state. In other words, if `v' is +live then so is `q'. Furthermore, if `e' mentions an enclosing +let-no-escaped variable, then its free variables are also live if `v' is. + +Note [What are these SRTs all about?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the Core program, + + fibs = go 1 1 + where go a b = let c = a + c + in c : go b c + add x = map (\y -> x*y) fibs + +In this case we have a CAF, 'fibs', which is quite large after evaluation and +has only one possible user, 'add'. Consequently, we want to ensure that when +all references to 'add' die we can garbage collect any bit of 'fibs' that we +have evaluated. + +However, how do we know whether there are any references to 'fibs' still +around? Afterall, the only reference to it is buried in the code generated +for 'add'. The answer is that we record the CAFs referred to by a definition +in its info table, namely a part of it known as the Static Reference Table +(SRT). +Since SRTs are so common, we use a special compact encoding for them in: we +produce one table containing a list of CAFs in a module and then include a +bitmap in each info table describing which entries of this table the closure +references. + +See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. + +Note [What is a non-escaping let] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +NB: Nowadays this is recognized by the occurrence analyser by turning a +"non-escaping let" into a join point. The following is then an operational +account of join points. + +Consider: + + let x = fvs \ args -> e + in + if ... then x else + if ... then x else ... + +`x' is used twice (so we probably can't unfold it), but when it is +entered, the stack is deeper than it was when the definition of `x' +happened. Specifically, if instead of allocating a closure for `x', +we saved all `x's fvs on the stack, and remembered the stack depth at +that moment, then whenever we enter `x' we can simply set the stack +pointer(s) to these remembered (compile-time-fixed) values, and jump +to the code for `x'. + +All of this is provided x is: + 1. non-updatable; + 2. guaranteed to be entered before the stack retreats -- ie x is not + buried in a heap-allocated closure, or passed as an argument to + something; + 3. all the enters have exactly the right number of arguments, + no more no less; + 4. all the enters are tail calls; that is, they return to the + caller enclosing the definition of `x'. + +Under these circumstances we say that `x' is non-escaping. + +An example of when (4) does not hold: + + let x = ... + in case x of ...alts... + +Here, `x' is certainly entered only when the stack is deeper than when +`x' is defined, but here it must return to ...alts... So we can't just +adjust the stack down to `x''s recalled points, because that would lost +alts' context. + +Things can get a little more complicated. Consider: + + let y = ... + in let x = fvs \ args -> ...y... + in ...x... + +Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a +non-escaping way in ...y..., then `y' is non-escaping. + +`x' can even be recursive! Eg: + + letrec x = [y] \ [v] -> if v then x True else ... + in + ...(x b)... + +Note [Cost-centre initialization plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, +and the fields were then fixed by a separate pass `stgMassageForProfiling`. +We now initialize these correctly. The initialization works like this: + + - For non-top level bindings always use `currentCCS`. + + - For top-level bindings, check if the binding is a CAF + + - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF + and use it. Note that these new cost centres need to be + collected to be able to generate cost centre initialization + code, so `coreToTopStgRhs` now returns `CollectedCCs`. + + If -fcaf-all is not enabled, use "all CAFs" cost centre. + + - Non-CAF: Top-level (static) data is not counted in heap profiles; nor + do we set CCCS from it; so we just slam in + dontCareCostCentre. + +Note [Coercion tokens] +~~~~~~~~~~~~~~~~~~~~~~ +In coreToStgArgs, we drop type arguments completely, but we replace +coercions with a special coercionToken# placeholder. Why? Consider: + + f :: forall a. Int ~# Bool -> a + f = /\a. \(co :: Int ~# Bool) -> error "impossible" + +If we erased the coercion argument completely, we’d end up with just +f = error "impossible", but then f `seq` () would be ⊥! + +This is an artificial example, but back in the day we *did* treat +coercion lambdas like type lambdas, and we had bug reports as a +result. So now we treat coercion lambdas like value lambdas, but we +treat coercions themselves as zero-width arguments — coercionToken# +has representation VoidRep — which gets the best of both worlds. + +(For the gory details, see also the (unpublished) paper, “Practical +aspects of evidence-based compilation in System FC.”) + +Note [Saturation of data constructors in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We guarantee that `StgConApp` is an exactly-saturated application of a data +constructor worker. + +* If the data constructor is /under/-saturated we just fall through to build + a `StgApp`. Remember, data constructor workers have a regular top-level definition + (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply + that function. + +* If the data constructor is /over/-saturated, which can happen (see #23865) we again + fall through to `StgApp`. That will fail horribly at runtime (by applying data + constructor to an argument) but it should be in dead code, and at least the compiler + itself won't crash. (We could inject an error-thunk instead.) + +Note [Naked lambdas in coreToStgExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = case x of + True -> \y. y+x + False -> blah +If `f` is not eta expanded (which would have happened in Prep if it was +going to happen at all, the code for f must allocate a closure for the +(\y. y+x). So the STG code we want has + + True -> let pap = \y. y+x + in pap + +The Lam case of `coreToStgExpr` deals with adding this `StgLet`. It's the +main reason we need a unique supply in the monad. + +Historical note: in the past, Prep guaranteed there would be no such naked +lambdas, so we didn't need a unique supply at all. But that proved too hard +in the end (see Note [Eta expansion and the CorePrep invariants]) so we +just deal with it here; it's very easy. +-} -- -------------------------------------------------------------- -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- -coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram - -> ([StgTopBinding], InfoTableProvMap, CollectedCCs) -coreToStg opts@CoreToStgOpts - { coreToStg_ways = ways - , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs - , coreToStg_InfoTableMap = opt_InfoTableMap - , coreToStg_stgDebugOpts = stgDebugOpts - } this_mod ml pgm - = (pgm'', denv, final_ccs) +coreToStg :: CoreToStgOpts -> Module -> ModLocation + -> CoreProgram + -> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs) +coreToStg opts this_mod ml pgm + = do { us <- mkSplitUniqSupply StgTag + ; let (_, (local_ccs, local_cc_stacks), pgm') + = initCts opts us $ + coreTopBindsToStg opts this_mod emptyCollectedCCs pgm + + -- See Note [Mapping Info Tables to Source Positions] + (!pgm'', !denv) + | opt_InfoTableMap + = collectDebugInformation stgDebugOpts ml pgm' + | otherwise = (pgm', emptyInfoTableProvMap) + + final_ccs + | prof && opt_AutoSccsOnIndividualCafs + = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC + | prof + = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) + | otherwise + = emptyCollectedCCs + + ; return (pgm'', denv, final_ccs) } where - (_, (local_ccs, local_cc_stacks), pgm') - = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm - - -- See Note [Mapping Info Tables to Source Positions] - (!pgm'', !denv) - | opt_InfoTableMap - = collectDebugInformation stgDebugOpts ml pgm' - | otherwise = (pgm', emptyInfoTableProvMap) + CoreToStgOpts { coreToStg_ways = ways + , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs + , coreToStg_InfoTableMap = opt_InfoTableMap + , coreToStg_stgDebugOpts = stgDebugOpts } + = opts prof = hasWay ways WayProf - - final_ccs - | prof && opt_AutoSccsOnIndividualCafs - = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC - | prof - = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) - | otherwise - = emptyCollectedCCs - (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod coreTopBindsToStg :: CoreToStgOpts -> Module - -> IdEnv HowBound -- environment for the bindings -> CollectedCCs -> CoreProgram - -> (IdEnv HowBound, CollectedCCs, [StgTopBinding]) + -> CtsM (IdEnv HowBound, CollectedCCs, [StgTopBinding]) + +coreTopBindsToStg _ _ ccs [] + = do { env <- getCtsEnv + ; return (env, ccs, []) } -coreTopBindsToStg _ _ env ccs [] - = (env, ccs, []) -coreTopBindsToStg opts this_mod env ccs (b:bs) +coreTopBindsToStg opts this_mod ccs (b:bs) | NonRec _ rhs <- b, isTyCoArg rhs - = coreTopBindsToStg opts this_mod env1 ccs1 bs + = coreTopBindsToStg opts this_mod ccs bs | otherwise - = (env2, ccs2, b':bs') - where - (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b - (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs + = do { (env1, ccs1, b' ) <- coreTopBindToStg opts this_mod ccs b + ; (env2, ccs2, bs') <- setCtsEnv env1 $ + coreTopBindsToStg opts this_mod ccs1 bs + ; return (env2, ccs2, b':bs') } coreTopBindToStg :: CoreToStgOpts -> Module - -> IdEnv HowBound -> CollectedCCs -> CoreBind - -> (IdEnv HowBound, CollectedCCs, StgTopBinding) + -> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding) -coreTopBindToStg _ _ env ccs (NonRec id e) +coreTopBindToStg _ _ ccs (NonRec id e) | Just str <- exprIsTickedString_maybe e -- top-level string literal -- See Note [Core top-level string literals] in GHC.Core - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet 0 - in (env', ccs, StgTopStringLit id str) - -coreTopBindToStg opts@CoreToStgOpts - { coreToStg_platform = platform - } this_mod env ccs (NonRec id rhs) - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet $! manifestArity rhs - - (ccs', (id', stg_rhs)) = - initCts platform env $ - coreToTopStgRhs opts this_mod ccs (id,rhs) - - bind = StgTopLifted $ StgNonRec id' stg_rhs - in - -- NB: previously the assertion printed 'rhs' and 'bind' - -- as well as 'id', but that led to a black hole - -- where printing the assertion error tripped the - -- assertion again! - (env', ccs', bind) - -coreTopBindToStg opts@CoreToStgOpts - { coreToStg_platform = platform - } this_mod env ccs (Rec pairs) + = do { env <- getCtsEnv + ; let env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet 0 + ; return (env', ccs, StgTopStringLit id str) } + +coreTopBindToStg opts this_mod ccs (NonRec id rhs) + = do { (ccs', (id', stg_rhs)) <- coreToTopStgRhs opts this_mod ccs (id,rhs) + + ; env <- getCtsEnv + ; let env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet $! manifestArity rhs + bind = StgTopLifted $ StgNonRec id' stg_rhs + ; return (env', ccs', bind) } + +coreTopBindToStg opts this_mod ccs (Rec pairs) = assert (not (null pairs)) $ - let - extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) - | (b, rhs) <- pairs ] - env' = extendVarEnvList env extra_env' - - -- generate StgTopBindings and CAF cost centres created for CAFs - (ccs', stg_rhss) - = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs - bind = StgTopLifted $ StgRec stg_rhss - in - (env', ccs', bind) + do { env <- getCtsEnv + ; let extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' + + -- Generate StgTopBindings and CAF cost centres created for CAFs + ; (ccs', stg_rhss) <- setCtsEnv env' $ + mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs + ; let bind = StgTopLifted $ StgRec stg_rhss + + ; return (env', ccs', bind) } coreToTopStgRhs :: CoreToStgOpts @@ -420,16 +434,24 @@ coreToStgExpr expr@(App _ _) res_ty = exprType expr (app_head, args, ticks) = myCollectArgs expr res_ty -coreToStgExpr expr@(Lam _ _) - = let - (args, body) = myCollectBinders expr - in - case filterStgBinders args of - - [] -> coreToStgExpr body - - _ -> pprPanic "coretoStgExpr" $ - text "Unexpected value lambda:" $$ ppr expr +coreToStgExpr expr@(Lam {}) + | null val_bndrs + = coreToStgExpr body + | otherwise + = -- See Note [Naked lambdas in coreToStgExpr] + do { body' <- extendVarEnvCts [ (a, LambdaBound) | a <- val_bndrs ] $ + coreToStgExpr body + ; uniq <- getCtsUnique + ; let body_ty = exprType body + fun_ty = mkLamTypes val_bndrs body_ty + -- This type is a bit ill-formed but it doesn't matter + rhs = StgRhsClosure noExtFieldSilent currentCCS + ReEntrant val_bndrs body' body_ty + tmp_fun = mkSysLocal (fsLit "pap") uniq ManyTy fun_ty + ; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $ + StgApp tmp_fun []) } + where + (val_bndrs, body) = myCollectBinders NotJoinPoint expr coreToStgExpr (Tick tick expr) = do @@ -634,8 +656,13 @@ coreToStgArgs (arg : args) = do -- Non-type argument stg_arg_rep = stgArgRep arg' bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) - warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) + -- Yikes! This assert FAILS in tests T13658, T14779b + -- It has been so for ages, but without the "() <-" it was lazily dropped + -- Hence commenting it out: see #27132 + -- massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) + + () <- warnPprTraceM bad_args + "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) return (arg' : stg_args, ticks' ++ ticks) @@ -710,12 +737,11 @@ coreToStgRhs (bndr, rhs) = do -- coreToStgExpr that can handle value lambdas. coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs coreToMkStgRhs bndr expr = do - let (args, body) = myCollectBinders expr - let args' = filterStgBinders args - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do + let (bndrs, body) = myCollectBinders (idJoinPointHood bndr) expr + extendVarEnvCts [ (a, LambdaBound) | a <- bndrs ] $ do body' <- coreToStgExpr body let mk_rhs = MkStgRhs - { rhs_args = args' + { rhs_args = bndrs , rhs_expr = body' , rhs_type = exprType body , rhs_is_join = isJoinId bndr @@ -733,7 +759,7 @@ coreToMkStgRhs bndr expr = do newtype CtsM a = CtsM { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs -> IdEnv HowBound - -> a + -> UniqSM a } deriving (Functor) @@ -769,20 +795,22 @@ data LetInfo -- The std monad functions: -initCts :: Platform -> IdEnv HowBound -> CtsM a -> a -initCts platform env m = unCtsM m platform env - +initCts :: CoreToStgOpts -> UniqSupply -> CtsM a -> a +initCts opts us cts_m + = initUs_ us $ + unCtsM cts_m (coreToStg_platform opts) emptyVarEnv {-# INLINE thenCts #-} {-# INLINE returnCts #-} returnCts :: a -> CtsM a -returnCts e = CtsM $ \_ _ -> e +returnCts e = CtsM $ \_ _ -> return e thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b -thenCts m k = CtsM $ \platform env - -> unCtsM (k (unCtsM m platform env)) platform env +thenCts m k = CtsM $ \platform env -> + do { v <- unCtsM m platform env + ; unCtsM (k v) platform env } instance Applicative CtsM where pure = returnCts @@ -792,17 +820,26 @@ instance Monad CtsM where (>>=) = thenCts getPlatform :: CtsM Platform -getPlatform = CtsM const +getPlatform = CtsM $ \platform _ -> return platform -- Functions specific to this monad: +setCtsEnv :: IdEnv HowBound -> CtsM a -> CtsM a +setCtsEnv env thing = CtsM $ \platform _ -> unCtsM thing platform env + +getCtsEnv :: CtsM (IdEnv HowBound) +getCtsEnv = CtsM $ \_ env -> return env + +getCtsUnique :: CtsM Unique +getCtsUnique = CtsM $ \_ _ -> getUniqueM + extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr = CtsM $ \platform env -> unCtsM expr platform (extendVarEnvList env ids_w_howbound) lookupVarCts :: Id -> CtsM HowBound -lookupVarCts v = CtsM $ \_ env -> lookupBinding env v +lookupVarCts v = CtsM $ \_ env -> return (lookupBinding env v) lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of @@ -814,13 +851,26 @@ lookupBinding env v = case lookupVarEnv env v of filterStgBinders :: [Var] -> [Var] filterStgBinders bndrs = filter isId bndrs -myCollectBinders :: Expr Var -> ([Var], Expr Var) -myCollectBinders expr +myCollectBinders :: JoinPointHood -> Expr Var -> ([Var], Expr Var) +-- Collect the binders from a lambda: +-- * Dropping type lambdas +-- * Stopping at join-point arity +myCollectBinders NotJoinPoint expr = go [] expr where - go bs (Lam b e) = go (b:bs) e - go bs (Cast e _) = go bs e - go bs e = (reverse bs, e) + go bs (Lam b e) | isRuntimeVar b = go (b:bs) e + | otherwise = go bs e + go bs (Cast e _) = go bs e + go bs e = (reverse bs, e) + +myCollectBinders (JoinPoint n) expr + = go n [] expr + where + go n bs e | n==0 = (reverse bs, e) + go n bs (Lam b e) | isRuntimeVar b = go (n-1) (b:bs) e + | otherwise = go (n-1) bs e + go n bs (Cast e _) = go n bs e + go _ bs e = (reverse bs, e) -- | If the argument expression is (potential chain of) 'App', return the head -- of the app chain, and collect ticks/args along the chain. ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -144,16 +144,13 @@ Here is the syntax of the Core produced by CorePrep: Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only + | let(rec) x = body in body -- Boxed only | case body of pat -> body - | /\a. body | /\c. body + | /\a. body | /\c. body | \x. body | body |> co - Right hand sides (only place where value lambdas can occur) - rhs ::= /\a.rhs | \x.rhs | body - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. +We define a synonym for each of these non-terminals, CpeArg, CpeApp, and +CpeBody. Functions with the corresponding name produce a result in that syntax. Note [Cloning in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -218,7 +215,6 @@ So our plan is: type CpeArg = CoreExpr -- Non-terminal 'arg' type CpeApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' {- ************************************************************************ @@ -261,7 +257,7 @@ corePrepExpr logger config expr = do withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do us <- mkSplitUniqSupply StgTag let initialCorePrepEnv = mkInitialCorePrepEnv config - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + let new_expr = initUs_ us (cpeBody initialCorePrepEnv expr) putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr @@ -665,16 +661,16 @@ cpeBind top_lvl env (Rec pairs) --------------- cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity -> CorePrepEnv -> OutId -> CoreExpr - -> UniqSM (Floats, CpeRhs) + -> UniqSM (Floats, CpeBody) -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd lev env0 bndr rhs = assert (isNothing $ joinPointBinding_maybe bndr rhs) $ -- those should use cpeJoinPair - do { (floats1, rhs1) <- cpeRhsE env rhs + do { (floats1, rhs1) <- cpeBodyF env rhs -- See if we are allowed to float this stuff out of the RHS ; let dec = want_float_from_rhs floats1 rhs1 - ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1 + (floats2, rhs2) = executeFloatDecision dec floats1 rhs1 -- Make the arity match up ; (floats3, rhs3) @@ -717,7 +713,7 @@ it seems good for CorePrep to be robust. --------------- cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr - -> UniqSM (JoinId, CpeRhs) + -> UniqSM (JoinId, CpeBody) -- Used for all join bindings -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs @@ -729,7 +725,7 @@ cpeJoinPair env bndr rhs ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts + ; body' <- cpeBody env' body -- Will let-bind the body if it starts -- with a lambda ; let rhs' = mkCoreLams bndrs' body' @@ -757,10 +753,20 @@ for us to mess with the arity because a join point is never exported. -} -- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs +-- cpeBodyF: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +cpeBodyF :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce +-- a list of 'Floats' which are being propagated upwards. In +-- fact, this function is used in only two cases: to +-- implement 'cpeBody' (which is what you usually want), +-- and in the case when a let-binding is in a case scrutinee--here, +-- we can always float out: +-- +-- case (let x = y in z) of ... +-- ==> let x = y in case z of ... +-- -- If -- e ===> (bs, e') -- then @@ -769,32 +775,32 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE env (Type ty) +cpeBodyF env (Type ty) = return (emptyFloats, Type (cpSubstTy env ty)) -cpeRhsE env (Coercion co) +cpeBodyF env (Coercion co) = return (emptyFloats, Coercion (cpSubstCo env co)) -cpeRhsE env expr@(Lit lit) +cpeBodyF env expr@(Lit lit) | LitNumber LitNumBigNat i <- lit = cpeBigNatLit env i | otherwise = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr +cpeBodyF env expr@(Var {}) = cpeApp env expr +cpeBodyF env expr@(App {}) = cpeApp env expr -cpeRhsE env (Let bind body) +cpeBodyF env (Let bind body) = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind - ; (body_floats, body') <- cpeRhsE env' body + ; (body_floats, body') <- cpeBodyF env' body ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' Nothing -> body' ; return (bind_floats `appFloats` body_floats, expr') } -cpeRhsE env (Tick tickish expr) +cpeBodyF env (Tick tickish expr) -- Pull out ticks if they are allowed to be floated. | tickishFloatable tickish - = do { (floats, body) <- cpeRhsE env expr + = do { (floats, body) <- cpeBodyF env expr -- See [Floating Ticks in CorePrep] ; return (FloatTick tickish `consFloat` floats, body) } | otherwise - = do { body <- cpeBodyNF env expr + = do { body <- cpeBody env expr ; return (emptyFloats, mkTick tickish' body) } where tickish' | Breakpoint ext bid fvs <- tickish @@ -803,17 +809,17 @@ cpeRhsE env (Tick tickish expr) | otherwise = tickish -cpeRhsE env (Cast expr co) - = do { (floats, expr') <- cpeRhsE env expr +cpeBodyF env (Cast expr co) + = do { (floats, expr') <- cpeBodyF env expr ; return (floats, Cast expr' (cpSubstCo env co)) } -cpeRhsE env expr@(Lam {}) +cpeBodyF env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body + ; body' <- cpeBody env' body ; return (emptyFloats, mkLams bndrs' body') } -cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) +cpeBodyF env (Case scrut bndr _ alts@[Alt con [covar] _]) -- See (U3) in Note [Implementing unsafeCoerce] -- We need make the Case float, otherwise we get -- let x = case ... of UnsafeRefl co -> @@ -828,7 +834,7 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) -- Note that `x` is a value here. This is visible in the GHCi debugger tests -- (such as `print003`). | Just rhs <- isUnsafeEqualityCase scrut bndr alts - = do { (floats_scrut, scrut) <- cpeBody env scrut + = do { (floats_scrut, scrut) <- cpeBodyF env scrut ; (env, bndr') <- cpCloneBndr env bndr ; (env, covar') <- cpCloneCoVarBndr env covar @@ -836,19 +842,19 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) -- See Note [Cloning CoVars and TyVars] -- Up until here this should do exactly the same as the regular code - -- path of `cpeRhsE Case{}`. - ; (floats_rhs, rhs) <- cpeBody env rhs + -- path of `cpeBodyF Case{}`. + ; (floats_rhs, rhs) <- cpeBodyF env rhs -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might -- become a value ; let case_float = UnsafeEqualityCase scrut bndr' con [covar'] -- NB: It is OK to "evaluate" the proof eagerly. -- Usually there's the danger that we float the unsafeCoerce out of -- a branching Case alt. Not so here, because the regular code path - -- for `cpeRhsE Case{}` will not float out of alts. + -- for `cpeBodyF Case{}` will not float out of alts. floats = snocFloat floats_scrut case_float `appFloats` floats_rhs ; return (floats, rhs) } -cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) +cpeBodyF env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) -- See item (SEQ4) of Note [seq# magic]. We want to match -- case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s'] -- and simplify to rhs[s]. Triggers in T15226. @@ -869,10 +875,10 @@ cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info] -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a -- variable, and in that case the zapping doesn't happen; see that Note. - = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs + = cpeBodyF (extendCorePrepEnv env token_out token_in') rhs -cpeRhsE env (Case scrut bndr ty alts) - = do { (floats, scrut') <- cpeBody env scrut +cpeBodyF env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBodyF env scrut ; (env', bndr2) <- cpCloneBndr env bndr ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding ; let alts' @@ -885,7 +891,7 @@ cpeRhsE env (Case scrut bndr ty alts) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts - where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" + where err = mkImpossibleExpr ty "cpeBodyF: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' ; case alts'' of @@ -896,7 +902,7 @@ cpeRhsE env (Case scrut bndr ty alts) where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs + ; rhs' <- cpeBody env2 rhs ; return (Alt con bs' rhs') } -- --------------------------------------------------------------------------- @@ -908,74 +914,10 @@ cpeRhsE env (Case scrut bndr ty alts) -- let-bound using 'wrapBinds'). Generally you want this, esp. -- when you've reached a binding form (e.g., a lambda) and -- floating any further would be incorrect. -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce --- a list of 'Floats' which are being propagated upwards. In --- fact, this function is used in only two cases: to --- implement 'cpeBodyNF' (which is what you usually want), --- and in the case when a let-binding is in a case scrutinee--here, --- we can always float out: --- --- case (let x = y in z) of ... --- ==> let x = y in case z of ... --- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody env rhs - ; return (floats1 `appFloats` floats2, body) } - --------- -rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -rhsToBody env (Tick t expr) - | tickishHasNoScope t -- only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody env expr - ; return (floats, mkTick t expr') } - -rhsToBody env (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody env e - ; return (floats, Cast e' co) } - -rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { let rhs = cpeEtaExpand (exprArity expr) expr - ; fn <- newVar env (exprType rhs) - ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable - ; return (unitFloat float, Var fn) } - where - (bndrs,_) = collectBinders expr - -rhsToBody _env expr = return (emptyFloats, expr) - - -{- Note [No eta reduction needed in rhsToBody] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Historical note. In the olden days we used to have a Prep-specific -eta-reduction step in rhsToBody: - rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - -The goal was to reduce - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } - -to avoid allocating a lambda. Of course, we'd allocate a PAP -instead, which is hardly better, but that's the way it was. - -Now we simply don't bother with this. It doesn't seem to be a win, -and it's extra work. --} + = do { (floats, body) <- cpeBodyF env expr + ; return (wrapBinds floats body) } -- --------------------------------------------------------------------------- -- CpeApp: produces a result satisfying CpeApp @@ -1060,8 +1002,8 @@ body of the eta-expansion lambda, resulting in which is unproblematic. -} -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs (instead of CpeApp) because of saturating primops +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +-- May return a CpeBody (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1103,7 +1045,7 @@ cpeApp top_env expr cpe_app :: CorePrepEnv -> CoreExpr -- The thing we are calling -> [ArgInfo] - -> UniqSM (Floats, CpeRhs) + -> UniqSM (Floats, CpeBody) cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make @@ -1156,7 +1098,7 @@ cpeApp top_env expr -- case thing of res { __DEFAULT -> (# token, res#) } }, -- allocating CaseBound Floats for token and thing as needed = do { (floats1, token) <- cpeArg env topDmd token - ; (floats2, thing) <- cpeBody env thing + ; (floats2, thing) <- cpeBodyF env thing ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] ; let float = mkCaseFloat case_bndr thing @@ -1173,9 +1115,10 @@ cpeApp top_env expr then Just $! idArity v_hd else Nothing Nothing -> Nothing - -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity - ; mb_saturate hd app floats unsat_ticks depth } + ; case hd of + Nothing -> do { massert (null unsat_ticks); return (floats, app) } + Just fn_id -> return (floats, maybeSaturate fn_id app depth unsat_ticks) } where depth = val_args args stricts = case idDmdSig v of @@ -1190,8 +1133,8 @@ cpeApp top_env expr -- partial application might be seq'd -- We inlined into something that's not a var and has no args. - -- Bounce it back up to cpeRhsE. - cpe_app env fun [] = cpeRhsE env fun + -- Bounce it back up to cpeBodyF. + cpe_app env fun [] = cpeBodyF env fun -- Here we get: -- N-variable fun, better let-bind it @@ -1202,7 +1145,8 @@ cpeApp top_env expr -- If evalDmd says that it's sure to be evaluated, -- we'll end up case-binding it ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing - ; mb_saturate Nothing app floats unsat_ticks (val_args args) } + ; massert (null unsat_ticks) + ; return (floats, app) } -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG) val_args :: [ArgInfo] -> Int @@ -1223,13 +1167,6 @@ cpeApp top_env expr | isTypeArg e = n | otherwise = n+1 - -- Saturate if necessary - mb_saturate head app floats unsat_ticks depth = - case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks - ; return (floats, sat_app) } - _other -> do { massert (null unsat_ticks) - ; return (floats, app) } -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, @@ -1561,11 +1498,11 @@ Wrinkles: cpeArg :: CorePrepEnv -> Demand -> CoreArg -> UniqSM (Floats, CpeArg) cpeArg env dmd arg - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + = do { (floats1, arg1) <- cpeBodyF env arg -- arg1 can be a lambda ; let arg_ty = exprType arg1 lev = typeLevity arg_ty dec = wantFloatLocal NonRecursive dmd lev floats1 arg1 - ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1 + (floats2, arg2) = executeFloatDecision dec floats1 arg1 -- Else case: arg1 might have lambdas, and we can't -- put them inside a wrapBinds @@ -1580,7 +1517,12 @@ cpeArg env dmd arg arg3 = cpeEtaExpand arity arg2 -- See Note [Eta expansion of arguments in CorePrep] ; let (arg_float, v') = mkNonRecFloat env lev v arg3 - ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2) +-- ; pprTraceM "cpeArg" (vcat [ text "arg1" <+> ppr arg1 +-- , text "decision" <+> ppr dec +-- , text "arg2" <+> ppr arg2 +-- , text "arity" <+> ppr arity +-- , text "arg3" <+> ppr arg3 +-- ]) ; return (snocFloat floats2 arg_float, varToCoreExpr v') } } @@ -1617,59 +1559,56 @@ eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts) eta_would_wreck_join _ = False -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> CpeApp + -> Int -- Number of value arguments in the application + -> [CoreTickish] + -> CpeBody maybeSaturate fn expr n_args unsat_ticks - | hasNoBinding fn -- There's no binding - -- See Note [Eta expansion of hasNoBinding things in CorePrep] - = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr - - | mark_arity > 0 -- A call-by-value function. - -- See Note [CBV Function Ids: overview] - , not applied_marks - = assertPpr - ( not (isJoinId fn)) -- See Note [Do not eta-expand join points] - ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ - text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ - text "join_arity" <+> ppr (idJoinPointHood fn) $$ - text "fn_arity" <+> ppr fn_arity - ) $ - -- pprTrace "maybeSat" - -- ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ - -- text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ - -- text "join_arity" <+> ppr (isJoinId_maybe fn) $$ - -- text "fn_arity" <+> ppr fn_arity $$ - -- text "excess_arity" <+> ppr excess_arity $$ - -- text "mark_arity" <+> ppr mark_arity - -- ) $ - return sat_expr + | isJoinId fn -- Never eta-expand a call to a join point + -- See Note [Do not eta-expand join points] + = assertPpr (not must_eta_expand) (ppr expr) $ + -- assertPpr: check that all arguments that need to be passed cbv + -- are visible, so the backend can evalaute them if required + expr + + | must_eta_expand || desirable_to_eta_expand + -- n_args > 0: do not eta-expand a naked variable! + = wrapLamBody (mkTicks unsat_ticks) $ + cpeEtaExpand excess_arity expr | otherwise - = assert (null unsat_ticks) $ - return expr + = expr + where - mark_arity = idCbvMarkArity fn - fn_arity = idArity fn - excess_arity = (max fn_arity mark_arity) - n_args - sat_expr = cpeEtaExpand excess_arity expr - applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . - reverse . expectJust $ (idCbvMarks_maybe fn)) - -- For join points we never eta-expand (See Note [Do not eta-expand join points]) - -- so we assert all arguments that need to be passed cbv are visible so that the - -- backend can evalaute them if required.. + must_eta_expand + = (hasNoBinding fn && fn_arity > n_args) + -- hasNoBinding functions must be saturated + || (mark_arity > n_args) + -- CBV functions must be CBV-saturated + + desirable_to_eta_expand = fn_arity > n_args && n_args > 0 + -- n_args > 0: do not eta-expand a naked variable unless we have to + + mark_arity = idCbvMarkArity fn + fn_arity = idArity fn + excess_arity = (max fn_arity mark_arity) - n_args {- Note [Eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity +Eta expand to match the arity claimed by the binder. +Remember, CorePrep must not change arity Eta expansion might not have happened already, because it is done by the simplifier only when there at least one lambda already. -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little worse for - code compiled without -O. The case in point is data constructor - wrappers. +We do eta-expansion (via `cpeEtaExpand`) in three places: + +* At let-bindings; in `cpePair` + +* On function arguments: in `cpeArg` + See Note [Eta expansion of arguments in CorePrep] + +* At un-saturated function calls: in `maybeSaturate` NB2: we have to be careful that the result of etaExpand doesn't invalidate any of the assumptions that CorePrep is attempting @@ -1677,12 +1616,37 @@ NB2: we have to be careful that the result of etaExpand doesn't an SCC note - we're now careful in etaExpand to make sure the SCC is pushed inside any new lambdas that are generated. -Note [Eta expansion of hasNoBinding things in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -maybeSaturate deals with eta expanding to saturate things that can't deal -with unsaturated applications (identified by 'hasNoBinding', currently -foreign calls, unboxed tuple/sum constructors, and representation-polymorphic -primitives such as 'coerce' and 'unsafeCoerce#'). +Note [Eta expansion for let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given f = rhs, we eta-expand `rhs` to match f's arity. + +We could refrain when the RHS is trivial (which can happen for exported things). +This would reduce the amount of code generated (a little) and make things a +little worse for code compiled without -O. The case in point is data +constructor wrappers. + +Note [Eta expansion of unsaturated calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a call (f a1..an), where `f` is a known function with arity greater than `n`, +there are three reasons we might want to eta-expand: + +* Must eta-expand: if `f` is a `hasNoBinding` function, we must saturate + it, because the function has no (curried) binding to call. Currently + this includes: + - foreign calls, + - unboxed tuple/sum constructors + - representation-polymorphic primitives such as 'coerce' and 'unsafeCoerce#' + - primops (for now anyway; see comments in `hasNoBinding`) + +* Must eta-expand: if `f` has a call-by-value calling convention, we /must/ + call it with evaluated arguments. The back end deals with adding the + necessary evaluation at the call site, but we must first ensure that it is + saturated. + +* May eta-expand: consider + \x -> f x True + where `f` has arity 3. Then it's much better to eta-expand f so we have + \xy -> f x True y Historical Note: Note that eta expansion in CorePrep used to be very fragile due to the "prediction" of CAFfyness that we used to make during tidying. We @@ -1694,7 +1658,7 @@ Note [Eta expansion and the CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out to be much much easier to do eta expansion *after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. +on the eta expander: given a CpeBody, it must return a CpeBody. For example here is what we do not want: f = /\a -> g (h 3) -- h has arity 2 @@ -1706,6 +1670,26 @@ and now we do NOT want eta expansion to give Instead GHC.Core.Opt.Arity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y +Another example: + f x = case x of + A -> \y. e + B -> hnb 3 -- where `hnb` has no binding + C -> z +Then we may eta-expand `hnb` to get + f x = case x of + A -> \y. e + B -> \y. hnb 3 y + C -> z +Now we come to the binding of `f` itself, and eta-expand that, to give + f x y = case x of + A -> e + B -> hnb 3 y + C -> z y +Notice how important it is that the eta-expansion for `f` doesn't +generate any crap like + B -> (\y. hnb 3 y) y +Fortunately, the eta-expander is careful not to do so. + Note [Eta expansion of arguments in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to @@ -1798,7 +1782,7 @@ There is a nasty Wrinkle: #24471 is a good example, where Prep took 25% of compile time! -} -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand :: Arity -> CpeBody -> CpeBody cpeEtaExpand arity expr | arity == 0 = expr | otherwise = etaExpand arity expr @@ -2165,9 +2149,6 @@ isEmptyFloats (Floats _ b) = isNilOL b getFloats :: Floats -> OrdList FloatingBind getFloats = fs_binds -unitFloat :: FloatingBind -> Floats -unitFloat = snocFloat emptyFloats - floatInfo :: FloatingBind -> FloatInfo floatInfo (Float _ _ info) = info floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep] @@ -2255,7 +2236,7 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, | Lifted <- lev = (LetBound, TopLvlFloatable) -- And these float freely but can't be speculated, hence LetBound -mkCaseFloat :: Id -> CpeRhs -> FloatingBind +mkCaseFloat :: Id -> CpeBody -> FloatingBind mkCaseFloat bndr scrut = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info) -- -- <+> ppr is_lifted <+> ppr is_strict @@ -2273,7 +2254,7 @@ mkCaseFloat bndr scrut -- (ok-for-spec case bindings are unlikely anyway.) } -mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id) +mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeBody -> (FloatingBind, Id) mkNonRecFloat env lev bndr rhs = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info) -- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted" @@ -2413,24 +2394,18 @@ instance Outputable FloatDecision where ppr FloatNone = text "none" ppr FloatAll = text "all" -executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs) -executeFloatDecision env dec floats rhs +executeFloatDecision :: FloatDecision -> Floats -> CpeBody -> (Floats, CpeBody) +executeFloatDecision dec floats rhs = case dec of - FloatAll -> return (floats, rhs) - FloatNone - | isEmptyFloats floats -> return (emptyFloats, rhs) - | otherwise -> do { (floats', body) <- rhsToBody env rhs - ; return (emptyFloats, wrapBinds floats $ - wrapBinds floats' body) } - -- FloatNone case: `rhs` might have lambdas, and we can't - -- put them inside a wrapBinds, which expects a `CpeBody`. + FloatAll -> (floats, rhs) + FloatNone -> (emptyFloats, wrapBinds floats rhs) wantFloatTop :: Floats -> FloatDecision wantFloatTop fs | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll | otherwise = FloatNone -wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision +wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeBody -> FloatDecision -- See Note [wantFloatLocal] wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs | isEmptyFloats floats -- Well yeah... @@ -2479,7 +2454,7 @@ zero free variables.) In general, the inliner is good at eliminating these let-bindings. However, there is one case where these trivial updatable thunks can arise: when we are optimizing away 'lazy' (see Note [lazyId magic], and also -'cpeRhsE'.) Then, we could have started with: +'cpeBodyF'.) Then, we could have started with: let x :: () x = lazy @() y @@ -2783,8 +2758,7 @@ wrapTicks floats expr -- --------------------------------------------------------------------------- -- | Converts Bignum literals into their final CoreExpr -cpeBigNatLit - :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) +cpeBigNatLit :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeBody) cpeBigNatLit env i = assert (i >= 0) $ do let platform = cp_platform (cpe_config env) ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2435,8 +2435,8 @@ myCoreToStg :: Logger -> DynFlags -> [Var] , CollectedCCs -- CAF cost centre info (declared and used) , StgCgInfos ) myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do - let (stg_binds, denv, cost_centre_info) - = {-# SCC "Core2Stg" #-} + (stg_binds, denv, cost_centre_info) + <- {-# SCC "Core2Stg" #-} coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds (stg_binds_with_fvs,stg_cg_info) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -105,7 +105,7 @@ import GHC.Core ( AltCon(..) ) import GHC.Core.Type import GHC.Core.Lint ( lintMessage ) -import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) +import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Id import GHC.Types.Var.Set @@ -123,12 +123,9 @@ import GHC.Unit.Module ( Module ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Monad -import Data.Maybe -import GHC.Utils.Misc import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) -import GHC.Utils.Panic.Plain (panic) lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) => Platform @@ -174,36 +171,37 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w lint_bind (StgTopStringLit v _) = return [v] lintStgConArg :: StgArg -> LintM () -lintStgConArg arg = do - unarised <- lf_unarised <$> getLintFlags - when unarised $ case stgArgRep_maybe arg of - -- Note [Post-unarisation invariants], invariant 4 - Just [_] -> pure () - badRep -> addErrL $ - text "Non-unary constructor arg: " <> ppr arg $$ - text "Its PrimReps are: " <> ppr badRep - - case arg of - StgLitArg _ -> pure () - StgVarArg v -> lintStgVar v +lintStgConArg arg + = do { lintStgArg arg + + ; unarised <- lf_unarised <$> getLintFlags + ; when unarised $ case stgArgRep_maybe arg of + -- Note [Post-unarisation invariants], invariant 4 + Just [_] -> pure () + badRep -> addErrL $ + text "Non-unary constructor arg: " <> ppr arg $$ + text "Its PrimReps are: " <> ppr badRep } lintStgFunArg :: StgArg -> LintM () -lintStgFunArg arg = do - unarised <- lf_unarised <$> getLintFlags - when unarised $ case stgArgRep_maybe arg of - -- Note [Post-unarisation invariants], invariant 3 - Just [] -> pure () - Just [_] -> pure () - badRep -> addErrL $ - text "Function arg is not unary or void: " <> ppr arg $$ - text "Its PrimReps are: " <> ppr badRep - - case arg of - StgLitArg _ -> pure () - StgVarArg v -> lintStgVar v - -lintStgVar :: Id -> LintM () -lintStgVar id = checkInScope id +lintStgFunArg arg + = do { lintStgArg arg + + ; unarised <- lf_unarised <$> getLintFlags + ; when unarised $ case stgArgRep_maybe arg of + -- Note [Post-unarisation invariants], invariant 3 + Just [] -> pure () + Just [_] -> pure () + badRep -> addErrL $ + text "Function arg is not unary or void: " <> ppr arg $$ + text "Its PrimReps are: " <> ppr badRep } + +lintStgArg :: StgArg -> LintM () +lintStgArg (StgLitArg _) = pure () +lintStgArg (StgVarArg v) = do { lintStgVarOcc v + ; lintAppCbvMarks v [] } + +lintStgVarOcc :: Id -> LintM () +lintStgVarOcc id = checkInScope id lintStgBinds :: (OutputablePass a, BinderP a ~ Id) @@ -275,13 +273,11 @@ lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () lintStgExpr (StgLit _) = return () -lintStgExpr e@(StgApp fun args) = do - lintStgVar fun - mapM_ lintStgFunArg args - lintAppCbvMarks e - lintStgAppReps fun args - - +lintStgExpr (StgApp fun args) + = do { lintStgVarOcc fun + ; mapM_ lintStgFunArg args + ; lintAppCbvMarks fun args + ; lintStgAppReps fun args } lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise @@ -413,22 +409,20 @@ lintStgAppReps fun args = do match_args actual_arg_reps fun_arg_tys_reps -lintAppCbvMarks :: OutputablePass pass - => GenStgExpr pass -> LintM () -lintAppCbvMarks e@(StgApp fun args) = do - lf <- getLintFlags - when (lf_unarised lf) $ do +lintAppCbvMarks :: Id -> [StgArg] -> LintM () +lintAppCbvMarks fun args + | idCbvMarkArity fun > length args -- A function which expects a unlifted argument as n'th argument -- always needs to be applied to n arguments. -- See Note [CBV Function Ids: overview]. - let marks = fromMaybe [] $ idCbvMarks_maybe fun - when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do - addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $ - (text "marks" <> ppr marks $$ - text "args" <> ppr args $$ - text "arity" <> ppr (idArity fun) $$ - text "join_arity" <> ppr (idJoinPointHood fun)) -lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks" + = addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr fun) + 2 (vcat [ text "marks" <> ppr (idCbvMarks_maybe fun) + , text "args" <> ppr args + , text "arity" <> ppr (idArity fun) + , text "join_arity" <> ppr (idJoinPointHood fun) ]) + + | otherwise + = return () {- ************************************************************************ ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -852,7 +852,7 @@ idCbvMarks_maybe id = case idDetails id of _ -> Nothing -- Id must be called with at least this arity in order to allow arguments to --- be passed unlifted. +-- be passed unlifted. Return 0 if there are no CBV marks. idCbvMarkArity :: Id -> Arity idCbvMarkArity fn = maybe 0 length (idCbvMarks_maybe fn) ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -210,6 +210,7 @@ data IdDetails -- Can also work as a WorkerLikeId if given `CbvMark`s. -- See Note [CBV Function Ids: overview] -- The [CbvMark] is always empty (and ignored) until after Tidy. + | WorkerLikeId [CbvMark] -- ^ An 'Id' for a worker like function, which might expect some arguments to be -- passed both evaluated and tagged. @@ -217,8 +218,10 @@ data IdDetails -- aren't used unapplied. -- See Note [CBV Function Ids: overview] -- See Note [EPT enforcement] - -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current - -- module. + -- Invariants: + -- - the [CbvMark] is always empty (and ignored) until after Tidy + -- for ids from the current module + -- - If non-empty, at least is isMarkedCbbv; see (CBV2) data RecSelInfo = RSI { rsi_def :: [ConLike] -- Record selector defined for these @@ -297,9 +300,7 @@ Here's how it all works: to identify strict arguments. See Note [Call-by-value for worker args] for how a worker guarantees to be strict in strict datacon fields. - TODO: We currently don't do this for arguments that are unboxed sums or tuples, - because then we'd have to predict the result of unarisation. But it would be nice to - do so. See `computeCbvInfo`. + See (CBV1) and (CBV2). * During CorePrep calls to CBV Ids are eta expanded. See `GHC.CoreToStg.Prep.maybeSaturate`. @@ -319,6 +320,16 @@ Here's how it all works: * Imported functions may be CBV, and then there is no point in eta-reducing them; we'll just have to eta-expand later; see GHC.Core.Opt.Arity.cantEtaReduceFun. +Wrinkles + +(CBV1) We do not set the CBV-marks for a function that takes an unboxed sum or tuple, + as an argument, because then we'd have to predict the result of unarisation. + It would be nice to do so in future. See `computeCbvInfo`. + +(CBV2) We do not set CBV-marks if none of them are `isMarkedCbv`. Why not? + Because if none are CBV then there is nothing special to do for this function; + in particular, we don't need to saturate its calls. See `computeCbvInfo`. + *** SPJ really? Andreas? **** We only use this for workers and specialized versions of SpecConstr But we also check other functions during tidy and potentially turn some of them into ===================================== testsuite/tests/arityanal/should_compile/Arity01.stderr ===================================== @@ -5,19 +5,19 @@ Result size of Tidy Core = {terms: 71, types: 43, coercions: 0, joins: 0/0} -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F1.f2 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F1.f2 = GHC.Num.Integer.IS 1# +F1.f2 = GHC.Internal.Bignum.Integer.IS 1# Rec { -- RHS size: {terms: 24, types: 6, coercions: 0, joins: 0/0} F1.f1_h1 [Occ=LoopBreaker] :: Integer -> Integer -> Integer -> Integer [GblId, Arity=3, Str=<1L><1L><SL>, Unf=OtherCon []] F1.f1_h1 - = \ (n :: Integer) (x :: Integer) (eta [OS=OneShot] :: Integer) -> + = \ (n :: Integer) (x [OS=OneShot] :: Integer) (eta [OS=OneShot] :: Integer) -> case x of x1 { __DEFAULT -> case n of y1 { __DEFAULT -> - case GHC.Num.Integer.integerLt# x1 y1 of { + case GHC.Internal.Bignum.Integer.integerLt# x1 y1 of { __DEFAULT -> eta; - 1# -> F1.f1_h1 y1 (GHC.Num.Integer.integerAdd x1 F1.f2) (GHC.Num.Integer.integerAdd x1 eta) + 1# -> F1.f1_h1 y1 (GHC.Internal.Bignum.Integer.integerAdd x1 F1.f2) (GHC.Internal.Bignum.Integer.integerAdd x1 eta) } } } @@ -26,7 +26,7 @@ end Rec } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F1.f3 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F1.f3 = GHC.Num.Integer.IS 5# +F1.f3 = GHC.Internal.Bignum.Integer.IS 5# -- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0} f1 :: Integer @@ -36,27 +36,27 @@ f1 = F1.f1_h1 F1.f3 F1.f2 F1.f3 -- RHS size: {terms: 14, types: 5, coercions: 0, joins: 0/0} g :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer [GblId, Arity=5, Str=<1L><SL><SL><SL><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0 0 0 0] 120 0}] -g = \ (x1 :: Integer) (x2 :: Integer) (x3 :: Integer) (x4 :: Integer) (x5 :: Integer) -> GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd x1 x2) x3) x4) x5 +g = \ (x1 :: Integer) (x2 :: Integer) (x3 :: Integer) (x4 :: Integer) (x5 :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd (GHC.Internal.Bignum.Integer.integerAdd x1 x2) x3) x4) x5 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F1.s1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F1.s1 = GHC.Num.Integer.IS 3# +F1.s1 = GHC.Internal.Bignum.Integer.IS 3# -- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2 -[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 60] 50 0}] +[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 50 0}] s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1) -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F1.h1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F1.h1 = GHC.Num.Integer.IS 24# +F1.h1 = GHC.Internal.Bignum.Integer.IS 24# -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} h :: Integer -> Integer [GblId, Arity=1, Str=<SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}] -h = \ (x5 :: Integer) -> GHC.Num.Integer.integerAdd F1.h1 x5 +h = \ (x5 :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F1.h1 x5 ===================================== testsuite/tests/arityanal/should_compile/Arity05.stderr ===================================== @@ -5,27 +5,27 @@ Result size of Tidy Core = {terms: 42, types: 44, coercions: 0, joins: 0/0} -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F5.f5g1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F5.f5g1 = GHC.Num.Integer.IS 1# +F5.f5g1 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 12, types: 9, coercions: 0, joins: 0/0} f5g :: forall {a} {t}. Num a => (t -> a) -> t -> a -[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 60 0] 90 0}] +[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 90 0}] f5g = \ (@a) (@t) ($dNum :: Num a) (h :: t -> a) (z :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1) -- RHS size: {terms: 17, types: 12, coercions: 0, joins: 0/0} f5h :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60 0 60] 150 0}] +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 150 0}] f5h = \ (@a) (@t) ($dNum :: Num a) (f :: t -> a) (x :: t) (g :: t -> a) -> + @a $dNum (f x) (+ @a $dNum (g x) (fromInteger @a $dNum F5.f5g1)) -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} f5y :: Integer -> Integer [GblId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}] -f5y = \ (y :: Integer) -> GHC.Num.Integer.integerAdd y F5.f5g1 +f5y = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd y F5.f5g1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} f5 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -f5 = GHC.Num.Integer.IS 3# +f5 = GHC.Internal.Bignum.Integer.IS 3# ===================================== testsuite/tests/arityanal/should_compile/Arity08.stderr ===================================== @@ -4,7 +4,7 @@ Result size of Tidy Core = {terms: 24, types: 18, coercions: 0, joins: 0/0} -- RHS size: {terms: 20, types: 10, coercions: 0, joins: 0/0} f8f :: forall {p}. Num p => Bool -> p -> p -> p -[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 30 0 0] 140 0}] +[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 140 0}] f8f = \ (@p) ($dNum :: Num p) (b :: Bool) (x :: p) (y :: p) -> case b of { @@ -15,7 +15,7 @@ f8f -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} f8 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -f8 = GHC.Num.Integer.IS 2# +f8 = GHC.Internal.Bignum.Integer.IS 2# ===================================== testsuite/tests/arityanal/should_compile/Arity11.stderr ===================================== @@ -5,57 +5,23 @@ Result size of Tidy Core = {terms: 136, types: 75, coercions: 0, joins: 2/7} -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.fib3 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.fib3 = GHC.Num.Integer.IS 1# +F11.fib3 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.fib2 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.fib2 = GHC.Num.Integer.IS 2# - -Rec { --- RHS size: {terms: 38, types: 13, coercions: 0, joins: 2/2} -F11.f11_fib [Occ=LoopBreaker] :: Integer -> Integer -[GblId, Arity=1, Str=<SL>, Unf=OtherCon []] -F11.f11_fib - = \ (ds :: Integer) -> - join { - $j [Dmd=ML] :: Integer - [LclId[JoinId(0)(Nothing)]] - $j - = join { - $j1 [Dmd=ML] :: Integer - [LclId[JoinId(0)(Nothing)]] - $j1 = GHC.Num.Integer.integerAdd (F11.f11_fib (GHC.Num.Integer.integerSub ds F11.fib3)) (F11.f11_fib (GHC.Num.Integer.integerSub ds F11.fib2)) } in - case ds of { - GHC.Num.Integer.IS x1 -> - case x1 of { - __DEFAULT -> jump $j1; - 1# -> F11.fib3 - }; - GHC.Num.Integer.IP x1 -> jump $j1; - GHC.Num.Integer.IN x1 -> jump $j1 - } } in - case ds of { - GHC.Num.Integer.IS x1 -> - case x1 of { - __DEFAULT -> jump $j; - 0# -> F11.fib3 - }; - GHC.Num.Integer.IP x1 -> jump $j; - GHC.Num.Integer.IN x1 -> jump $j - } -end Rec } +F11.fib2 = GHC.Internal.Bignum.Integer.IS 2# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.fib1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.fib1 = GHC.Num.Integer.IS 0# +F11.fib1 = GHC.Internal.Bignum.Integer.IS 0# -- RHS size: {terms: 54, types: 27, coercions: 0, joins: 0/5} -fib :: forall {t} {a}. (Eq t, Num t, Num a) => t -> a -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 480 0}] +fib :: forall {t1} {t2}. (Eq t1, Num t1, Num t2) => t1 -> t2 +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 480 0}] fib - = \ (@t) (@a) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num a) (eta :: t) -> + = \ (@t) (@t1) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num t1) (eta :: t) -> let { lvl :: t [LclId] @@ -65,32 +31,66 @@ fib [LclId] lvl1 = fromInteger @t $dNum F11.fib2 } in let { - lvl2 :: a + lvl2 :: t1 [LclId] - lvl2 = fromInteger @a $dNum1 F11.fib3 } in + lvl2 = fromInteger @t1 $dNum1 F11.fib3 } in let { lvl3 :: t [LclId] lvl3 = fromInteger @t $dNum F11.fib1 } in letrec { - fib4 [Occ=LoopBreaker, Dmd=SC(S,L)] :: t -> a + fib4 [Occ=LoopBreaker, Dmd=SC(S,L)] :: t -> t1 [LclId, Arity=1, Str=<L>, Unf=OtherCon []] fib4 = \ (ds :: t) -> case == @t $dEq ds lvl3 of { False -> case == @t $dEq ds lvl of { - False -> + @a $dNum1 (fib4 (- @t $dNum ds lvl)) (fib4 (- @t $dNum ds lvl1)); + False -> + @t1 $dNum1 (fib4 (- @t $dNum ds lvl)) (fib4 (- @t $dNum ds lvl1)); True -> lvl2 }; True -> lvl2 }; } in fib4 eta +Rec { +-- RHS size: {terms: 38, types: 13, coercions: 0, joins: 2/2} +F11.f11_fib [Occ=LoopBreaker] :: Integer -> Integer +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []] +F11.f11_fib + = \ (ds :: Integer) -> + join { + $j [Dmd=ML] :: Integer + [LclId[JoinId(0)(Nothing)]] + $j + = join { + $j1 [Dmd=ML] :: Integer + [LclId[JoinId(0)(Nothing)]] + $j1 = GHC.Internal.Bignum.Integer.integerAdd (F11.f11_fib (GHC.Internal.Bignum.Integer.integerSub ds F11.fib3)) (F11.f11_fib (GHC.Internal.Bignum.Integer.integerSub ds F11.fib2)) } in + case ds of { + GHC.Internal.Bignum.Integer.IS x -> + case x of { + __DEFAULT -> jump $j1; + 1# -> F11.fib3 + }; + GHC.Internal.Bignum.Integer.IP x -> jump $j1; + GHC.Internal.Bignum.Integer.IN x -> jump $j1 + } } in + case ds of { + GHC.Internal.Bignum.Integer.IS x -> + case x of { + __DEFAULT -> jump $j; + 0# -> F11.fib3 + }; + GHC.Internal.Bignum.Integer.IP x -> jump $j; + GHC.Internal.Bignum.Integer.IN x -> jump $j + } +end Rec } + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f3 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.f3 = GHC.Num.Integer.IS 1000# +F11.f3 = GHC.Internal.Bignum.Integer.IS 1000# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f11_x :: Integer @@ -100,7 +100,7 @@ F11.f11_x = F11.f11_fib F11.f3 -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} F11.f11f1 :: Integer -> Integer [GblId, Arity=1, Str=<SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}] -F11.f11f1 = \ (y :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y +F11.f11f1 = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F11.f11_x y -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} f11f :: forall {p}. p -> Integer -> Integer @@ -110,22 +110,22 @@ f11f = \ (@p) _ [Occ=Dead] -> F11.f11f1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f5 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.f5 = GHC.Num.Integer.IS 6# +F11.f5 = GHC.Internal.Bignum.Integer.IS 6# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} F11.f4 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}] -F11.f4 = GHC.Num.Integer.integerAdd F11.f11_x F11.f5 +F11.f4 = GHC.Internal.Bignum.Integer.integerAdd F11.f11_x F11.f5 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f2 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F11.f2 = GHC.Num.Integer.IS 8# +F11.f2 = GHC.Internal.Bignum.Integer.IS 8# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} F11.f1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}] -F11.f1 = GHC.Num.Integer.integerAdd F11.f11_x F11.f2 +F11.f1 = GHC.Internal.Bignum.Integer.integerAdd F11.f11_x F11.f2 -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} f11 :: (Integer, Integer) @@ -133,7 +133,4 @@ f11 :: (Integer, Integer) f11 = (F11.f4, F11.f1) ------- Local rules for imported ids -------- -"SPEC fib @Integer @Integer" forall ($dEq :: Eq Integer) ($dNum :: Num Integer) ($dNum1 :: Num Integer). fib @Integer @Integer $dEq $dNum $dNum1 = F11.f11_fib - ===================================== testsuite/tests/arityanal/should_compile/Arity14.stderr ===================================== @@ -3,18 +3,18 @@ Result size of Tidy Core = {terms: 44, types: 38, coercions: 0, joins: 0/3} -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -F14.f1 :: forall {t}. t -> t +F14.f1 :: forall t. t -> t [GblId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}] F14.f1 = \ (@t) (y :: t) -> y -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F14.f2 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -F14.f2 = GHC.Num.Integer.IS 1# +F14.f2 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/3} f14 :: forall {t}. (Ord t, Num t) => t -> t -> t -> t -[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 90 0 0] 310 0}] +[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 310 0}] f14 = \ (@t) ($dOrd :: Ord t) ($dNum :: Num t) (eta :: t) (eta1 :: t) -> let { @@ -25,7 +25,7 @@ f14 f3 [Occ=LoopBreaker, Dmd=SC(S,C(1,L))] :: t -> t -> t -> t [LclId, Arity=2, Str=<L><L>, Unf=OtherCon []] f3 - = \ (n :: t) (x :: t) -> + = \ (n :: t) (x [OS=OneShot] :: t) -> case < @t $dOrd x n of { False -> F14.f1 @t; True -> ===================================== testsuite/tests/simplCore/should_compile/T15205.stderr ===================================== @@ -10,7 +10,7 @@ f :: forall a b. C a b => a -> b Str=<1P(A,1C(1,C(1,L)))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [30 0] 40 0}] + Guidance=IF_ARGS [90 0] 40 0}] f = \ (@a) (@b) ($dC :: C a b) (x :: a) -> op @a @b $dC x x ===================================== testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs ===================================== @@ -91,12 +91,17 @@ stgify :: ModSummary -> ModGuts -> Ghc [StgTopBinding] stgify summary guts = do hsc_env <- getSession let dflags = hsc_dflags hsc_env - prepd_binds <- liftIO $ do + liftIO $ do cp_cfg <- initCorePrepConfig hsc_env - corePrepPgm (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env)) this_mod core_binds - return $ fstOf3 $ coreToStg (initCoreToStgOpts dflags) (ms_mod summary) (ms_location summary) prepd_binds - where this_mod = mg_module guts - core_binds = mg_binds guts + prepd_binds <- corePrepPgm (hsc_logger hsc_env) cp_cfg + (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env)) + this_mod core_binds + (binds, _, _) <- coreToStg (initCoreToStgOpts dflags) (ms_mod summary) + (ms_location summary) prepd_binds + return binds + where + this_mod = mg_module guts + core_binds = mg_binds guts slurpCmm :: HscEnv -> FilePath -> IO (CmmGroup) slurpCmm hsc_env filename = runHsc hsc_env $ do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe351792fc7fdcb718f30855590966… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe351792fc7fdcb718f30855590966… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/fix-static-001-darwin] Deleted 1 commit: REVERT: CI TEST
by Magnus (＠MangoIV) 31 Mar '26

31 Mar '26

Magnus pushed to branch wip/mangoiv/fix-static-001-darwin at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: 4f98c4cd by mangoiv at 2026-03-30T16:54:38+02:00 REVERT: CI TEST - - - - - 2 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -301,8 +301,8 @@ runnerTag arch (Linux _) = Amd64 -> "x86_64-linux" AArch64 -> "aarch64-linux" I386 -> "x86_64-linux" -runnerTag AArch64 Darwin = "aarch64-darwin" -runnerTag Amd64 Darwin = "x86_64-darwin-m1" +runnerTag AArch64 Darwin = "beta" +runnerTag Amd64 Darwin = "beta" runnerTag Amd64 Windows = "new-x86_64-windows" runnerTag Amd64 FreeBSD14 = "x86_64-freebsd14" runnerTag _ _ = error "Invalid arch/opsys" ===================================== .gitlab/jobs.yaml ===================================== @@ -50,7 +50,7 @@ ], "stage": "full-build", "tags": [ - "aarch64-darwin" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", @@ -838,7 +838,7 @@ ], "stage": "full-build", "tags": [ - "aarch64-darwin" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", @@ -1638,7 +1638,7 @@ ], "stage": "full-build", "tags": [ - "x86_64-darwin-m1" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", @@ -3877,7 +3877,7 @@ ], "stage": "full-build", "tags": [ - "aarch64-darwin" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", @@ -4459,7 +4459,7 @@ ], "stage": "full-build", "tags": [ - "x86_64-darwin-m1" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", @@ -5561,7 +5561,7 @@ ], "stage": "full-build", "tags": [ - "x86_64-darwin-m1" + "beta" ], "variables": { "BIGNUM_BACKEND": "gmp", View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f98c4cdb736010b656886026989d03… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f98c4cdb736010b656886026989d03… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/linker_fix] Remove unused var
by Andreas Klebinger (＠AndreasK) 31 Mar '26

31 Mar '26

Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC Commits: 924d0ca5 by Andreas Klebinger at 2026-03-31T11:30:50+00:00 Remove unused var - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -347,7 +347,6 @@ HsInt loadArchive_ (pathchar *path) int memberIdx = 0; FILE *f = NULL; size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ - int macho_misalignment = 0; DEBUG_LOG("start\n"); DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/924d0ca5f9f30371b38f1dfdc9d95ed… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/924d0ca5f9f30371b38f1dfdc9d95ed… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/no-ds-flag-cache] 2 commits: Update comments
by Simon Peyton Jones (＠simonpj) 31 Mar '26

31 Mar '26

Simon Peyton Jones pushed to branch wip/ani/no-ds-flag-cache at Glasgow Haskell Compiler / GHC Commits: 80ef7754 by Simon Peyton Jones at 2026-03-31T12:12:19+01:00 Update comments - - - - - 57261072 by Simon Peyton Jones at 2026-03-31T12:12:59+01:00 Unused imports - - - - - 2 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -461,11 +461,8 @@ checkResultTy :: HsExpr GhcRn -> TcM HsWrapper checkResultTy rn_expr (tc_fun,_) _ app_res_rho (Infer inf_res) = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun - -- We must deeply-instantiate data constructors - -- E.g. data T = MkT Int int - -- f = K 3 - -- We must infer f :: Int ->{many} T - -- and not f :: Int ->{one} T + -- Why the "DataConHead" bit? See (IIR5) in + -- Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify. ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res } checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -99,13 +99,13 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Builtin.Types import GHC.Types.Name -import GHC.Types.Id( idType, isDataConId ) +import GHC.Types.Id( idType ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Unique.Set (nonDetEltsUniqSet) -import GHC.Types.SrcLoc (unLoc, GenLocated (..)) +import GHC.Types.SrcLoc ( GenLocated (..) ) import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable @@ -1305,7 +1305,7 @@ Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type". Why is this the common case? See #17173 for discussion. Here are some examples of why: -1. Consider +(IIR1) Consider f x = (*) We want to instantiate the type of (*) before returning, else we will infer the type @@ -1317,21 +1317,46 @@ of why: instantiating. This could perhaps be worked around, but it may be hard to know even when instantiation should happen. -2. Another reason. Consider +(IIR2) Another reason. Consider f :: (?x :: Int) => a -> a g y = let ?x = 3::Int in f Here want to instantiate f's type so that the ?x::Int constraint gets discharged by the enclosing implicit-parameter binding. -3. Suppose one defines plus = (+). If we instantiate lazily, we will +(IIR3) Suppose one defines plus = (+). If we instantiate lazily, we will infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism restriction compels us to infer plus :: Integer -> Integer -> Integer (or similar monotype). Indeed, the only way to know whether to apply the monomorphism restriction at all is to instantiate -HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning -"return a sigma-type": +(IIR4) When -XDeepSubsumption is on, we /deeply/ instantiate. Why isn't + top-instantiation enough? Answer: to accept the following program (T26225b) with + -XDeepSubsumption, we need to deeply instantiate when inferring in checkResultTy: + + f :: Int -> (forall a. a->a) + g :: Int -> Bool -> Bool + + test b = case b of + True -> f + False -> g + + If we don't deeply instantiate in the branches of the case expression, we will + try to unify the type of `f` with that of `g`, which fails. If we instead + deeply instantiate `f`, we will fill the `InferResult` with `Int -> alpha -> alpha` + which then successfully unifies with the type of `g` when we come to fill the + `InferResult` hole a second time for the second case branch. + +(IIR5) When inferring, even /without/ -XDeepSubsumption, we must deeply instantiate + the types of data constructors. E.g + data T = MkT Int int + f = MkT 3 + We must infer MkT 3 :: Int ->{mu} T (fresh mu) + and not MkT 3 :: Int ->{one} T + See Note [Typechecking data constructors] in GHC.Tc.Gen.Head + Hence the use of `getDeepSubsumptionFlag_DataConHead` in `checkResultTy`. + +HOWEVER, `ir_inst` is not always `IIF_DeepRho`! Here are places when it isn't: * IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type command, we want to return a completely uninstantiated type. @@ -1347,23 +1372,6 @@ HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism] in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho. -Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough? -Answer: to accept the following program (T26225b) with -XDeepSubsumption, we -need to deeply instantiate when inferring in checkResultTy: - - f :: Int -> (forall a. a->a) - g :: Int -> Bool -> Bool - - test b = - case b of - True -> f - False -> g - -If we don't deeply instantiate in the branches of the case expression, we will -try to unify the type of 'f' with that of 'g', which fails. If we instead -deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha' -which then successfully unifies with the type of 'g' when we come to fill the -'InferResult' hole a second time for the second case branch. -} {- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3418bdbadd44cd7bf8b7cb47cf912c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3418bdbadd44cd7bf8b7cb47cf912c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26002] 9 commits: Bump minimum shake version for hadrian.
by Zubin (＠wz1000) 31 Mar '26

31 Mar '26

Zubin pushed to branch wip/26002 at Glasgow Haskell Compiler / GHC Commits: d741a6cc by Andreas Klebinger at 2026-03-31T04:39:33-04:00 Bump minimum shake version for hadrian. We also add the shake version we want to stack.yaml Fixes #26884 - - - - - 5e556f9e by Vladislav Zavialov at 2026-03-31T04:40:16-04:00 Status check for the HsType~HsExpr refactoring (#25121) Add a test case to track the status of a refactoring project within GHC whose goal is to arrive at the following declaration: type HsType = HsExpr The rationale for this is to increase code reuse between the term- and type-level code in the compiler front-end (AST, parser, renamer, type checker). The status report is saved to testsuite/tests/ghc-api/T25121_status.stdout and provides useful insights into what needs to happen to make progress on the ticket. - - - - - acffb1b1 by fendor at 2026-03-31T04:41:02-04:00 Extract Binary instances to `GHC.ByteCode.Binary` - - - - - e2ea8e25 by fendor at 2026-03-31T04:41:02-04:00 Add `seqNonEmpty` for evaluating `NonEmpty a` - - - - - 048b00b7 by fendor at 2026-03-31T04:41:02-04:00 Record `LinkableUsage` instead of `Linkable` in `LoaderState` Retaining a ByteCode `Linkable` after it has been loaded retains its `UnlinkedBCO`, keeping it alive for the remainder of the program. This starts accumulating a lot of `UnlinkedBCO` and memory over time. However, the `Linkable` is merely used to later record its usage in `mkObjectUsage`, which is used for recompilation checking. However, this is incorrect, as the interface file and bytecode objects could be in different states, e.g. the interface changes, but the bytecode library hasn't changed so we don't need to recompile and vice versa. By computing a `Fingerprint` for the `ModuleByteCode`, and recording it in the `LinkableUsage`, we know precisely whether the `ByteCode` object on disk is outdated. Thus, parts of this commit just makes sure that we efficiently compute a `Fingerprint` for `ModuleByteCode` and store it in the on-disk representation of `ModuleByteCode`. We change the `LoaderState` to retain `LinkableUsage`, which is smaller representation of a `Linkable`. This allows us to free the unneeded fields of `Linkable` after linking them. We declare the following memory invariants that this commit implements: * No `LinkablePart` should be retained from `LoaderState`. * `Linkable`s should be unloaded after they have been loaded. These invariants are unfortunately tricky to automatically uphold, so we are simply documenting our assumptions for now. We introduce the `linkable-space` test which makes sure that after loading, no `DotGBC` or `UnlinkedBCO` is retained. ------------------------- Metric Increase: MultiLayerModulesTH_OneShot ------------------------- We allocate a bit more, but the peak number of bytes doesn't change. While a bit unfortunate, accepting the metric increase. We add multiple new performance measurements where we were able to observe the desired memory invariants. Further, we add regression tests to validate that the recompilation checker behaves more correct than before. - - - - - 2d1c1997 by Simon Jakobi at 2026-03-31T04:41:46-04:00 Eliminate dictionary-passing in ListMap operations Mark the ListMap helpers 'INLINABLE' so importing modules can specialise the 'TrieMap (ListMap m)' methods and avoid recursive dictionary-passing. See Note [Making ListMap operations specialisable]. Fixes #27097 - - - - - ed2c6570 by Cheng Shao at 2026-03-31T04:42:33-04:00 testsuite: fix testdir cleanup logic on Windows testdir cleanup is unreliable on Windows (#13162) and despite existing hacks in the driver, new failure mode has occurred. This patch makes it print the warning and carry on when failed to clean up a testdir, instead of reporting a spurious framework failure. See added comment for detailed explanation. - - - - - 4c274478 by Zubin Duggal at 2026-03-31T16:40:39+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). - - - - - 263c7ab4 by Zubin Duggal at 2026-03-31T16:40:40+05:30 Sample changelog entries - - - - - 80 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/changelog-entries - + changelog.d/config - + changelog.d/fix-hsExprType - + changelog.d/fix-stm-catchRetry - + changelog.d/fix-unary-typeclass-default - + changelog.d/fix-windows-async-io - + changelog.d/infix-holes-types - + compiler/GHC/ByteCode/Binary.hs - + compiler/GHC/ByteCode/Recomp/Binary.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Data/TrieMap.hs - compiler/GHC/Driver/Hooks.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - + docs/users_guide/10.2.1-notes.rst - docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - ghc/GHCi/Leak.hs - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Default.hs - hadrian/stack.yaml - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - + testsuite/tests/bytecode/TLinkable/BCOTemplate.hs - + testsuite/tests/bytecode/TLinkable/LinkableUsage01.stderr - + testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr - + testsuite/tests/bytecode/TLinkable/Makefile - + testsuite/tests/bytecode/TLinkable/all.T - + testsuite/tests/bytecode/TLinkable/genLinkables.sh - + testsuite/tests/bytecode/TLinkable/linkable-space.hs - + testsuite/tests/bytecode/TLinkable/linkable-space.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout - + testsuite/tests/driver/recomp022/A1.hs - + testsuite/tests/driver/recomp022/A2.hs - + testsuite/tests/driver/recomp022/A3.hs - + testsuite/tests/driver/recomp022/B.hs - + testsuite/tests/driver/recomp022/C.hs - + testsuite/tests/driver/recomp022/Makefile - + testsuite/tests/driver/recomp022/all.T - + testsuite/tests/driver/recomp022/recomp022a.stdout - + testsuite/tests/driver/recomp022/recomp022b.stdout - + testsuite/tests/ghc-api/T25121_status.hs - + testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/all.T - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ce7f29af85fb5323d9578a2fe1adc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ce7f29af85fb5323d9578a2fe1adc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26002] 2 commits: Use changelog.d for release notes (#26002)
by Zubin (＠wz1000) 31 Mar '26

31 Mar '26

Zubin pushed to branch wip/26002 at Glasgow Haskell Compiler / GHC Commits: 17872bb0 by Zubin Duggal at 2026-03-31T16:15:24+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). - - - - - 5ce7f29a by Zubin Duggal at 2026-03-31T16:15:52+05:30 Sample changelog entries - - - - - 31 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/changelog-entries - + changelog.d/config - + changelog.d/fix-hsExprType - + changelog.d/fix-stm-catchRetry - + changelog.d/fix-unary-typeclass-default - + changelog.d/fix-windows-async-io - + changelog.d/infix-holes-types - + docs/users_guide/10.2.1-notes.rst - docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Default.hs - testsuite/mk/boilerplate.mk - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dd2e5d107e5dbd763f804ec96f446… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4dd2e5d107e5dbd763f804ec96f446… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/26002
by Zubin (＠wz1000) 31 Mar '26

31 Mar '26

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

1 0

[Git][ghc/ghc][wip/ani/no-ds-flag-cache] Fix an oversight in getDeepSubsumptionFlag
by Simon Peyton Jones (＠simonpj) 31 Mar '26

31 Mar '26

Simon Peyton Jones pushed to branch wip/ani/no-ds-flag-cache at Glasgow Haskell Compiler / GHC Commits: 3418bdba by Simon Peyton Jones at 2026-03-31T11:08:47+01:00 Fix an oversight in getDeepSubsumptionFlag - - - - - 1 changed file: - compiler/GHC/Tc/Gen/App.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -350,7 +350,7 @@ Unify result type /before/ typechecking the args The latter is much better. That is why we call `checkResultTy` before tcValArgs. -} --- CAUTION: Any changes to tcApp should be reflected in tcExprSigma + tcApp :: HsExpr GhcRn -> ExpRhoType -- When checking, -XDeepSubsumption <=> deeply skolemised -> TcM (HsExpr GhcTc) @@ -459,11 +459,15 @@ checkResultTy :: HsExpr GhcRn -- expose foralls, but maybe not /deeply/ instantiated -> ExpRhoType -- Expected type; this is deeply skolemised -> TcM HsWrapper -checkResultTy rn_expr _ _ app_res_rho (Infer inf_res) - = do { ds_flag <- getDeepSubsumptionFlag +checkResultTy rn_expr (tc_fun,_) _ app_res_rho (Infer inf_res) + = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun + -- We must deeply-instantiate data constructors + -- E.g. data T = MkT Int int + -- f = K 3 + -- We must infer f :: Int ->{many} T + -- and not f :: Int ->{one} T ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res } - checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) -- Unify with expected type from the context -- See Note [Unify with expected type before typechecking arguments] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3418bdbadd44cd7bf8b7cb47cf912c2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3418bdbadd44cd7bf8b7cb47cf912c2… You're receiving this email because of your account on gitlab.haskell.org.

1 0