diff options
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 5 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenFunctor.hs | 132 | ||||
| -rw-r--r-- | docs/users_guide/8.4.1-notes.rst | 50 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 45 | ||||
| -rw-r--r-- | testsuite/tests/perf/should_run/DeriveNullTermination.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/perf/should_run/DeriveNullTermination.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/perf/should_run/all.T | 7 |
7 files changed, 218 insertions, 40 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 94c2d64f7f..1f9f8f33df 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -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") diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 38628398d5..1b0f90b268 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -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") diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst index 4470bb9e79..193515c077 100644 --- a/docs/users_guide/8.4.1-notes.rst +++ b/docs/users_guide/8.4.1-notes.rst @@ -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>`_ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index e1642062c4..3e4d22c4a6 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -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 index 0000000000..b08881c2f6 --- /dev/null +++ b/testsuite/tests/perf/should_run/DeriveNullTermination.hs @@ -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 index 0000000000..815d6689fe --- /dev/null +++ b/testsuite/tests/perf/should_run/DeriveNullTermination.stdout @@ -0,0 +1,2 @@ +False +False diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index a70cf3892a..49a6656223 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -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, ['']) |