I think the motivation was your suggestion in #4960. Matt On Wed, Jan 25, 2017 at 10:11 AM, Simon Peyton Jones via ghc-devs wrote:

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@git.haskell.org | Sent: 24 January 2017 17:20 | To: ghc-commits@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 | 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@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 _______________________________________________ ghc-devs mailing list ghc-devs@haskell.org http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-devs