Derive the definition of null
authorDavid Feuer <david.feuer@gmail.com>
Sun, 2 Apr 2017 20:20:20 +0000 (16:20 -0400)
committerDavid Feuer <David.Feuer@gmail.com>
Sun, 2 Apr 2017 20:20:22 +0000 (16:20 -0400)
We can sometimes produce much better code by deriving the
definition of `null` rather than using the default. For example,
given

    data SnocList a = Lin | Snoc (SnocList a) a

the default definition of `null` will walk the whole list, but of
course we can stop as soon as we see `Snoc`. Similarly, if a
constructor contains some other `Foldable` type, we want to use its
`null` rather than folding over the structure.

Partially fixes Trac #13280

Reviewers: austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: rwbarton, thomie

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

compiler/prelude/PrelNames.hs
compiler/typecheck/TcGenFunctor.hs
docs/users_guide/8.4.1-notes.rst
docs/users_guide/glasgow_exts.rst
testsuite/tests/perf/should_run/DeriveNullTermination.hs [new file with mode: 0644]
testsuite/tests/perf/should_run/DeriveNullTermination.stdout [new file with mode: 0644]
testsuite/tests/perf/should_run/all.T

index 94c2d64..1f9f8f3 100644 (file)
@@ -836,7 +836,8 @@ uIntHash_RDR    = varQual_RDR gHC_GENERICS (fsLit "uInt#")
 uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")
 
 fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,
-    foldMap_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
+    foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,
+    mappend_RDR :: RdrName
 fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")
 replace_RDR             = varQual_RDR gHC_BASE (fsLit "<$")
 pure_RDR                = nameRdrName pureAName
@@ -844,6 +845,8 @@ ap_RDR                  = nameRdrName apAName
 liftA2_RDR              = varQual_RDR gHC_BASE (fsLit "liftA2")
 foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")
 foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
+null_RDR                = varQual_RDR dATA_FOLDABLE       (fsLit "null")
+all_RDR                 = varQual_RDR dATA_FOLDABLE       (fsLit "all")
 traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
 mempty_RDR              = varQual_RDR gHC_BASE            (fsLit "mempty")
 mappend_RDR             = varQual_RDR gHC_BASE            (fsLit "mappend")
index 3862839..1b0f90b 100644 (file)
@@ -34,6 +34,7 @@ import Util
 import Var
 import VarSet
 import MkId (coerceId)
+import TysWiredIn (true_RDR, false_RDR)
 
 import Data.Maybe (catMaybes, isJust)
 
@@ -176,7 +177,7 @@ gen_Functor_binds loc tycon
                  , ft_bad_app = panic "in other argument in ft_fmap"
                  , ft_co_var = panic "contravariant in ft_fmap" }
 
-    -- See Note [deriving <$]
+    -- See Note [Deriving <$]
     replace_name = L loc replace_RDR
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
@@ -225,11 +226,11 @@ gen_Functor_binds loc tycon
     match_for_con ctxt = mkSimpleConMatch ctxt $
         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
 
--- See Note [deriving <$]
+-- See Note [Deriving <$]
 data Replacer = Immediate {replace :: LHsExpr RdrName}
               | Nested {replace :: LHsExpr RdrName}
 
