- ghc-devs - Haskell.org

Re: Lazy ST vs concurrency
by David Feuer 31 Jan '17

31 Jan '17

I think Ben's eagerlyBlackhole is what I called noDup. And it is indeed a bit tricky to use correctly. It needs the same sort of care around inlining that unsafePerformIO does. A bit of summary: 1. It's okay to duplicate a runST thunk or to enter it twice, because each copy will have its own set of references and arrays. This is important, because we have absolutely no control over what the user will do with such a thunk. 2. With the exception of a runST thunk, we must never duplicate or double-enter a thunk if it performs or suspends ST work. Based on my tests and the intuition I've developed about what's going on here, (2) breaks down into two pieces: 2a. Any time we perform or suspend ST work, we must use NOINLINE to avoid duplication. 2b. Any time we suspend ST work, we must set up the thunk involved with noDuplicate# or similar. For example, the code I wrote yesterday for the Applicative instance looks like this: fm <*> xm = ST $ \ s -> let {-# NOINLINE res1 #-} !res1 = unST fm s !(f, s') = res1 {-# NOINLINE res2 #-} res2 = noDup (unST xm s') (x, s'') = res2 in (f x, s'') I NOINLINE res1. If it were to inline (could that happen?), we'd get let res2 = noDup (unST xm (snd (unST fm s))) (x, s'') = res2 in (fst (unST fm s) x, s') and that would run the fm computation twice. But I don't noDup res1, because we force it immediately on creation; no one else ever handles it. I NOINLINE res2 for a similar reason, but I also use noDup on it. The res2 thunk escapes into the wild via x and s'' in the result; we need to make sure that it is not entered twice. I believe can use a few rewrite rules to reduce costs substantially in some situations. I will add those to the differential. -------- Original message -------- From: Simon Marlow <marlowsd(a)gmail.com> Date: 1/31/17 3:59 AM (GMT-05:00) To: Simon Peyton Jones <simonpj(a)microsoft.com> Cc: David Feuer <david(a)well-typed.com>, ghc-devs(a)haskell.org Subject: Re: Lazy ST vs concurrency On 30 January 2017 at 22:56, Simon Peyton Jones <simonpj(a)microsoft.com[1]> wrote: We don’t want to do this on a per-module basis do we, as -fatomic-eager-blackholing would suggest. Rather, on per-thunk basis, no? Which thunks, precisely? I think perhaps *precisely thunks one of whose free variables has type (Sttate# s) for some s.* These are thunks that consume a state token, and must do so no more than once.

1 0

Constant functions and selectors make for interesting arguments
by David Feuer 31 Jan '17

31 Jan '17

GHC's inliner has a notion of "interesting argument" it uses to encourage inlining of functions called with (I think) dictionary arguments. I think another class of argument is very interesting, by being very boring. Any argument that looks like either \ _ ... (Con _ ... x ... _ ) ... _ -> coerce x or \ _ ... _ -> k Has a pretty good chance of doing a lot of good when inlined, perhaps plugging a space leak. Would it make sense to try to identify such functions and consider them interesting for inlining?

4 5

Overloaded record fields for 8.2?
by Adam Gundry 30 Jan '17

30 Jan '17

Hi Ben, devs, I'd like to propose that we merge my latest ORF patch (https://phabricator.haskell.org/D2708) for 8.2 (modulo any code review improvements, of course). The corresponding proposal discussion (https://github.com/ghc-proposals/ghc-proposals/pull/6) seems to have reached a broad consensus. But it's not clear to me if some kind of final approval from the GHC committee is needed, or how to obtain that. This patch makes breaking changes to the experimental OverloadedLabels extension, and I think it would be good to make those quickly rather than having another release with the "old" version. Moreover, the work has been in progress for a long time, so it would be great to see it finally make it into a GHC release. Any objections? Adam -- Adam Gundry, Haskell Consultant Well-Typed LLP, http://www.well-typed.com/

