Commit d4d4bef2 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve the desugaring of RULES, esp those from SPECIALISE pragmas

In the code for Trac #8331 we were not getting a complaint, but
we *were* getting a terrible (and virtually useless) RULE, looking
like
   useAbstractMonad (complicated-dictionary-expresion) = $fuseAbstractMonad
where we wanted
   useAbstractMonad d = $fuseAbstractMonad

This commit improves the desugaring algorithm.  More comments
explain; see Note [Drop dictionary bindings on rule LHS]
parent 2989ffdc
......@@ -454,7 +454,10 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs bndrs ds_lhs of {
; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id
-- , ptext (sLit "spec_co:") <+> ppr spec_co
-- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $
case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (rule_bndrs, _fn, args) -> do
......@@ -578,7 +581,7 @@ SPEC f :: ty [n] INLINE [k]
decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
-- may add some extra dictionary binders (see Note [Constant rule dicts])
-- may add some extra dictionary binders (see Note [Free dictionaries])
--
-- Returns Nothing if the LHS isn't of the expected shape
-- Note [Decomposing the left-hand side of a RULE]
......@@ -589,7 +592,13 @@ decomposeRuleLhs orig_bndrs orig_lhs
| Var fn_var <- fun
, not (fn_var `elemVarSet` orig_bndr_set)
= Right (bndrs1, fn_var, args)
= -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
-- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
-- , ptext (sLit "lhs1:") <+> ppr lhs1
-- , ptext (sLit "bndrs1:") <+> ppr bndrs1
-- , ptext (sLit "fn_var:") <+> ppr fn_var
-- , ptext (sLit "args:") <+> ppr args]) $
Right (bndrs1, fn_var, args)
| Case scrut bndr ty [(DEFAULT, _, body)] <- fun
, isDeadBinder bndr -- Note [Matching seqId]
......@@ -608,7 +617,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
orig_bndr_set = mkVarSet orig_bndrs
-- Add extra dict binders: Note [Constant rule dicts]
-- Add extra dict binders: Note [Free dictionaries]
extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
| d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)
, isDictId d ]
......@@ -625,12 +634,29 @@ decomposeRuleLhs orig_bndrs orig_lhs
| otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts (Let (NonRec d rhs) body)
| isDictId d
, not (exprFreeVars rhs `intersectsVarSet` orig_bndr_set)
= drop_dicts body
drop_dicts (Let bnd body) = Let bnd (drop_dicts body)
drop_dicts body = body
drop_dicts e
= wrap_lets needed bnds body
where
(bnds, body) = split_lets e
needed = orig_bndr_set `minusVarSet` exprFreeVars body
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets e
| Let (NonRec d r) body <- e
, isDictId d
, (bs, body') <- split_lets body
= ((d,r):bs, body')
| otherwise
= ([], e)
wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets _ [] body = body
wrap_lets needed ((d, r) : bs) body
| rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
| otherwise = wrap_lets needed bs body
where
rhs_fvs = exprFreeVars r
needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
\end{code}
Note [Decomposing the left-hand side of a RULE]
......@@ -638,7 +664,7 @@ Note [Decomposing the left-hand side of a RULE]
There are several things going on here.
* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
* simpleOptExpr: see Note [Simplify rule LHS]
* extra_dict_bndrs: see Note [Free rule dicts]
* extra_dict_bndrs: see Note [Free dictionaries]
Note [Drop dictionary bindings on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -666,9 +692,36 @@ drop_dicts drops dictionary bindings on the LHS where possible.
will be simple NonRec bindings. We don't handle recursive
dictionaries!
NB3: In the common case of a non-overloaded, but perhpas-polymorphic
specialisation, we don't need to bind *any* dictionaries for use
in the RHS. For example (Trac #8331)
{-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
useAbstractMonad :: MonadAbstractIOST m => m Int
Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
but the RHS uses no dictionaries, so we want to end up with
RULE forall s (d :: MonadBstractIOST (ReaderT s)).
useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
Trac #8848 is a good example of where there are some intersting
dictionary bindings to discard.
The drop_dicts algorithm is based on these observations:
* Given (let d = rhs in e) where d is a DictId,
matching 'e' will bind e's free variables.
* So we want to keep the binding if one of the needed variables (for
which we need a binding) is in fv(rhs) but not already in fv(e).
* The "needed variables" are simply the orig_bndrs. Consider
f :: (Eq a, Show b) => a -> b -> String
{-# SPECIALISE f :: (Show b) => Int -> b -> String
Then orig_bndrs includes the *quantified* dictionaries of the type
namely (dsb::Show b), but not the one for Eq Int
So we work inside out, applying the above criterion at each step.
Note [Simplify rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~
simplOptExpr occurrence-analyses and simplifies the LHS:
......
{-# LANGUAGE FlexibleInstances, RankNTypes #-}
module Main ( main, useAbstractMonad ) where
import Control.Monad
import Control.Monad.ST
import Control.Applicative
newtype ReaderT r m a = ReaderT {
-- | The underlying computation, as a function of the environment.
runReaderT :: r -> m a
}
instance (Applicative m) => Applicative (ReaderT r m) where
pure = liftReaderT . pure
f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r
instance (Functor m) => Functor (ReaderT r m) where
fmap f = mapReaderT (fmap f)
instance (Monad m) => Monad (ReaderT r m) where
return x = ReaderT (\_ -> return x)
m >>= k = ReaderT $ \ r -> do
a <- runReaderT m r
runReaderT (k a) r
fail msg = ReaderT (\_ -> fail msg)
mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT f m = ReaderT $ f . runReaderT m
liftReaderT :: m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)
ask :: (Monad m) => ReaderT r m r
ask = ReaderT return
class (Applicative m, Functor m , Monad m) => MonadAbstractIOST m where
addstuff :: Int -> m Int
type ReaderST s = ReaderT (Int) (ST s)
instance MonadAbstractIOST (ReaderST s) where
addstuff a = return . (a +) =<< ask
runAbstractST :: (forall s. ReaderST s a) -> a
runAbstractST f = runST $ runReaderT f 99
{-# SPECIALIZE useAbstractMonad :: Int -> ReaderST s Int #-}
-- Note the polymorphism
useAbstractMonad :: MonadAbstractIOST m => Int -> m Int
useAbstractMonad n = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]
-- useConcreteMonad :: Int -> ReaderST s Int
-- useConcreteMonad = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]
main :: IO ()
main = do
let st = runAbstractST (useAbstractMonad 5000000)
putStrLn . show $ st
==================== Tidy Core rules ====================
"SPEC useAbstractMonad" [ALWAYS]
forall (@ s)
($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).
useAbstractMonad @ (ReaderT Int (ST s)) $dMonadAbstractIOST
= useAbstractMonad_$suseAbstractMonad @ s
......@@ -203,3 +203,4 @@ test('T8832',
['$MAKE -s --no-print-directory T8832'])
test('T8848', only_ways(['optasm']), compile, ['-ddump-rule-firings'])
test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules'])
test('T8331', only_ways(['optasm']), compile, ['-ddump-rules'])
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