-{- Note [deriving <$]
+{- Note [Deriving <$]
    ~~~~~~~~~~~~~~~~~~
 
 We derive the definition of <$. Allowing this to take the default definition
@@ -596,6 +597,46 @@ derived Foldable instance for GADT is:
 
 See Note [DeriveFoldable with ExistentialQuantification].
 
+Note [Deriving null]
+~~~~~~~~~~~~~~~~~~~~
+
+In some cases, deriving the definition of 'null' can produce much better
+results than the default definition. For example, with
+
+  data SnocList a = Nil | Snoc (SnocList a) a
+
+the default definition of 'null' would walk the entire spine of a
+nonempty snoc-list before concluding that it is not null. But looking at
+the Snoc constructor, we can immediately see that it contains an 'a', and
+so 'null' can return False immediately if it matches on Snoc. When we
+derive 'null', we keep track of things that cannot be null. The interesting
+case is type application. Given
+
+  data Wrap a = Wrap (Foo (Bar a))
+
+we use
+
+  null (Wrap fba) = all null fba
+
+but if we see
+
+  data Wrap a = Wrap (Foo a)
+
+we can just use
+
+  null (Wrap fa) = null fa
+
+Indeed, we allow this to happen even for tuples:
+
+  data Wrap a = Wrap (Foo (a, Int))
+
+produces
+
+  null (Wrap fa) = null fa
+
+As explained in Note [Deriving <$], giving tuples special performance treatment
+could surprise users if they switch to other types, but Ryan Scott seems to
+think it's okay to do it for now.
 -}
 
 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
@@ -618,7 +659,7 @@ gen_Foldable_binds loc tycon
   = (unitBag foldMap_bind, emptyBag)
 
   | otherwise
-  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
+  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
   where
     data_cons = tyConDataCons tycon
 
@@ -642,6 +683,29 @@ gen_Foldable_binds loc tycon
       where
         parts = sequence $ foldDataConArgs ft_foldMap con
 
+    -- Given a list of NullM results, produce Nothing if any of
+    -- them is NotNull, and otherwise produce a list of Maybes
+    -- with Justs representing unknowns and Nothings representing
+    -- things that are definitely null.
+    convert :: [NullM a] -> Maybe [Maybe a]
+    convert = traverse go where
+      go IsNull = Just Nothing
+      go NotNull = Nothing
+      go (NullM a) = Just (Just a)
+
+    null_name = L loc null_RDR
+    null_match_ctxt = FunRhs null_name Prefix
+    null_bind = mkRdrFunBind null_name null_eqns
+    null_eqns = map null_eqn data_cons
+    null_eqn con
+      = flip evalState bs_RDRs $ do
+          parts <- sequence $ foldDataConArgs ft_null con
+          case convert parts of
+            Nothing -> return $
+              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
+                false_Expr (noLoc emptyLocalBinds)
+            Just cp -> match_null [] con cp
+
     -- Yields 'Just' an expression if we're folding over a type that mentions
     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
     -- See Note [FFoldType and functorLikeTraverse]
@@ -708,6 +772,59 @@ gen_Foldable_binds loc tycon
         mkFoldMap [] = mempty_Expr
         mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
 
+    -- See Note [FFoldType and functorLikeTraverse]
+    -- Yields NullM an expression if we're folding over an expression
+    -- that may or may not be null. Yields IsNull if it's certainly
+    -- null, and yields NotNull if it's certainly not null.
+    -- See Note [Deriving null]
+    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr RdrName)))
+    ft_null
+      = FT { ft_triv = return IsNull
+             -- null = \_ -> True
+           , ft_var  = return NotNull
+             -- null = \_ -> False
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               case convert gg of
+                 Nothing -> pure NotNull
+                 Just ggg ->
+                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
+             -- null = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
+                              case nestedResult of
+                                -- If e definitely contains the parameter,
+                                -- then we can test if (G e) contains it by
+                                -- simply checking if (G e) is null
+                                NotNull -> NullM null_Expr
+                                -- This case is unreachable--it will actually be
+                                -- caught by ft_triv
+                                IsNull -> IsNull
+                                -- The general case uses (all null),
+                                -- (all (all null)), etc.
+                                NullM nestedTest -> NullM $
+                                                    nlHsApp all_Expr nestedTest
+             -- null fa = null fa, or null fa = all null fa, or null fa = True
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_null"
+           , ft_fun = panic "function in ft_null"
+           , ft_bad_app = panic "in other argument in ft_null" }
+
+    match_null :: [LPat RdrName]
+                  -> DataCon
+                  -> [Maybe (LHsExpr RdrName)]
+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
+      where
+        -- v1 && v2 && ..
+        mkNull :: [LHsExpr RdrName] -> LHsExpr RdrName
+        mkNull [] = true_Expr
+        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
+
+data NullM a =
+    IsNull   -- Definitely null
+  | NotNull  -- Definitely not null
+  | NullM a  -- Unknown
+
 {-
 ************************************************************************
 *                                                                      *
@@ -821,7 +938,8 @@ gen_Traversable_binds loc tycon
 -----------------------------------------------------------------------
 
 f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
-    traverse_Expr, coerce_Expr, pure_Expr :: LHsExpr RdrName
+    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
+    all_Expr, null_Expr :: LHsExpr RdrName
 f_Expr        = nlHsVar f_RDR
 z_Expr        = nlHsVar z_RDR
 fmap_Expr     = nlHsVar fmap_RDR
@@ -831,6 +949,10 @@ foldMap_Expr  = nlHsVar foldMap_RDR
 traverse_Expr = nlHsVar traverse_RDR
 coerce_Expr   = nlHsVar (getRdrName coerceId)
 pure_Expr     = nlHsVar pure_RDR
+true_Expr     = nlHsVar true_RDR
+false_Expr    = nlHsVar false_RDR
+all_Expr      = nlHsVar all_RDR
+null_Expr     = nlHsVar null_RDR
 
 f_RDR, z_RDR :: RdrName
 f_RDR = mkVarUnqual (fsLit "f")
index 4470bb9..193515c 100644 (file)
@@ -25,44 +25,50 @@ Compiler
 ~~~~~~~~
 
 - Derived ``Functor``, ``Foldable``, and ``Traversable`` instances are now
-optimized when their last type parameters have phantom roles. Specifically, ::
+  optimized when their last type parameters have phantom roles.
+  Specifically, ::
 
     fmap _ = coerce
     traverse _ x = pure (coerce x)
     foldMap _ _ = mempty
 
-These definitions of ``foldMap`` and ``traverse`` are lazier than
-the ones we would otherwise derive, as they may produce results without
-inspecting their arguments at all.
+  These definitions of ``foldMap`` and ``traverse`` are lazier than the ones we
+  would otherwise derive, as they may produce results without inspecting their
+  arguments at all.
 
-See also :ref:`deriving-functor`, :ref:`deriving-foldable`, and
-:ref:`deriving-traversable`.
+  See also :ref:`deriving-functor`, :ref:`deriving-foldable`, and
+  :ref:`deriving-traversable`.
 
 - Derived ``Functor``, ``Foldable``, ``Traversable``, ``Generic``, and
-``Generic1`` instances now have better, and generally better-documented,
-behaviors for types with no constructors. In particular, ::
+  ``Generic1`` instances now have better, and generally better-documented,
+  behaviors for types with no constructors. In particular, ::
 
-    fmap _ x = case x of
-    foldMap _ _ = mempty
-    traverse _ x = pure (case x of)
-    to x = case x of
-    to1 x = case x of
-    from x = case x of
-    from1 x = case x of
+      fmap _ x = case x of
+      foldMap _ _ = mempty
+      traverse _ x = pure (case x of)
+      to x = case x of
+      to1 x = case x of
+      from x = case x of
+      from1 x = case x of
+
+  The new behavior generally leads to more useful error messages than the
+  old did, and lazier semantics for ``foldMap`` and ``traverse``.
 
-The new behavior generally leads to more useful error messages than the
-old did, and lazier semantics for ``foldMap`` and ``traverse``.
+- Derived ``Foldable`` instances now derive custom definitions for ``null``
+  instead of using the default one. This leads to asymptotically better
+  performance for recursive types not shaped like cons-lists, and allows ``null``
+  to terminate for more (but not all) infinitely large structures.
 
 - Derived instances for types with no constructors now have appropriate
-arities: they take all their arguments before producing errors. This may not
-be terribly important in practice, but it seems like the right thing to do.
-Previously, we generated ::
+  arities: they take all their arguments before producing errors. This may not
+  be terribly important in practice, but it seems like the right thing to do.
+  Previously, we generated ::
 
-    (==) = error ...
+      (==) = error ...
 
 Now we generate ::
 
-    _ == _ = error ...
+      _ == _ = error ...
 
 - Lots of other bugs. See `Trac
    <https://ghc.haskell.org/trac/ghc/query?status=closed&milestone=8.4.1&col=id&col=summary&col=status&col=type&col=priority&col=milestone&col=component&order=priority>`_
index e164206..3e4d22c 100644 (file)
@@ -3816,11 +3816,12 @@ would generate the following instance::
       foldr f z (Ex a1 a2 a3 a4) = f a1 (foldr f z a3)
       foldMap f (Ex a1 a2 a3 a4) = mappend (f a1) (foldMap f a3)
 
-The algorithm for :ghc-flag:`-XDeriveFoldable` is adapted from the :ghc-flag:`-XDeriveFunctor`
-algorithm, but it generates definitions for ``foldMap`` and ``foldr`` instead
-of ``fmap``. In addition, :ghc-flag:`-XDeriveFoldable` filters out all
-constructor arguments on the RHS expression whose types do not mention the last
-type parameter, since those arguments do not need to be folded over.
+The algorithm for :ghc-flag:`-XDeriveFoldable` is adapted from the
+:ghc-flag:`-XDeriveFunctor` algorithm, but it generates definitions for
+``foldMap``, ``foldr``, and ``null`` instead of ``fmap``. In addition,
+:ghc-flag:`-XDeriveFoldable` filters out all constructor arguments on the RHS
+expression whose types do not mention the last type parameter, since those
+arguments do not need to be folded over.
 
 When the type parameter has a phantom role (see :ref:`roles`),
 :ghc-flag:`-XDeriveFoldable` derives a trivial instance. For example, this
@@ -3847,20 +3848,44 @@ will generate the following. ::
 Here are the differences between the generated code for ``Functor`` and
 ``Foldable``:
 
-#. When a bare type variable ``a`` is encountered, :ghc-flag:`-XDeriveFunctor` would
-   generate ``f a`` for an ``fmap`` definition. :ghc-flag:`-XDeriveFoldable` would
-   generate ``f a z`` for ``foldr``, and ``f a`` for ``foldMap``.
+#. When a bare type variable ``a`` is encountered, :ghc-flag:`-XDeriveFunctor`
+would generate ``f a`` for an ``fmap`` definition. :ghc-flag:`-XDeriveFoldable`
+would generate ``f a z`` for ``foldr``, ``f a`` for ``foldMap``, and ``False``
+for ``null``.
 
 #. When a type that is not syntactically equivalent to ``a``, but which does
    contain ``a``, is encountered, :ghc-flag:`-XDeriveFunctor` recursively calls
    ``fmap`` on it. Similarly, :ghc-flag:`-XDeriveFoldable` would recursively call
-   ``foldr`` and ``foldMap``.
+   ``foldr`` and ``foldMap``. Depending on the context, ``null`` may recursively
+   call ``null`` or ``all null``. For example, given ::
+
+       data F a = F (P a)
+       data G a = G (P (a, Int))
+       data H a = H (P (Q a))
+
+   ``Foldable`` deriving will produce ::
+
+       null (F x) = null x
+       null (G x) = null x
+       null (H x) = all null x
 
 #. :ghc-flag:`-XDeriveFunctor` puts everything back together again at the end by
    invoking the constructor. :ghc-flag:`-XDeriveFoldable`, however, builds up a value
    of some type. For ``foldr``, this is accomplished by chaining applications
    of ``f`` and recursive ``foldr`` calls on the state value ``z``. For
-   ``foldMap``, this happens by combining all values with ``mappend``.
+   ``foldMap``, this happens by combining all values with ``mappend``. For ``null``,
+   the values are usually combined with ``&&``. However, if any of the values is
+   known to be ``False``, all the rest will be dropped. For example, ::
+
+       data SnocList a = Nil | Snoc (SnocList a) a
+
+   will not produce ::
+
+       null (Snoc xs _) = null xs && False
+
+   (which would walk the whole list), but rather ::
+
+       null (Snoc _ _) = False
 
 There are some other differences regarding what data types can have derived
 ``Foldable`` instances:
diff --git a/testsuite/tests/perf/should_run/DeriveNullTermination.hs b/testsuite/tests/perf/should_run/DeriveNullTermination.hs
new file mode 100644 (file)
index 0000000..b08881c
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveFoldable #-}
+
+module Main where
+
+-- Trying to check if this is null from left to right or right to left
+-- will produce an infinite loop.
+data Ouch a = Ouch (Ouch a) a (Ouch a) deriving Foldable
+
+ouch :: a -> Ouch a
+ouch a = v where v = Ouch v a v
+
+newtype Tuplouch a = Tuplouch (Ouch (a, Int)) deriving Foldable
+
+main :: IO ()
+main = do
+  print $ null (ouch ())
+  print $ null (Tuplouch (ouch ((), 3)))
diff --git a/testsuite/tests/perf/should_run/DeriveNullTermination.stdout b/testsuite/tests/perf/should_run/DeriveNullTermination.stdout
new file mode 100644 (file)
index 0000000..815d668
--- /dev/null
@@ -0,0 +1,2 @@
+False
+False
index a70cf38..49a6656 100644 (file)
@@ -529,8 +529,11 @@ test('T13218',
 
 test('DeriveNull',
     [stats_num_field('bytes allocated',
-                    [ (wordsize(64), 152083704, 5) ]),
-                    # 2017-04-02     152083704 w/o derived null
+                    [ (wordsize(64), 112050856, 5) ]),
+                    # 2017-04-01     152083704 w/o derived null
+                    # 2017-04-02     112050856 derive null
      only_ways(['normal'])],
     compile_and_run,
     ['-O'])
+
+test('DeriveNullTermination', normal, compile_and_run, [''])