2 1

Next steps of the trac-to-maniphest migration?
by Matthew Pickering 29 Jan '17

29 Jan '17

Hello devs, Thanks to everyone so far who has looked at and commented on the prototype. It seems that the response is generally positive so I would like to drive the process forwards. In order for that to happen, someone needs to decide whether we as a community think it is a good idea. It seems to make sense if those who use the tracker most make this decision so I propose that Simon and Ben should ultimately be the ones to do this. Therefore, I propose this timeline 1. Before 11th Feb (3 weeks from today) we decide whether we want to migrate the issue tracker. 2. A working group is established who will work through the details of the migration with the minimum of a final prototype built from a clone of the actual installation. 3. Migration would happen before the end of March. I think Ben summarised the discussions quite well on the wiki page - https://ghc.haskell.org/trac/ghc/wiki/Phabricator/Maniphest And the prototype continues to exist here. http://ec2-52-214-147-146.eu-west-1.compute.amazonaws.com/ As always, any comments welcome. Matt

3 8

quick building the user's guide
by Takenobu Tani 29 Jan '17

29 Jan '17

Dear devs, Can We build the user's guide without building the ghc binary? If so, new contributors can easily check the generated html. When I execute the following command, a binary build is always executed. # vi mk/build.mk (BuildFlavour = quick; BUILD_SPHINX_HTML = YES) # ./boot # ./configure # cd docs/users_guide/ # make html Is there a way to skip binary builds? Regards, Takenobu

2 2

simple pictures about GHC development flow
by Takenobu Tani 28 Jan '17

28 Jan '17

Hi devs, For myself and new contributors, I drew overview pictures about GHC development flow. GHC development flow http://takenobu-hs.github.io/downloads/ghc_development_flow.pdf https://github.com/takenobu-hs/ghc-development-flow If I misunderstood something, please teach me. I'll correct or remove them. Regards, Takenobu

4 15

Cannot build GHC using the Newcomers guide
by Marius Ghita 27 Jan '17

27 Jan '17

Following is a list of steps that I ran and their output linked: - clone repo https://gist.github.com/mhitza/f5d4516b6c8386fe8e064f95b5ad62 0b - build.mk configuration https://gist.github.com/mhitza/ 2d979c64a646bdd3e097f65fd650c675 - boot https://gist.github.com/mhitza/e23df8b9ed2aac5b1b8881c70165bf3f - configure https://gist.github.com/mhitza/88c09179be3bb82024192bf6181aef13 - make FAILS https://gist.github.com/mhitza/95738bf49c8c87ce46c9319b4c266a 2c I'm using a 'stack-ghc' executable, that's only a shell wrapper to run ghc from stack (since I don't have a globally installed ghc) (source https://gist.github.com/mhitza/38fe96fb440daab28e57a50de47863d5 ), and I also have 'ghc-pkg' wrapped in the same way with a stack-ghc-pkg script (source https://gist.github.com/mhitza/ 6c2b1978ef802707161041abe1d2699e ) -- Google+: https://plus.google.com/111881868112036203454

5 7

Problems with `arc` and `phabricator`
by Iavor Diatchki 26 Jan '17

26 Jan '17

