Inline partially-applied wrappers
authorDavid Feuer <david.feuer@gmail.com>
Tue, 10 Jan 2017 21:33:20 +0000 (16:33 -0500)
committerDavid Feuer <David.Feuer@gmail.com>
Tue, 10 Jan 2017 21:57:19 +0000 (16:57 -0500)
Suppose we have

```
data Node a = Node2 !Int a a | Node3 !Int a a a
instance Traversable Node where
  traverse f (Node2 s x y) = Node2 s <$> f x <*> f y
  ...

```

Since `Node2` is partially applied, we wouldn't inline its
wrapper.  The result was that we'd box up the `Int#` to put
the box in the closure passed to `fmap`. We now allow the wrapper
to inline when partially applied, so GHC stores the `Int#`
directly in the closure.

Reviewers: rwbarton, mpickering, simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D2891

GHC Trac Issues: #12990

compiler/basicTypes/MkId.hs
testsuite/tests/deSugar/should_compile/T2431.stderr
testsuite/tests/perf/should_run/T12990.hs [new file with mode: 0644]
testsuite/tests/perf/should_run/all.T
testsuite/tests/simplCore/should_compile/T7360.stderr

index dc8b4d0..7c8ffed 100644 (file)
@@ -466,6 +466,32 @@ newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                        -- Bind these src-level vars, returning the
                        -- rep-level vars to bind in the pattern
 
+{-
+Note [Inline partially-applied constructor wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We allow the wrapper to inline when partially applied to avoid
+boxing values unnecessarily. For example, consider
+
+   data Foo a = Foo !Int a
+
+   instance Traversable Foo where
+     traverse f (Foo i a) = Foo i <$> f a
+
+This desugars to
+
+   traverse f foo = case foo of
+        Foo i# a -> let i = I# i#
+                    in map ($WFoo i) (f a)
+
+If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.
+But if we inline the wrapper, we get
+
+   map (\a. case i of I# i# a -> Foo i# a) (f a)
+
+and now case-of-known-constructor eliminates the redundant allocation.
+-}
+
 mkDataConRep :: DynFlags
              -> FamInstEnvs
              -> Name
@@ -498,16 +524,16 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              wrap_arg_dmds = map mk_dmd arg_ibangs
              mk_dmd str | isBanged str = evalDmd
                         | otherwise           = topDmd
-                 -- The Cpr info can be important inside INLINE rhss, where the
-                 -- wrapper constructor isn't inlined.
-                 -- And the argument strictness can be important too; we
-                 -- may not inline a constructor when it is partially applied.
-                 -- For example:
-                 --      data W = C !Int !Int !Int
-                 --      ...(let w = C x in ...(w p q)...)...
-                 -- we want to see that w is strict in its two arguments
-
-             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+
+             -- The wrapper will usually be inlined (see wrap_unf), so its
+             -- strictness and CPR info is usually irrelevant. But this is
+             -- not always the case; GHC may choose not to inline it. In
+             -- particular, the wrapper constructor is not inlined inside
+             -- an INLINE rhs or when it is not applied to any arguments.
+             -- See Note [Inline partially-applied constructor wrappers]
+             -- Passing Nothing here allows the wrapper to inline when
+             -- unsaturated.
+             wrap_unf = mkInlineUnfolding Nothing wrap_rhs
              wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
              wrap_rhs = mkLams wrap_tvs $
                         mkLams wrap_args $
index ff1047d..797c6c7 100644 (file)
@@ -9,7 +9,7 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
  Str=m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
-         Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=False)
+         Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
          Tmpl= \ (@ a) ->
                  T2431.Refl @ a @ a @~ (<a>_N :: (a :: *) GHC.Prim.~# (a :: *))}]
 T2431.$WRefl =
diff --git a/testsuite/tests/perf/should_run/T12990.hs b/testsuite/tests/perf/should_run/T12990.hs
new file mode 100644 (file)
index 0000000..f7655ac
--- /dev/null
@@ -0,0 +1,28 @@
+-- We used to inline constructor wrapper functions only when fully applied.
+-- This led to unnecessary boxing when partially applying to unpacked fields.
+
+module Main where
+import Control.DeepSeq
+import Data.Functor.Identity
+import Control.Exception (evaluate)
+
+data AList = Cons !Int !Int !Int !Int !Int !Int !Int !Int !Int AList | Nil
+
+-- We need to write this instance manually because the Generic-derived
+-- instance allocates a ton of intermediate junk, obscuring the interesting
+-- differences.
+instance NFData AList where
+  rnf Nil = ()
+  rnf (Cons _1 _2 _3 _4 _5 _6 _7 _8 _9 xs) = rnf xs
+
+-- If GHC is allowed to specialize it to Identity, the partial application of
+-- Cons will become a fully saturated one, defeating the test. So we NOINLINE
+-- it.
+buildalist :: Applicative f => Int -> f AList
+buildalist n
+  | n <= 0 = pure Nil
+  | otherwise = Cons n (n+1) (n+2) (n+3) (n+4) (n+5) (n+6) (n+7) (n+8) <$>
+                  buildalist (n - 1)
+{-# NOINLINE buildalist #-}
+
+main = evaluate . rnf . runIdentity $ buildalist 100000
index 89ae3ec..333970c 100644 (file)
@@ -460,3 +460,13 @@ test('T13001',
       only_ways(['normal'])],
      compile_and_run,
      ['-O2'])
+
+test('T12990',
+    [stats_num_field('bytes allocated',
+                     [ (wordsize(64), 21640904, 5) ]),
+                     # 2017-01-03     34440936  w/o inlining unsaturated
+                     #                          constructor wrappers
+                     # 2017-01-03     21640904 inline wrappers
+     only_ways(['normal'])],
+    compile_and_run,
+    ['-O2'])
index 4598b3e..2b0984c 100644 (file)
@@ -10,7 +10,7 @@ T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo
  Str=<S,U>m3,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
-         Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (dt [Occ=Once!] :: Int) ->
                  case dt of { GHC.Types.I# dt [Occ=Once] -> T7360.Foo3 dt }}]
 T7360.$WFoo3 =