Improve CPR behavior for strict constructors
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Jun 2015 10:40:01 +0000 (11:40 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Jun 2015 16:53:22 +0000 (17:53 +0100)
When working on Trac #10482 I noticed that we could give constructor
arguments the CPR property if they are use strictly.

This is documented carefully in
    Note [CPR in a product case alternative]
and also
    Note [Initial CPR for strict binders]

There are a bunch of intersting examples in
    Note [CPR examples]
which I have added to the test suite as T10482a.

I also added a test for #10482 itself.

compiler/stranal/DmdAnal.hs
testsuite/tests/stranal/T10482a.hs [new file with mode: 0644]
testsuite/tests/stranal/should_compile/Makefile
testsuite/tests/stranal/should_compile/T10482.hs [new file with mode: 0644]
testsuite/tests/stranal/should_compile/T10482.stdout [new file with mode: 0644]
testsuite/tests/stranal/should_compile/T10482a.hs [new file with mode: 0644]
testsuite/tests/stranal/should_compile/T10482a.stdout [new file with mode: 0644]
testsuite/tests/stranal/should_compile/all.T

index a0e5fef..79dd492 100644 (file)
@@ -214,24 +214,12 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
   , isJust (isDataProductTyCon_maybe tycon)
   , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
   = let
-        env_w_tc      = env { ae_rec_tc = rec_tc' }
-        env_alt       = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig
-        case_bndr_sig = cprProdSig (dataConRepArity dc)
-                -- cprProdSig: inside the alternative, the case binder has the CPR property.
-                -- Meaning that a case on it will successfully cancel.
-                -- Example:
-                --      f True  x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
-                --      f False x = I# 3
-                --
-                -- We want f to have the CPR property:
-                --      f b x = case fw b x of { r -> I# r }
-                --      fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
-                --      fw False x = 3
-
-        (rhs_ty, rhs')                  = dmdAnal env_alt dmd rhs
-        (alt_ty1, dmds)                 = findBndrsDmds env rhs_ty bndrs
-        (alt_ty2, case_bndr_dmd)        = findBndrDmd env False alt_ty1 case_bndr
-        id_dmds                         = addCaseBndrDmd case_bndr_dmd dmds
+        env_w_tc                 = env { ae_rec_tc = rec_tc' }
+        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs
+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
         alt_ty3 | io_hack_reqd dc bndrs = deferAfterIO alt_ty2
                 | otherwise             = alt_ty2
 
@@ -432,50 +420,6 @@ in this case.
 In other words, for locally-bound lambdas we can infer
 one-shotness.
 
-Note [Add demands for strict constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this program (due to Roman):
-
-    data X a = X !a
-
-    foo :: X Int -> Int -> Int
-    foo (X a) n = go 0
-     where
-       go i | i < n     = a + go (i+1)
-            | otherwise = 0
-
-We want the worker for 'foo' too look like this:
-
-    $wfoo :: Int# -> Int# -> Int#
-
-with the first argument unboxed, so that it is not eval'd each time
-around the 'go' loop (which would otherwise happen, since 'foo' is not
-strict in 'a').  It is sound for the wrapper to pass an unboxed arg
-because X is strict, so its argument must be evaluated.  And if we
-*don't* pass an unboxed argument, we can't even repair it by adding a
-`seq` thus:
-
-    foo (X a) n = a `seq` go 0
-
-because the seq is discarded (very early) since X is strict!
-
-We achieve the effect using addDataConStrictness.  It is called at a
-case expression, such as the pattern match on (X a) in the example
-above.  After computing how 'a' is used in the alternatives, we add an
-extra 'seqDmd' to it.  The case alternative isn't itself strict in the
-sub-components, but simply evaluating the scrutinee to HNF does force
-those sub-components.
-
-If the argument is not used at all in the alternative (i.e. it is
-Absent), then *don't* add a 'seqDmd'.  If we do, it makes it look used
-and hence it'll be passed to the worker when it doesn't need to be.
-Hence the isAbsDmd test in addDataConStrictness.
-
-There is the usual danger of reboxing, which as usual we ignore. But
-if X is monomorphic, and has an UNPACK pragma, then this optimisation
-is even more important.  We don't want the wrapper to rebox an unboxed
-argument, and pass an Int to $wfoo!
-
 
 ************************************************************************
 *                                                                      *
@@ -1097,6 +1041,30 @@ extendSigsWithLam env id
   | otherwise
   = env
 
+extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
+-- See Note [CPR in a product case alternative]
+extendEnvForProdAlt env scrut case_bndr dc bndrs
+  = foldl do_con_arg env1 ids_w_strs
+  where
+    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
+
+    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc
+    case_bndr_sig = cprProdSig (dataConRepArity dc)
+    fam_envs      = ae_fam_envs env
+
+    do_con_arg env (id, str)
+       |  ae_virgin env || isStrictDmd (idDemandInfo id)  -- c.f. extendSigsWithLam
+          || (is_var_scrut && isMarkedStrict str)         -- See Note [CPR in a product case alternative]
+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id
+       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
+       | otherwise
+       = env
+
+    is_var_scrut = is_var scrut
+    is_var (Cast e _) = is_var e
+    is_var (Var v)    = isLocalId v
+    is_var _          = False
+
 addDataConStrictness :: DataCon -> [Demand] -> [Demand]
 -- See Note [Add demands for strict constructors]
 addDataConStrictness con ds
@@ -1158,7 +1126,98 @@ dumpStrSig binds = vcat (map printId ids)
   printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
              | otherwise       = empty
 
-{-
+{- Note [CPR in a product case alternative]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case alternative for a product type, we want to give some of the
+binders the CPR property.  Specifically
+
+ * The case binder; inside the alternative, the case binder always has
+   the CPR property, meaning that a case on it will successfully cancel.
+   Example:
+        f True  x = case x of y { I# x' -> if x' ==# 3
+                                           then y
+                                           else I# 8 }
+        f False x = I# 3
+
+   By giving 'y' the CPR property, we ensure that 'f' does too, so we get
+        f b x = case fw b x of { r -> I# r }
+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
+        fw False x = 3
+
+   Of course there is the usual risk of re-boxing: we have 'x' available
+   boxed and unboxed, but we return the unboxed verison for the wrapper to
+   box.  If the wrapper doesn't cancel with its caller, we'll end up
+   re-boxing something that we did have available in boxed form.
+
+ * Any strict binders with product type, can use
+   Note [Initial CPR for strict binders].  But we can go a little
+   further. Consider
+
+      data T = MkT !Int Int
+
+      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))
+                   | otherwise = x
+
+   For $wf2 we are going to unbox the MkT *and*, since it is strict, the
+   first agument of the MkT; see Note [Add demands for strict constructors].
+   But then we don't want box it up again when returning it!  We want
+   'f2' to have the CPR property, so we give 'x' the CPR property.
+
+   It's a bit delicate because if this case is scrutinising something other
+   than an argument the original function, we really don't have the unboxed
+   version available.  E.g
+      g v = case foo v of
+              MkT x y | y>0       -> ...
+                      | otherwise -> x
+   Here we don't have the unboxed 'x' available.  Hence the is_var_scrut
+   test when making use of the strictness annoatation.  Slight ad-hoc,
+   but nothing terrible happens if we get it wrong.
+
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+    data X a = X !a
+
+    foo :: X Int -> Int -> Int
+    foo (X a) n = go 0
+     where
+       go i | i < n     = a + go (i+1)
+            | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+    $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the 'go' loop (which would otherwise happen, since 'foo' is not
+strict in 'a').  It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated.  And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+    foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+We achieve the effect using addDataConStrictness.  It is called at a
+case expression, such as the pattern match on (X a) in the example
+above.  After computing how 'a' is used in the alternatives, we add an
+extra 'seqDmd' to it.  The case alternative isn't itself strict in the
+sub-components, but simply evaluating the scrutinee to HNF does force
+those sub-components.
+
+If the argument is not used at all in the alternative (i.e. it is
+Absent), then *don't* add a 'seqDmd'.  If we do, it makes it look used
+and hence it'll be passed to the worker when it doesn't need to be.
+Hence the isAbsDmd test in addDataConStrictness.
+
+There is the usual danger of reboxing, which as usual we ignore. But
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important.  We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
+
 Note [Initial CPR for strict binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 CPR is initialized for a lambda binder in an optimistic manner, i.e,
@@ -1167,19 +1226,92 @@ a product are used, which is checked by the value of the absence
 demand.
 
 If the binder is marked demanded with a strict demand, then give it a
-CPR signature, because in the likely event that this is a lambda on a
-fn defn [we only use this when the lambda is being consumed with a
-call demand], it'll be w/w'd and so it will be CPR-ish.  E.g.
-
-        f = \x::(Int,Int).  if ...strict in x... then
-                                x
-                            else
-                                (a,b)
-We want f to have the CPR property because x does, by the time f has been w/w'd
-
-Also note that we only want to do this for something that definitely
-has product type, else we may get over-optimistic CPR results
-(e.g. from \x -> x!).
+CPR signature. Here's a concrete example ('f1' in test T10482a),
+assuming h is strict:
+
+  f1 :: Int -> Int
+  f1 x = case h x of
+          A -> x
+          B -> f1 (x-1)
+          C -> x+1
+
+If we notice that 'x' is used strictly, we can give it the CPR
+property; and hence f1 gets the CPR property too.  It's ok to give it
+the CPR property because by the time 'x' is returned (case A above),
+it'll have been evaluated (by the wrapper of 'h' in the example), and
+so the unboxed version will be available.
+
+Moreover, if f itself is strict in x, then we'll pass x unboxed to
+f1, and so the boxed version *won't* be available; in that case it's
+more important to give 'x' the CPR property.
+
+Note that
+
+  * We only want to do this for something that definitely
+    has product type, else we may get over-optimistic CPR results
+    (e.g. from \x -> x!).
+
+  * This works for both lambda and case-alternative binders. For
+    case binders consider
+        g (Left x) = case h x of
+                       A -> x
+                       B -> ...
+                       C -> x+1
+    Since 'h' evaluates x, we'll have it available unboxed even
+    though in this case it won't be passed in unboxed.
+
+Note [CPR examples]
+~~~~~~~~~~~~~~~~~~~~
+Here are some examples, in stranal/should_compile/T10482a.
+The main point: all of these functions can have the CPR property
+
+    ------- f1 -----------
+    -- x is used strictly by h, so it'll be available
+    -- unboxed before it is returned in the True branch
+
+    f1 :: Int -> Int
+    f1 x = case h x x of
+            True  -> x
+            False -> f1 (x-1)
+
+
+    ------- f2 -----------
+    -- x is a strict field of MkT2, so we'll pass it unboxed
+    -- to $wf2, so it's available unboxed.  This depends on
+    -- the case expression analysing (a subcomponent of) one
+    -- of the original arguments to the function, so it's
+    -- a bit more delicate.
+
+    data T2 = MkT2 !Int Int
+
+    f2 :: T2 -> Int
+    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+                  | otherwise = x
+
+
+    ------- f3 -----------
+    -- h is strict in x, so x will be unboxed before it
+    -- is rerturned in the otherwise case.
+
+    data T3 = MkT3 Int Int
+
+    f1 :: T3 -> Int
+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+                  | otherwise = x
+
+
+    ------- f4 -----------
+    -- Just like f2, but MkT4 can't unbox its strict
+    -- argument automatically, as f2 can
+
+    data family Foo a
+    newtype instance Foo Int = Foo Int
+
+    data T4 a = MkT4 !(Foo a) Int
+
+    f4 :: T4 Int -> Int
+    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                          | otherwise = v
 
 
 Note [Initialising strictness]
diff --git a/testsuite/tests/stranal/T10482a.hs b/testsuite/tests/stranal/T10482a.hs
new file mode 100644 (file)
index 0000000..3547ebd
--- /dev/null
@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
+                -- Makes f2 a bit more challenging
+
+module Foo where
+
+
+h :: Int -> Int -> Bool
+h 0 y = y>0
+h n y = h (n-1) y
+
+-- The main point: all of these functions can have the CPR property
+
+------- f1 -----------
+-- x is used strictly by h, so it'll be available
+-- unboxed before it is returned in the True branch
+
+f1 :: Int -> Int
+f1 x = case h x x of
+        True  -> x
+        False -> f1 (x-1)
+
+
+------- f2 -----------
+-- x is a strict field of MkT2, so we'll pass it unboxed
+-- to $wf2, so it's available unboxed.  This depends on
+-- the case expression analysing (a subcomponent of) one
+-- of the original arguments to the function, so it's
+-- a bit more delicate.
+
+data T2 = MkT2 !Int Int
+
+f2 :: T2 -> Int
+f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+              | y>1       = 1
+              | otherwise = x
+
+
+------- f3 -----------
+-- h is strict in x, so x will be unboxed before it
+-- is rerturned in the otherwise case.
+
+data T3 = MkT3 Int Int
+
+f1 :: T3 -> Int
+f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+              | otherwise = x
+
+
+------- f4 -----------
+-- Just like f2, but MkT4 can't unbox its strict
+-- argument automatically, as f2 can
+
+data family Foo a
+newtype instance Foo Int = Foo Int
+
+data T4 a = MkT4 !(Foo a) Int
+
+f4 :: T4 Int -> Int
+f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                      | otherwise = v
index 9101fbd..32cc924 100644 (file)
@@ -1,3 +1,15 @@
 TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+# T10482
+#   The intent here is to check that $wfoo has type
+#         $wfoo :: Int# -> Int# -> Int
+#   with two unboxed args.  See Trac #10482 for background
+T10482:
+       $(RM) -f T10482.o T10482.hi
+       '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T10482.hs | grep 'T10482.*wfoo.*Int'
+
+T10482a:
+       $(RM) -f T10482a.o T10482a.hi
+       '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T10482a.hs | grep 'wf.*Int'
diff --git a/testsuite/tests/stranal/should_compile/T10482.hs b/testsuite/tests/stranal/should_compile/T10482.hs
new file mode 100644 (file)
index 0000000..ef7c29c
--- /dev/null
@@ -0,0 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+module T10482 where
+
+data family Foo a
+data instance Foo (a, b) = FooPair !(Foo a) !(Foo b)
+newtype instance Foo Int = Foo Int
+
+foo :: Foo ((Int, Int), Int) -> Int -> Int
+foo !f k =
+  if k == 0 then 0
+  else if even k then foo f (k-1)
+  else case f of
+    FooPair (FooPair (Foo n) _) _ -> n
diff --git a/testsuite/tests/stranal/should_compile/T10482.stdout b/testsuite/tests/stranal/should_compile/T10482.stdout
new file mode 100644 (file)
index 0000000..010cb4c
--- /dev/null
@@ -0,0 +1 @@
+T10482.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
diff --git a/testsuite/tests/stranal/should_compile/T10482a.hs b/testsuite/tests/stranal/should_compile/T10482a.hs
new file mode 100644 (file)
index 0000000..e633ebe
--- /dev/null
@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
+                -- Makes f2 a bit more challenging
+
+-- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482
+
+module Foo where
+
+
+h :: Int -> Int -> Bool
+h 0 y = y>0
+h n y = h (n-1) y
+
+-- The main point: all of these functions can have the CPR property
+
+------- f1 -----------
+-- x is used strictly by h, so it'll be available
+-- unboxed before it is returned in the True branch
+
+f1 :: Int -> Int
+f1 x = case h x x of
+        True  -> x
+        False -> f1 (x-1)
+
+
+------- f2 -----------
+-- x is a strict field of MkT2, so we'll pass it unboxed
+-- to $wf2, so it's available unboxed.  This depends on
+-- the case expression analysing (a subcomponent of) one
+-- of the original arguments to the function, so it's
+-- a bit more delicate.
+
+data T2 = MkT2 !Int Int
+
+f2 :: T2 -> Int
+f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+              | y>1       = 1
+              | otherwise = x
+
+
+------- f3 -----------
+-- h is strict in x, so x will be unboxed before it
+-- is rerturned in the otherwise case.
+
+data T3 = MkT3 Int Int
+
+f3 :: T3 -> Int
+f3 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+              | otherwise = x
+
+
+------- f4 -----------
+-- Just like f2, but MkT4 can't unbox its strict
+-- argument automatically, as f2 can
+
+data family Foo a
+newtype instance Foo Int = Foo Int
+
+data T4 a = MkT4 !(Foo a) Int
+
+f4 :: T4 Int -> Int
+f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                      | otherwise = v
diff --git a/testsuite/tests/stranal/should_compile/T10482a.stdout b/testsuite/tests/stranal/should_compile/T10482a.stdout
new file mode 100644 (file)
index 0000000..bb19e36
--- /dev/null
@@ -0,0 +1,4 @@
+Foo.$wf2 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+Foo.$wf1 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int#
+Foo.$wf3 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+Foo.$wf4 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
index 62a4306..54b7736 100644 (file)
@@ -20,6 +20,12 @@ test('T8467', normal, compile, [''])
 test('T8037', normal, compile, [''])
 test('T8743', [ extra_clean(['T8743.o-boot', 'T8743a.hi', 'T8743a.o', 'T8743.hi-boot']) ], multimod_compile, ['T8743', '-v0'])
 
+# test('T10482', normal, compile, [''])
+
+test('T10482',  only_ways(['normal']), run_command, ['$MAKE -s --no-print-directory T10482'])
+test('T10482a', only_ways(['normal']), run_command, ['$MAKE -s --no-print-directory T10482a'])
+
 test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, [''])
 # T9208 fails (and should do so) if you have assertion checking on in the compiler
 # Hence the above expect_broken.  See comments in the Trac ticket
+