Hello, I just fixed a small bug in GHC (#11406) and I'm trying to push the change to `phabricator` for review, but the command is failing. Here is my output, could you please advise on what to do? > arc diff Linting... LINT OKAY No lint problems. Running unit tests... No unit test engine is configured for this project. PUSH STAGING Pushing changes to staging area... Permission denied (publickey,keyboard-interactive). fatal: Could not read from remote repository. Please make sure you have the correct access rights and the repository exists. STAGING FAILED Unable to push changes to the staging area. Usage Exception: Failed to push changes to staging area. Correct the issue, or use --skip-staging to skip this step. Clearly, there is some sort of permission issue... -Iavor

3 3

RE: [commit: ghc] wip/discount-fv: Discount scrutinized free variables (fd9608e)
by Simon Peyton Jones 25 Jan '17

25 Jan '17

Long story short: learning and experimenting how GHC works and eventually contribute my findings (if any). OK great! Let us know if you need help. Simon From: Alex Biehl [mailto:alex.biehl@gmail.com] Sent: 25 January 2017 10:32 To: Simon Peyton Jones <simonpj(a)microsoft.com> Cc: ghc-devs(a)haskell.org Subject: Re: [commit: ghc] wip/discount-fv: Discount scrutinized free variables (fd9608e) I believe it was a false alarm. Unfortunately I could reproduce the reduced allocations even without my patch (I hadn't ran `validate` before, so I didn't know at that time). Ben was kind enough to push it to a branch so gipedia could pick up but it hadn't any effect either. What leaves me wondering though why are the allocations reduced drastically (by ~30% for haddock.cabal and haddock.base and even ~57% for T9203. c.f. https://ghc.haskell.org/trac/ghc/ticket/4960#comment:14) And not for others? I am using `./validate --testsuite-only --fast` (with a perf build GHC). The reason I did this was that I thought if I reduce `dupAppSize` in `CoreUtils` I could reduce code duplication in `case` expressions where GHC currently duplicates lots of alternatives (I only realized later that `dupAppSize` does not account for `case` expressions at all, so its probably some case-of-case stuff or something) in some of my code and I wanted to confirm if that is actually a good thing. I noticed the ticket and though before tackling that I will try myself on that discount stuff. Long story short: learning and experimenting how GHC works and eventually contribute my findings (if any). Simon Peyton Jones <simonpj(a)microsoft.com<mailto:simonpj@microsoft.com>> schrieb am Mi., 25. Jan. 2017 um 11:11 Uhr: Alex Interesting. Care to give us any background on what you are working on? I've often thought about discounting for free vars. Do you have some compelling examples? (Also fine if you just want to noodle privately for now.) Simon | -----Original Message----- | From: ghc-commits [mailto:ghc-commits-bounces@haskell.org<mailto:ghc-commits-bounces@haskell.org>] On Behalf Of | git(a)git.haskell.org<mailto:git@git.haskell.org> | Sent: 24 January 2017 17:20 | To: ghc-commits(a)haskell.org<mailto:ghc-commits@haskell.org> | Subject: [commit: ghc] wip/discount-fv: Discount scrutinized free | variables (fd9608e) | | Repository : ssh://git@git.haskell.org/ghc<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fgit%40git.h…> | | On branch : wip/discount-fv | Link : | https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fghc.haske | ll.org<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fll.org&data…>%2Ftrac%2Fghc%2Fchangeset%2Ffd9608ea93fc2389907b82c3fe540805d986c28 | e%2Fghc&data=02%7C01%7Csimonpj%40microsoft.com<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2F40microsoft…>%7C6b18dd9581bc459c203b08d4 | 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884& | sdata=3%2F1y5zQjDsa5j1%2FhTEjnKc4mg0qNtCD8WyqMaNUq5mA%3D&reserved=0 | | >--------------------------------------------------------------- | | commit fd9608ea93fc2389907b82c3fe540805d986c28e | Author: alexbiehl <alex.biehl(a)gmail.com<mailto:alex.biehl@gmail.com>> | Date: Mon Jan 23 20:34:20 2017 +0100 | | Discount scrutinized free variables | | | >--------------------------------------------------------------- | | fd9608ea93fc2389907b82c3fe540805d986c28e | compiler/coreSyn/CoreUnfold.hs | 95 +++++++++++++++++++++++++----------- | ------ | 1 file changed, 56 insertions(+), 39 deletions(-) | | diff --git a/compiler/coreSyn/CoreUnfold.hs | b/compiler/coreSyn/CoreUnfold.hs index 574d841..36ea382 100644 | --- a/compiler/coreSyn/CoreUnfold.hs | +++ b/compiler/coreSyn/CoreUnfold.hs | @@ -62,8 +62,11 @@ import Bag | import Util | import Outputable | import ForeignCall | +import VarEnv | | +import Control.Applicative ((<|>)) | import qualified Data.ByteString as BS | +import Debug.Trace | | {- | ************************************************************************ | @@ -501,43 +504,51 @@ sizeExpr :: DynFlags | -- Note [Computing the size of an expression] | | sizeExpr dflags bOMB_OUT_SIZE top_args expr | - = size_up expr | + = size_up emptyInScopeSet expr | where | - size_up (Cast e _) = size_up e | - size_up (Tick _ e) = size_up e | - size_up (Type _) = sizeZero -- Types cost nothing | - size_up (Coercion _) = sizeZero | - size_up (Lit lit) = sizeN (litSize lit) | - size_up (Var f) | isRealWorldId f = sizeZero | + size_up :: InScopeSet -> CoreExpr -> ExprSize | + size_up is (Cast e _) = size_up is e | + size_up is (Tick _ e) = size_up is e | + size_up _ (Type _) = sizeZero -- Types cost nothing | + size_up _ (Coercion _) = sizeZero | + size_up _ (Lit lit) = sizeN (litSize lit) | + size_up _ (Var f) | isRealWorldId f = sizeZero | -- Make sure we get constructor discounts even | -- on nullary constructors | - | otherwise = size_up_call f [] 0 | - | - size_up (App fun arg) | - | isTyCoArg arg = size_up fun | - | otherwise = size_up arg `addSizeNSD` | - size_up_app fun [arg] (if isRealWorldExpr arg | then 1 else 0) | - | - size_up (Lam b e) | - | isId b && not (isRealWorldId b) = lamScrutDiscount dflags | (size_up e `addSizeN` 10) | - | otherwise = size_up e | - | - size_up (Let (NonRec binder rhs) body) | - = size_up rhs `addSizeNSD` | - size_up body `addSizeN` | + | otherwise = size_up_call f [] 0 | + | + size_up is (App fun arg) | + | isTyCoArg arg = size_up is fun | + | otherwise = size_up is arg `addSizeNSD` | + size_up_app is fun [arg] (if isRealWorldExpr | + arg then 1 else 0) | + | + size_up is (Lam b e) | + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags | (size_up is e `addSizeN` 10) | + | otherwise = size_up is e | + | + size_up is (Let (NonRec binder rhs) body) | + = let | + is' = extendInScopeSet is binder | + in | + size_up is rhs `addSizeNSD` | + size_up is' body `addSizeN` | (if isUnliftedType (idType binder) then 0 else 10) | -- For the allocation | -- If the binder has an unlifted type there is no | allocation | | - size_up (Let (Rec pairs) body) | - = foldr (addSizeNSD . size_up . snd) | - (size_up body `addSizeN` (10 * length pairs)) -- | (length pairs) for the allocation | + size_up is (Let (Rec pairs) body) | + = let | + is' = extendInScopeSetList is (map fst pairs) | + in | + foldr (addSizeNSD . size_up is' . snd) | + (size_up is' body | + `addSizeN` (10 * length pairs)) -- (length pairs) | for the allocation | pairs | | - size_up (Case e _ _ alts) | - | Just v <- is_top_arg e -- We are scrutinising an argument | variable | + size_up is (Case e _ _ alts) | + | Just v <- is_top_arg e <|> is_free_var e -- We are | + scrutinising an argument variable or a free variable | = let | - alt_sizes = map size_up_alt alts | + alt_sizes = map (size_up_alt is) alts | | -- alts_size tries to compute a good discount for | -- the case when we are scrutinising an argument | variable @@ -569,9 +580,12 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | is_top_arg (Cast e _) = is_top_arg e | is_top_arg _ = Nothing | | + is_free_var (Var v) | not (v `elemInScopeSet` is) = Just v | + is_free_var (Cast e _) = is_free_var e | + is_free_var _ = Nothing | | - size_up (Case e _ _ alts) = size_up e `addSizeNSD` | - foldr (addAltSize . size_up_alt) | case_size alts | + size_up is (Case e _ _ alts) = size_up is e `addSizeNSD` | + foldr (addAltSize . size_up_alt is) | + case_size alts | where | case_size | | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (- | 10) @@ -608,15 +622,15 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | | ------------ | -- size_up_app is used when there's ONE OR MORE value args | - size_up_app (App fun arg) args voids | - | isTyCoArg arg = size_up_app fun args voids | - | isRealWorldExpr arg = size_up_app fun (arg:args) | (voids + 1) | - | otherwise = size_up arg `addSizeNSD` | - size_up_app fun (arg:args) | voids | - size_up_app (Var fun) args voids = size_up_call fun args voids | - size_up_app (Tick _ expr) args voids = size_up_app expr args voids | - size_up_app (Cast expr _) args voids = size_up_app expr args voids | - size_up_app other args voids = size_up other `addSizeN` | + size_up_app is (App fun arg) args voids | + | isTyCoArg arg = size_up_app is fun args voids | + | isRealWorldExpr arg = size_up_app is fun (arg:args) | (voids + 1) | + | otherwise = size_up is arg `addSizeNSD` | + size_up_app is fun (arg:args) | voids | + size_up_app _ (Var fun) args voids = size_up_call fun args | voids | + size_up_app is (Tick _ expr) args voids = size_up_app is expr args | voids | + size_up_app is (Cast expr _) args voids = size_up_app is expr args | voids | + size_up_app is other args voids = size_up is other | `addSizeN` | callSize (length args) voids | -- if the lhs is not an App or a Var, or an invisible thing like | a | -- Tick or Cast, then we should charge for a complete call plus | the @@ -633,7 +647,10 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | _ -> funSize dflags top_args fun (length | val_args) voids | | ------------ | - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 | + size_up_alt :: InScopeSet -> Alt Var -> ExprSize | + size_up_alt is (_con, bndrs, rhs) = size_up is' rhs `addSizeN` 10 | + where is' = extendInScopeSetList is bndrs | + | -- Don't charge for args, so that wrappers look cheap | -- (See comments about wrappers with Case) | -- | | _______________________________________________ | ghc-commits mailing list | ghc-commits(a)haskell.org<mailto:ghc-commits@haskell.org> | https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fmail.hask | ell.org<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fell.org&dat…>%2Fcgi-bin%2Fmailman%2Flistinfo%2Fghc- | commits&data=02%7C01%7Csimonpj%40microsoft.com<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2F40microsoft…>%7C6b18dd9581bc459c203b08d4 | 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884& | sdata=rGeUVlgqjfwCl%2FEdTX3%2BX0mQGX5UcS7bY9qadLT%2FSE4%3D&reserved=0

1 0

RE: [commit: ghc] wip/discount-fv: Discount scrutinized free variables (fd9608e)
by Simon Peyton Jones 25 Jan '17

25 Jan '17

Alex Interesting. Care to give us any background on what you are working on? I've often thought about discounting for free vars. Do you have some compelling examples? (Also fine if you just want to noodle privately for now.) Simon | -----Original Message----- | From: ghc-commits [mailto:ghc-commits-bounces@haskell.org] On Behalf Of | git(a)git.haskell.org | Sent: 24 January 2017 17:20 | To: ghc-commits(a)haskell.org | Subject: [commit: ghc] wip/discount-fv: Discount scrutinized free | variables (fd9608e) | | Repository : ssh://git@git.haskell.org/ghc | | On branch : wip/discount-fv | Link : | https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fghc.haske | ll.org%2Ftrac%2Fghc%2Fchangeset%2Ffd9608ea93fc2389907b82c3fe540805d986c28 | e%2Fghc&data=02%7C01%7Csimonpj%40microsoft.com%7C6b18dd9581bc459c203b08d4 | 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884& | sdata=3%2F1y5zQjDsa5j1%2FhTEjnKc4mg0qNtCD8WyqMaNUq5mA%3D&reserved=0 | | >--------------------------------------------------------------- | | commit fd9608ea93fc2389907b82c3fe540805d986c28e | Author: alexbiehl <alex.biehl(a)gmail.com> | Date: Mon Jan 23 20:34:20 2017 +0100 | | Discount scrutinized free variables | | | >--------------------------------------------------------------- | | fd9608ea93fc2389907b82c3fe540805d986c28e | compiler/coreSyn/CoreUnfold.hs | 95 +++++++++++++++++++++++++----------- | ------ | 1 file changed, 56 insertions(+), 39 deletions(-) | | diff --git a/compiler/coreSyn/CoreUnfold.hs | b/compiler/coreSyn/CoreUnfold.hs index 574d841..36ea382 100644 | --- a/compiler/coreSyn/CoreUnfold.hs | +++ b/compiler/coreSyn/CoreUnfold.hs | @@ -62,8 +62,11 @@ import Bag | import Util | import Outputable | import ForeignCall | +import VarEnv | | +import Control.Applicative ((<|>)) | import qualified Data.ByteString as BS | +import Debug.Trace | | {- | ************************************************************************ | @@ -501,43 +504,51 @@ sizeExpr :: DynFlags | -- Note [Computing the size of an expression] | | sizeExpr dflags bOMB_OUT_SIZE top_args expr | - = size_up expr | + = size_up emptyInScopeSet expr | where | - size_up (Cast e _) = size_up e | - size_up (Tick _ e) = size_up e | - size_up (Type _) = sizeZero -- Types cost nothing | - size_up (Coercion _) = sizeZero | - size_up (Lit lit) = sizeN (litSize lit) | - size_up (Var f) | isRealWorldId f = sizeZero | + size_up :: InScopeSet -> CoreExpr -> ExprSize | + size_up is (Cast e _) = size_up is e | + size_up is (Tick _ e) = size_up is e | + size_up _ (Type _) = sizeZero -- Types cost nothing | + size_up _ (Coercion _) = sizeZero | + size_up _ (Lit lit) = sizeN (litSize lit) | + size_up _ (Var f) | isRealWorldId f = sizeZero | -- Make sure we get constructor discounts even | -- on nullary constructors | - | otherwise = size_up_call f [] 0 | - | - size_up (App fun arg) | - | isTyCoArg arg = size_up fun | - | otherwise = size_up arg `addSizeNSD` | - size_up_app fun [arg] (if isRealWorldExpr arg | then 1 else 0) | - | - size_up (Lam b e) | - | isId b && not (isRealWorldId b) = lamScrutDiscount dflags | (size_up e `addSizeN` 10) | - | otherwise = size_up e | - | - size_up (Let (NonRec binder rhs) body) | - = size_up rhs `addSizeNSD` | - size_up body `addSizeN` | + | otherwise = size_up_call f [] 0 | + | + size_up is (App fun arg) | + | isTyCoArg arg = size_up is fun | + | otherwise = size_up is arg `addSizeNSD` | + size_up_app is fun [arg] (if isRealWorldExpr | + arg then 1 else 0) | + | + size_up is (Lam b e) | + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags | (size_up is e `addSizeN` 10) | + | otherwise = size_up is e | + | + size_up is (Let (NonRec binder rhs) body) | + = let | + is' = extendInScopeSet is binder | + in | + size_up is rhs `addSizeNSD` | + size_up is' body `addSizeN` | (if isUnliftedType (idType binder) then 0 else 10) | -- For the allocation | -- If the binder has an unlifted type there is no | allocation | | - size_up (Let (Rec pairs) body) | - = foldr (addSizeNSD . size_up . snd) | - (size_up body `addSizeN` (10 * length pairs)) -- | (length pairs) for the allocation | + size_up is (Let (Rec pairs) body) | + = let | + is' = extendInScopeSetList is (map fst pairs) | + in | + foldr (addSizeNSD . size_up is' . snd) | + (size_up is' body | + `addSizeN` (10 * length pairs)) -- (length pairs) | for the allocation | pairs | | - size_up (Case e _ _ alts) | - | Just v <- is_top_arg e -- We are scrutinising an argument | variable | + size_up is (Case e _ _ alts) | + | Just v <- is_top_arg e <|> is_free_var e -- We are | + scrutinising an argument variable or a free variable | = let | - alt_sizes = map size_up_alt alts | + alt_sizes = map (size_up_alt is) alts | | -- alts_size tries to compute a good discount for | -- the case when we are scrutinising an argument | variable @@ -569,9 +580,12 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | is_top_arg (Cast e _) = is_top_arg e | is_top_arg _ = Nothing | | + is_free_var (Var v) | not (v `elemInScopeSet` is) = Just v | + is_free_var (Cast e _) = is_free_var e | + is_free_var _ = Nothing | | - size_up (Case e _ _ alts) = size_up e `addSizeNSD` | - foldr (addAltSize . size_up_alt) | case_size alts | + size_up is (Case e _ _ alts) = size_up is e `addSizeNSD` | + foldr (addAltSize . size_up_alt is) | + case_size alts | where | case_size | | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (- | 10) @@ -608,15 +622,15 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | | ------------ | -- size_up_app is used when there's ONE OR MORE value args | - size_up_app (App fun arg) args voids | - | isTyCoArg arg = size_up_app fun args voids | - | isRealWorldExpr arg = size_up_app fun (arg:args) | (voids + 1) | - | otherwise = size_up arg `addSizeNSD` | - size_up_app fun (arg:args) | voids | - size_up_app (Var fun) args voids = size_up_call fun args voids | - size_up_app (Tick _ expr) args voids = size_up_app expr args voids | - size_up_app (Cast expr _) args voids = size_up_app expr args voids | - size_up_app other args voids = size_up other `addSizeN` | + size_up_app is (App fun arg) args voids | + | isTyCoArg arg = size_up_app is fun args voids | + | isRealWorldExpr arg = size_up_app is fun (arg:args) | (voids + 1) | + | otherwise = size_up is arg `addSizeNSD` | + size_up_app is fun (arg:args) | voids | + size_up_app _ (Var fun) args voids = size_up_call fun args | voids | + size_up_app is (Tick _ expr) args voids = size_up_app is expr args | voids | + size_up_app is (Cast expr _) args voids = size_up_app is expr args | voids | + size_up_app is other args voids = size_up is other | `addSizeN` | callSize (length args) voids | -- if the lhs is not an App or a Var, or an invisible thing like | a | -- Tick or Cast, then we should charge for a complete call plus | the @@ -633,7 +647,10 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr | _ -> funSize dflags top_args fun (length | val_args) voids | | ------------ | - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 | + size_up_alt :: InScopeSet -> Alt Var -> ExprSize | + size_up_alt is (_con, bndrs, rhs) = size_up is' rhs `addSizeN` 10 | + where is' = extendInScopeSetList is bndrs | + | -- Don't charge for args, so that wrappers look cheap | -- (See comments about wrappers with Case) | -- | | _______________________________________________ | ghc-commits mailing list | ghc-commits(a)haskell.org | https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fmail.hask | ell.org%2Fcgi-bin%2Fmailman%2Flistinfo%2Fghc- | commits&data=02%7C01%7Csimonpj%40microsoft.com%7C6b18dd9581bc459c203b08d4 | 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884& | sdata=rGeUVlgqjfwCl%2FEdTX3%2BX0mQGX5UcS7bY9qadLT%2FSE4%3D&reserved=0

2 1