Commit e5ca7e6e authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix corner case of useless constraint in SPECIALISE pragma

	MERGE TO STABLE

This patch fixes Trac #1287.  

The problem is described in Note [Unused spec binders] in DsBinds.

At the same time I realised that the error messages in DsBinds.dsPrag
were being given the location of the *binding* not the *pragma*.
So I've fixed that too.
parent 7edaba26
......@@ -19,6 +19,7 @@ import MkIface
import Id
import Name
import CoreSyn
import OccurAnal
import PprCore
import DsMonad
import DsExpr
......@@ -277,13 +278,13 @@ ppr_ds_rules rules
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
= putSrcSpanDs loc $
do { let bndrs = [var | RuleBndr (L _ var) <- vars]
do { let bndrs = [var | RuleBndr (L _ var) <- vars]
; lhs' <- dsLExpr lhs
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
Nothing -> do { warnDs msg; return Nothing } ;
Just (bndrs', fn_id, args) -> do
Just (fn_id, args) -> do
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
......@@ -294,7 +295,7 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
fn_name = idName fn_id
rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
ru_rough = roughTopNames args,
ru_local = local_rule }
; return (Just rule)
......
......@@ -29,15 +29,15 @@ import CoreSyn -- lots of things
import CoreUtils
import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import TcType
import OccurAnal
import CostCentre
import Module
import Id
import Var ( TyVar )
import Rules
import Var ( TyVar, Var )
import VarEnv
import Type
import TysWiredIn
import Outputable
import SrcLoc
import Maybes
......@@ -46,9 +46,6 @@ import BasicTypes hiding ( TopLevel )
import FastString
import Util ( mapSnd )
import Name
import OccName
import Literal
import Control.Monad
import Data.List
......@@ -207,7 +204,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
; returnDs ((poly_tup_id, poly_tup_expr) :
(concat export_binds_s ++ rest)) }
mkABEnv :: [([TyVar], Id, Id, [Prag])] -> VarEnv (Id, [Prag])
mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv (Id, [LPrag])
-- Takes the exports of a AbsBinds, and returns a mapping
-- lcl_id -> (gbl_id, prags)
mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags))
......@@ -216,7 +213,7 @@ mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags))
dsSpec :: [TyVar] -> [DictId] -> [TyVar]
-> Id -> Id -- Global, local
-> CoreBind -> Prag
-> CoreBind -> LPrag
-> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
CoreRule)) -- Rule for the Global Id
......@@ -235,22 +232,39 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar]
-- /\b.\(d:Ix b). in f Int b dInt d
-- The idea is that f occurs just once, so it'll be
-- inlined and specialised
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
--
-- Given SpecPrag (/\as.\ds. f es) t, we have
-- the defn f_spec as ds = f es
-- and the RULE f es = f_spec as ds
--
-- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
-- (a bit silly, because then the
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (L _ (InlinePrag {}))
= return Nothing
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
(SpecPrag spec_expr spec_ty const_dicts inl)
= do { let poly_name = idName poly_id
(L loc (SpecPrag spec_expr spec_ty _const_dicts inl))
-- See Note [Const rule dicts]
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; ds_spec_expr <- dsExpr spec_expr
; let (bndrs, body) = collectBinders ds_spec_expr
mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
; case mb_lhs of
Nothing -> do { warnDs msg; return Nothing }
Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
-- The occurrence-analysis does two things
-- (a) identifies unused binders: Note [Unused spec binders]
-- (b) sorts dict bindings into NonRecs
-- so they can be inlined by decomposeRuleLhs
mb_lhs = decomposeRuleLhs body
-- Check for dead binders: Note [Unused spec binders]
; case filter isDeadBinder bndrs of {
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise ->
case mb_lhs of
Nothing -> do { warnDs decomp_msg; return Nothing }
Just (var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
......@@ -260,17 +274,11 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
poly_f_body = mkLams (tvs ++ dicts) $
fix_up (Let mono_bind (Var mono_id))
-- Quantify over constant dicts on the LHS, since
-- their value depends only on their type
-- The ones we are interested in may even be imported
-- e.g. GHC.Base.dEqInt
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
bndrs' -- Includes constant dicts
args
bndrs args
(mkVarApps (Var spec_id) bndrs)
}
} }
where
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
......@@ -279,10 +287,45 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
(map mkArbitraryType void_tvs)
void_tvs = all_tvs \\ tvs
msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr)
dead_msg bs = vcat [ sep [ptext SLIT("Useless constraint") <> plural bs
<+> ptext SLIT("in specialied type:"),
nest 2 (pprTheta (map get_pred bs))]
, ptext SLIT("SPECIALISE pragma ignored")]
get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
decomp_msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr)
\end{code}
Note [Unused spec binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f :: a -> a
{-# SPECIALISE f :: Eq a => a -> a #-}
It's true that this *is* a more specialised type, but the rule
we get is something like this:
f_spec d = f
RULE: f = f_spec d
Note that the rule is bogus, becuase it mentions a 'd' that is
not bound on the LHS! But it's a silly specialisation anyway, becuase
the constraint is unused. We could bind 'd' to (error "unused")
but it seems better to reject the program because it's almost certainly
a mistake. That's what the isDeadBinder call detects.
Note [Const rule dicts]
~~~~~~~~~~~~~~~~~~~~~~~
A SpecPrag has a field for "constant dicts" in the RULE, but I think
it's pretty useless. See the place where it's generated in TcBinds.
TcSimplify will discharge a constraint by binding it to, say,
GHC.Base.$f2 :: Eq Int, withour putting anything in the LIE, so this
dict won't show up in the const-dicts field. It probably doesn't matter,
because the rule will end up being something like
f Int GHC.Base.$f2 = ...
rather than
forall d. f Int d = ...
The latter is more general, but in practice I think it won't make any
difference.
%************************************************************************
%* *
......@@ -291,29 +334,12 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
%************************************************************************
\begin{code}
decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr])
decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
-- Returns Nothing if the LHS isn't of the expected shape
-- The argument 'all_bndrs' includes the "constant dicts" of the LHS,
-- and they may be GlobalIds, which we can't forall-ify.
-- So we substitute them out instead
decomposeRuleLhs all_bndrs lhs
= go init_env (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
-- bindings so we know if they are recursive
decomposeRuleLhs lhs
= go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
-- bindings so we know if they are recursive
where
-- all_bndrs may include top-level imported dicts,
-- imported things with a for-all.
-- So we localise them and subtitute them out
bndr_prs = [ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ]
localise d = mkLocalId (idName d) (idType d)
init_env = mkVarEnv bndr_prs
all_bndrs' = map subst_bndr all_bndrs
subst_bndr bndr = case lookupVarEnv init_env bndr of
Just (Var bndr') -> bndr'
Just other -> panic "decomposeRuleLhs"
Nothing -> bndr
-- Substitute dicts in the LHS args, so that there
-- aren't any lets getting in the way
-- Note that we substitute the function too; we might have this as
......@@ -322,7 +348,7 @@ decomposeRuleLhs all_bndrs lhs
= go (extendVarEnv env dict (simpleSubst env rhs)) body
go env body
= case collectArgs (simpleSubst env body) of
(Var fn, args) -> Just (all_bndrs', fn, args)
(Var fn, args) -> Just (fn, args)
other -> Nothing
simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
......@@ -330,7 +356,9 @@ simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
-- (a) takes no account of capture; dictionary bindings use new names
-- (b) can have a GlobalId (imported) in its domain
-- (c) Ids only; no types are substituted
--
-- (b) is the reason we can't use CoreSubst... and it's no longer relevant
-- so really we should replace simpleSubst
simpleSubst subst expr
= go expr
where
......@@ -346,9 +374,9 @@ simpleSubst subst expr
go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
[(c,bs,go r) | (c,bs,r) <- alts]
addInlinePrags :: [Prag] -> Id -> CoreExpr -> (Id,CoreExpr)
addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
addInlinePrags prags bndr rhs
= case [inl | InlinePrag inl <- prags] of
= case [inl | L _ (InlinePrag inl) <- prags] of
[] -> (bndr, rhs)
(inl:_) -> addInlineInfo inl bndr rhs
......
......@@ -353,7 +353,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
--------------
mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
-> TcM ([TyVar], Id, Id, [Prag])
-> TcM ([TyVar], Id, Id, [LPrag])
-- mkExport generates exports with
-- zonked type variables,
-- zonked poly_ids
......@@ -393,12 +393,11 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
env = foldl add emptyNameEnv prs
add env (n,p) = extendNameEnv_Acc (:) singleton env n p
tcPrags :: Id -> [LSig Name] -> TcM [Prag]
tcPrags poly_id prags = mapM tc_prag prags
tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
where
tc_prag (L loc prag) = setSrcSpan loc $
addErrCtxt (pragSigCtxt prag) $
tcPrag poly_id prag
tc_prag prag = addErrCtxt (pragSigCtxt prag) $
tcPrag poly_id prag
pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
......
......@@ -304,11 +304,12 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
= zonkIdBndr env global `thenM` \ new_global ->
mapM zonk_prag prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
zonk_prag prag@(InlinePrag {}) = return prag
zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
; ty' <- zonkTcTypeToType env ty
; let ds' = zonkIdOccs env ds
; return (SpecPrag expr' ty' ds' inl) }
zonk_prag prag@(L _ (InlinePrag {})) = return prag
zonk_prag (L loc (SpecPrag expr ty ds inl))
= do { expr' <- zonkExpr env expr
; ty' <- zonkTcTypeToType env ty
; let ds' = zonkIdOccs env ds
; return (L loc (SpecPrag expr' ty' ds' inl)) }
\end{code}
%************************************************************************
......
......@@ -582,10 +582,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
dfun_id = instanceDFunId ispec
rigid_info = InstSkol
inst_ty = idType dfun_id
loc = srcLocSpan (getSrcLoc dfun_id)
in
-- Prime error recovery
recoverM (returnM emptyLHsBinds) $
setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-- Instantiate the instance decl with skolem constants
......@@ -638,7 +639,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
inline_prag | null dfun_arg_dicts = []
| otherwise = [InlinePrag (Inline AlwaysActive True)]
| otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then
......
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