Commit 43a2e4a2 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Tidy up the treatment of SPECIALISE pragmas

Remove the now-redundant "const-dicts" field in SpecPrag

In dsBinds, abstract over constant dictionaries in the RULE.
This avoids the creation of a redundant, duplicate, rule later
in the Specialise pass, which was happening before.

There should be no effect on performance either way, just less
duplicated code, and the compiler gets a little simpler.
parent 3e35714a
......@@ -34,6 +34,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils
import CoreFVs
import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import TcType
......@@ -42,6 +43,7 @@ import CostCentre
import Module
import Id
import Var ( TyVar )
import VarSet
import Rules
import VarEnv
import Type
......@@ -242,8 +244,9 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar]
-- inlined and specialised
--
-- 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
-- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
-- in f es
-- and the RULE forall as, ds. 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
......@@ -251,8 +254,7 @@ 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
(L loc (SpecPrag spec_expr spec_ty _const_dicts inl))
-- See Note [Const rule dicts]
(L loc (SpecPrag spec_expr spec_ty inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
......@@ -283,9 +285,12 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
poly_f_body = mkLams (tvs ++ dicts) f_body
extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
-- Note [Const rule dicts]
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
bndrs args
(extra_dict_bndrs ++ bndrs) args
(mkVarApps (Var spec_id) bndrs)
; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
} } }
......@@ -329,17 +334,23 @@ 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.
When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
which is presumably in scope at the function definition site, we can quantify
over it too. *Any* dict with that type will do.
So for example when you have
f :: Eq a => a -> a
f = <rhs>
{-# SPECIALISE f :: Int -> Int #-}
Then we get the SpecPrag
SpecPrag (f Int dInt) Int
And from that we want the rule
RULE forall dInt. f Int dInt = f_spec
f_spec = let f = <rhs> in f Int dInt
%************************************************************************
......
......@@ -454,9 +454,6 @@ data Prag
| SpecPrag
(HsExpr Id) -- An expression, of the given specialised type, which
PostTcType -- specialises the polymorphic function
[Id] -- Dicts mentioned free in the expression
-- Apr07: I think this is pretty useless
-- see Note [Const rule dicts] in DsBinds
InlineSpec -- Inlining spec for the specialised function
isInlinePrag (InlinePrag _) = True
......@@ -573,7 +570,7 @@ pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
pprPrag :: Outputable id => id -> LPrag -> SDoc
pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var
pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl
pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var
pprPrag var (L _ (SpecPrag expr ty inl)) = pprSpec var ty inl
\end{code}
......@@ -426,10 +426,8 @@ tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
tcSpecPrag poly_id hs_ty inl
= do { let name = idName poly_id
; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
; (co_fn, lie) <- getLIE (tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty)
; extendLIEs lie
; let const_dicts = map instToId lie
; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
-- Most of the work of specialisation is done by
-- the desugarer, guided by the SpecPrag
......
......@@ -313,11 +313,10 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
mapM zonk_prag prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
zonk_prag prag@(L _ (InlinePrag {})) = return prag
zonk_prag (L loc (SpecPrag expr ty ds inl))
zonk_prag (L loc (SpecPrag expr ty inl))
= do { expr' <- zonkExpr env expr
; ty' <- zonkTcTypeToType env ty
; let ds' = zonkIdOccs env ds
; return (L loc (SpecPrag expr' ty' ds' inl)) }
; return (L loc (SpecPrag expr' ty' inl)) }
\end{code}
%************************************************************************
......
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