From: simonpj@microsoft.com Date: Tue, 22 Jan 2008 12:26:13 +0000 (+0000) Subject: Tidy up the treatment of SPECIALISE pragmas X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=43a2e4a26175b9dbf29e39b97f7d032ef00f9993 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. --- diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 5540dd8..ca357c5 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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 = 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 = + {-# 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 = in f Int dInt + %************************************************************************ diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 90442df..211a3c1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index db1a37a..9e60bbd 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 205197a..df6c50a 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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} %************************************************************************