Commit 4291bdda authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Major improvements to the specialiser

This patch is joint work of Alexis King and Simon PJ.  It does some
significant refactoring of the type-class specialiser.  Main highlights:

* We can specialise functions with types like
     f :: Eq a => a -> Ord b => b => blah
  where the classes aren't all at the front (#16473).  Here we can
  correctly specialise 'f' based on a call like
     f @Int @Bool dEqInt x dOrdBool
  This change really happened in an earlier patch
     commit 2d0cf625
     Author: Sandy Maguire <sandy@sandymaguire.me>
     Date:   Thu May 16 12:12:10 2019 -0400
  work that this new patch builds directly on that work, and refactors
  it a bit.

* We can specialise functions with implicit parameters (#17930)
     g :: (?foo :: Bool, Show a) => a -> String
  Previously we could not, but now they behave just like a non-class
  argument as in 'f' above.

* We can specialise under-saturated calls, where some (but not all of
  the dictionary arguments are provided (#17966).  For example, we can
  specialise the above 'f' based on a call
     map (f @Int dEqInt) xs
  even though we don't (and can't) give Ord dictionary.

  This may sound exotic, but #17966 is a program from the wild, and
  showed significant perf loss for functions like f, if you need
  saturation of all dictionaries.

* We fix a buglet in which a floated dictionary had a bogus demand
  (#17810), by using zapIdDemandInfo in the NonRec case of specBind.

* A tiny side benefit: we can drop dead arguments to specialised
  functions; see Note [Drop dead args from specialisations]

* Fixed a bug in deciding what dictionaries are "interesting"; see
  Note [Keep the old dictionaries interesting]

This is all achieved by by building on Sandy Macguire's work in
defining SpecArg, which mkCallUDs uses to describe the arguments of
the call. Main changes:

* Main work is in specHeader, which marched down the [InBndr] from the
  function definition and the [SpecArg] from the call site, together.

* specCalls no longer has an arity check; the entire mechanism now
  handles unders-saturated calls fine.

* mkCallUDs decides on an argument-by-argument basis whether to
  specialise a particular dictionary argument; this is new.
  See mk_spec_arg in mkCallUDs.

It looks as if there are many more lines of code, but I think that
all the extra lines are comments!
parent 1b7e8a94
This diff is collapsed.
......@@ -17,7 +17,7 @@ module GHC.Core.Subst (
deShadowBinds, substSpec, substRulesForImportedIds,
substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
lookupIdSubst, lookupTCvSubst, substIdOcc,
lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
......@@ -756,4 +756,3 @@ analyser, so it's possible that the worker is not even in scope any more.
In all all these cases we simply drop the special case, returning to
InlVanilla. The WARN is just so I can see if it happens a lot.
-}
......@@ -173,15 +173,16 @@ mkInlinableUnfolding dflags expr
where
expr' = simpleOptExpr dflags expr
specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
specUnfolding :: DynFlags -> Id -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
-> Unfolding -> Unfolding
-- See Note [Specialising unfoldings]
-- specUnfolding spec_bndrs spec_app arity_decrease unf
-- = \spec_bndrs. spec_app( unf )
--
specUnfolding dflags spec_bndrs spec_app arity_decrease
specUnfolding dflags fn spec_bndrs spec_app arity_decrease
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
= ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )
= ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs
, ppr df $$ ppr spec_bndrs $$ ppr (spec_app (Var fn)) $$ ppr arity_decrease )
mkDFunUnfolding spec_bndrs con (map spec_arg args)
-- There is a hard-to-check assumption here that the spec_app has
-- enough applications to exactly saturate the old_bndrs
......@@ -195,7 +196,7 @@ specUnfolding dflags spec_bndrs spec_app arity_decrease
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
specUnfolding dflags spec_bndrs spec_app arity_decrease
specUnfolding dflags _ spec_bndrs spec_app arity_decrease
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl
, uf_guidance = old_guidance })
......@@ -212,7 +213,7 @@ specUnfolding dflags spec_bndrs spec_app arity_decrease
in mkCoreUnfolding src top_lvl new_tmpl guidance
specUnfolding _ _ _ _ _ = noUnfolding
specUnfolding _ _ _ _ _ _ = noUnfolding
{- Note [Specialising unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -701,7 +701,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
spec_unf = specUnfolding dflags poly_id spec_bndrs core_app arity_decrease fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
......
......@@ -92,6 +92,12 @@ Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
......@@ -117,18 +123,19 @@ Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main)
Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main)
Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op <*> (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op <*> (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
......
......@@ -2,6 +2,11 @@ TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
T17966:
$(RM) -f T17966.o T17966.hi
- '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-spec T17966.hs 2> /dev/null | grep 'SPEC'
# Expecting a SPEC rule for $cm
T17409:
$(RM) -f T17409.o T17409.hi
- '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -dverbose-core2core -dsuppress-uniques T17409.hs 2> /dev/null | grep '\<id\>'
......
module T17801 where
import Control.Monad.Except
import T17810a
f :: ExceptT e (TCMT IO) ()
f = liftReduce
module T17810a where
import Control.Monad.Except
class Monad m => ReadTCState m where
locallyTCState :: m ()
liftReduce :: m ()
instance ReadTCState m => ReadTCState (ExceptT err m) where
locallyTCState = undefined
liftReduce = lift liftReduce
instance MonadIO m => ReadTCState (TCMT m) where
locallyTCState = (undefined <$> liftReduce) <* TCM (\_ -> return ())
liftReduce = undefined
newtype TCMT m a = TCM { unTCM :: () -> m a }
instance MonadIO m => Functor (TCMT m) where
fmap f (TCM m) = TCM $ \r -> liftM f (m r )
instance MonadIO m => Applicative (TCMT m) where
pure x = TCM (\_ -> return x)
(<*>) (TCM mf) (TCM m) = TCM $ \r -> ap (mf r) (m r)
instance MonadIO m => Monad (TCMT m) where
(>>=) (TCM m) k = TCM $ \r -> m r >>= \x -> unTCM (k x) r
{-# LANGUAGE ImplicitParams #-}
module T17930 where
foo :: (?b :: Bool, Show a) => a -> String
foo x | ?b = show x ++ "!"
| otherwise = show x ++ "."
{-# INLINABLE[0] foo #-}
str :: String
str = let ?b = True in foo "Hello"
$sfoo :: (?b::Bool) => [Char] -> [Char]
$sfoo
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-- The issue here is whether $cm gets a specialiation
-- See #17966
module T17966 where
class C a b where
m :: Show c => a -> b -> c -> String
instance Show b => C Bool b where
m a b c = show a ++ show b ++ show c
{-# INLINABLE [0] m #-}
f :: (C a b, Show c) => a -> b -> c -> String
f a b c = m a b c ++ "!"
{-# INLINABLE [0] f #-}
x :: String
x = f True () (Just 42)
RULES: "SPEC $cm @()" [0]
RULES: "SPEC f @Bool @() @(Maybe Integer)" [0]
"SPEC/T17966 $fShowMaybe_$cshowList @Integer"
"SPEC/T17966 $fShowMaybe @Integer"
......@@ -319,3 +319,10 @@ test('T17787', [ grep_errmsg(r'foo') ], compile, ['-ddump-simpl -dsuppress-uniq
test('T17901',
normal,
makefile_test, ['T17901'])
test('T17930', [ grep_errmsg(r'^\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques -dsuppress-idinfo'])
test('spec004', [ grep_errmsg(r'\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques'])
test('T17966',
normal,
makefile_test, ['T17966'])
# NB: T17810: -fspecialise-aggressively
test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
{-# LANGUAGE RankNTypes #-}
-- Dead arguments should be dropped in specialisations. See !2913.
module ShouldCompile where
foo :: () -> Show a => a -> String
foo _x y = show y ++ "!"
{-# NOINLINE[0] foo #-}
bar :: String
bar = foo () (42 :: Int)
==================== Specialise ====================
Result size of Specialise
= {terms: 53, types: 46, coercions: 0, joins: 0/0}
-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char]
[LclId]
$sfoo
= \ (y :: Int) ->
GHC.Base.build
@Char
(\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
GHC.Base.foldr
@Char
@b
c
(GHC.CString.unpackFoldrCString# @b "!"# c n)
(show @Int GHC.Show.$fShowInt y))
-- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0}
foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
[LclIdX,
Arity=3,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40},
RULES: "SPEC foo @Int" [0]
forall (dk :: ()) ($dShow :: Show Int). foo @Int dk $dShow = $sfoo]
foo
= \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) ->
GHC.Base.build
@Char
(\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
GHC.Base.foldr
@Char
@b
c
(GHC.CString.unpackFoldrCString# @b "!"# c n)
(show @a $dShow y))
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
$trModule = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}]
$trModule = "ShouldCompile"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
ShouldCompile.$trModule :: GHC.Types.Module
[LclIdX,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule
-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0}
bar :: String
[LclIdX,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 0}]
bar = foo @Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment