[commit: ghc] wip/discount-fv: Discount scrutinized free variables (fd9608e)
Simon Peyton Jones
simonpj at microsoft.com
Wed Jan 25 23:40:11 UTC 2017
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 at gmail.com]
Sent: 25 January 2017 10:32
To: Simon Peyton Jones <simonpj at microsoft.com>
Cc: ghc-devs at 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 at microsoft.com<mailto:simonpj at 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 at haskell.org<mailto:ghc-commits-bounces at haskell.org>] On Behalf Of
| git at git.haskell.org<mailto:git at git.haskell.org>
| Sent: 24 January 2017 17:20
| To: ghc-commits at haskell.org<mailto:ghc-commits at 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.haskell.org%2Fghc&data=02%7C01%7Csimonpj%40microsoft.com%7Caed78e8369f94b75d66a08d4450d6406%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636209371202035595&sdata=l5xJmng0a25tj5stOwHOvAv4kbW%2FbjPLosVpk5dYgvs%3D&reserved=0>
|
| 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=02%7C01%7Csimonpj%40microsoft.com%7Caed78e8369f94b75d66a08d4450d6406%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636209371202055605&sdata=1RcKcmd6%2FeKlRwYwn2W0wNUQM7H9iMCyT0Vv1GznjLo%3D&reserved=0>%2Ftrac%2Fghc%2Fchangeset%2Ffd9608ea93fc2389907b82c3fe540805d986c28
| e%2Fghc&data=02%7C01%7Csimonpj%40microsoft.com<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2F40microsoft.com&data=02%7C01%7Csimonpj%40microsoft.com%7Caed78e8369f94b75d66a08d4450d6406%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636209371202055605&sdata=DI6gAH9d6JijQuhi3FQXMHc4oEFKVVFq0OcZRfnZq4s%3D&reserved=0>%7C6b18dd9581bc459c203b08d4
| 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884&
| sdata=3%2F1y5zQjDsa5j1%2FhTEjnKc4mg0qNtCD8WyqMaNUq5mA%3D&reserved=0
|
| >---------------------------------------------------------------
|
| commit fd9608ea93fc2389907b82c3fe540805d986c28e
| Author: alexbiehl <alex.biehl at gmail.com<mailto:alex.biehl at 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 at haskell.org<mailto:ghc-commits at 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&data=02%7C01%7Csimonpj%40microsoft.com%7Caed78e8369f94b75d66a08d4450d6406%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636209371202055605&sdata=IWRk1wqqENc614l5qjal8TvaUKI0UWqDRkRda2RZkiA%3D&reserved=0>%2Fcgi-bin%2Fmailman%2Flistinfo%2Fghc-
| commits&data=02%7C01%7Csimonpj%40microsoft.com<https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2F40microsoft.com&data=02%7C01%7Csimonpj%40microsoft.com%7Caed78e8369f94b75d66a08d4450d6406%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636209371202055605&sdata=DI6gAH9d6JijQuhi3FQXMHc4oEFKVVFq0OcZRfnZq4s%3D&reserved=0>%7C6b18dd9581bc459c203b08d4
| 447d482c%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636208752257772884&
| sdata=rGeUVlgqjfwCl%2FEdTX3%2BX0mQGX5UcS7bY9qadLT%2FSE4%3D&reserved=0
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-devs/attachments/20170125/76ba6ffd/attachment-0001.html>
More information about the ghc-devs
mailing list