[commit: ghc] wip/discount-fv: Discount scrutinized free variables (fd9608e)
Matthew Pickering
matthewtpickering at gmail.com
Wed Jan 25 10:38:30 UTC 2017
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
<ghc-devs at haskell.org> 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 at haskell.org] On Behalf Of
> | git at git.haskell.org
> | Sent: 24 January 2017 17:20
> | To: ghc-commits at 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 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
> | 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 at haskell.org
> http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-devs
More information about the ghc-devs
mailing list