diff options
| author | simonpj@microsoft.com <unknown> | 2010-10-07 11:10:51 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2010-10-07 11:10:51 +0000 |
| commit | 92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44 (patch) | |
| tree | 11ada6374af97f3a65b327221aec17368f3344b0 | |
| parent | 861e1d55126391785e93493080d3c7516812675e (diff) | |
| download | haskell-92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44.tar.gz | |
Implement auto-specialisation of imported Ids
This big-ish patch arranges that if an Id 'f' is
* Type-class overloaded
f :: Ord a => [a] -> [a]
* Defined with an INLINABLE pragma
{-# INLINABLE f #-}
* Exported from its defining module 'D'
then in any module 'U' that imports D
1. Any call of 'f' at a fixed type will generate
(a) a specialised version of f in U
(b) a RULE that rewrites unspecialised calls to the
specialised on
e.g. if the call is (f Int dOrdInt xs) then the
specialiser will generate
$sfInt :: [Int] -> [Int]
$sfInt = <code for f, imported from D, specialised>
{-# RULE forall d. f Int d = $sfInt #-}
2. In addition, you can give an explicit {-# SPECIALISE -#}
pragma for the imported Id
{-# SPECIALISE f :: [Bool] -> [Bool] #-}
This too generates a local specialised definition,
and the corresponding RULE
The new RULES are exported from module 'U', so that any module
importing U will see the specialised versions of 'f', and will
not re-specialise them.
There's a flag -fwarn-auto-orphan that warns you if the auto-generated
RULES are orphan rules. It's not in -Wall, mainly to avoid lots of
error messages with existing packages.
Main implementation changes
- A new flag on a CoreRule to say if it was auto-generated.
This is persisted across interface files, so there's a small
change in interface file format.
- Quite a bit of fiddling with plumbing, to get the
{-# SPECIALISE #-} pragmas for imported Ids. In particular, a
new field tgc_imp_specs in TcGblEnv, to keep the specialise
pragmas for imported Ids between the typechecker and the desugarer.
- Some new code (although surprisingly little) in Specialise,
to deal with calls of imported Ids
27 files changed, 557 insertions, 332 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 3c7407db84..ce47e5841a 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -65,7 +65,8 @@ module BasicTypes( InlineSpec(..), InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat, + isDefaultInlinePragma, isInlinePragma, isInlinablePragma, + inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -773,6 +774,11 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = isInlineSpec (inl_inline prag) +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index fb7865b354..c74de06b24 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -319,7 +319,7 @@ data CoreRule = Rule { ru_name :: RuleName, -- ^ Name of the rule, for communication with the user ru_act :: Activation, -- ^ When the rule is active - + -- Rough-matching stuff -- see comments with InstEnv.Instance( is_cls, is_rough ) ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule @@ -336,6 +336,10 @@ data CoreRule -- See Note [OccInfo in unfoldings and rules] -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- @False@ <=> generated at the users behest + -- Main effect: reporting of orphan-hood + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is -- defined in the same module as the rule -- and is not an implicit 'Id' (like a record selector, diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 9616c62dc3..d154e045ab 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -34,11 +34,11 @@ import CoreMonad ( endPass, CoreToDo(..) ) import ErrUtils import Outputable import SrcLoc -import Maybes import FastString import Coverage import Util - +import MonadUtils +import OrdList import Data.List import Data.IORef \end{code} @@ -69,6 +69,7 @@ deSugar hsc_env tcg_warns = warns, tcg_anns = anns, tcg_binds = binds, + tcg_imp_specs = imp_specs, tcg_ev_binds = ev_binds, tcg_fords = fords, tcg_rules = rules, @@ -88,7 +89,7 @@ deSugar hsc_env <- case target of HscNothing -> return (emptyMessages, - Just ([], [], [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@ -98,23 +99,26 @@ deSugar hsc_env (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - ds_ev_binds <- dsEvBinds ev_binds - core_prs <- dsTopLHsBinds auto_scc binds_cvr - (ds_fords, foreign_prs) <- dsForeigns fords - let all_prs = foreign_prs ++ core_prs - mb_rules <- mapM dsRule rules - return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks) + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds auto_scc binds_cvr + ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; rules <- mapMaybeM dsRule rules + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + , spec_rules ++ rules + , ds_fords, ds_hpc_info, modBreaks) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do + Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let (rules_for_locals, rules_for_imps) - = partition isLocalRule (catMaybes mb_rules) + = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target - export_set keep_alive rules_for_locals all_prs + export_set keep_alive rules_for_locals (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -163,6 +167,11 @@ deSugar hsc_env ; return (msgs, Just mod_guts) }}} +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind] -- Top-level bindings can include coercion bindings, but not via superclasses @@ -340,13 +349,14 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) Nothing -> do { warnDs msg; return Nothing } ; Just (fn_id, args) -> do - { let local_rule = isLocalId fn_id + { let is_local = isLocalId fn_id -- NB: isLocalId is False of implicit Ids. This is good becuase -- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code gen fn_name = idName fn_id final_rhs = simpleOptExpr rhs' -- De-crap it - rule = mkRule local_rule name act fn_name bndrs' args final_rhs + rule = mkRule False {- Not auto -} is_local + name act fn_name bndrs' args final_rhs ; return (Just rule) } } } where diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index b5b58fe645..7e922fd973 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -10,7 +10,7 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, +module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, DsEvBind(..), AutoScc(..) ) where @@ -69,9 +69,8 @@ import MonadUtils %************************************************************************ \begin{code} -dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] -dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds - ; return (fromOL binds') } +dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds @@ -135,7 +134,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts Let core_bind $ Var local - ; (spec_binds, rules) <- dsSpecs global rhs prags + ; (spec_binds, rules) <- dsSpecs rhs prags ; let global' = addIdSpecialisations global rules main_bind = makeCorePair global' (isDefaultMethod prags) @@ -178,9 +177,9 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts mkTupleSelector locals' (locals' !! n) tup_id $ mkVarApps (mkTyApps (Var poly_tup_id) ty_args) dicts - ; (spec_binds, rules) <- dsSpecs global - (Let (NonRec poly_tup_id poly_tup_rhs) rhs) - spec_prags + full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags + ; let global' = addIdSpecialisations global rules ; return ((global', rhs) `consOL` spec_binds) } where @@ -475,66 +474,69 @@ Note that \begin{code} ------------------------ -dsSpecs :: Id -- The polymorphic Id - -> CoreExpr -- Its rhs +dsSpecs :: CoreExpr -- Its rhs -> TcSpecPrags -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids , [CoreRule] ) -- Rules for the Global Ids -- See Note [Implementing SPECIALISE pragmas] -dsSpecs poly_id poly_rhs prags - = case prags of - IsDefaultMethod -> return (nilOL, []) - SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps - ; let (spec_binds_s, rules) = unzip pairs - ; return (concatOL spec_binds_s, rules) } - where - spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) - spec_one (L loc (SpecPrag spec_co spec_inl)) - = putSrcSpanDs loc $ - do { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name - ; wrap_fn <- dsHsWrapper spec_co - ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id)) - spec_ty = mkPiTypes bndrs (exprType ds_lhs) - ; case decomposeRuleLhs ds_lhs of { - Nothing -> do { warnDs (decomp_msg spec_co) - ; return Nothing } ; - - Just (_fn, args) -> - - -- Check for dead binders: Note [Unused spec binders] - let arg_fvs = exprsFreeVars args - bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs - in if not (null bad_bndrs) - then do { warnDs (dead_msg bad_bndrs); return Nothing } - else do - - { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id) - - ; let spec_id = mkLocalId spec_name spec_ty - `setInlinePragma` inl_prag - `setIdUnfolding` spec_unf - inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id - | otherwise = spec_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) - -- See Note [Constant rule dicts] - | d <- varSetElems (arg_fvs `delVarSetList` bndrs) - , isDictId d] - - rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) - AlwaysActive poly_name - (extra_dict_bndrs ++ bndrs) args - (mkVarApps (Var spec_id) bndrs) - - spec_rhs = wrap_fn poly_rhs - spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs - - ; return (Just (spec_pair `consOL` unf_pairs, rule)) - } } } - +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding + -- Nothing => RULE is for an imported Id + -- rhs is in the Id's unfolding + -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + = putSrcSpanDs loc $ + do { let poly_name = idName poly_id + ; spec_name <- newLocalName poly_name + ; wrap_fn <- dsHsWrapper spec_co + ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id)) + spec_ty = mkPiTypes bndrs (exprType ds_lhs) + ; case decomposeRuleLhs ds_lhs of { + Nothing -> do { warnDs (decomp_msg spec_co) + ; return Nothing } ; + + Just (_fn, args) -> + + -- Check for dead binders: Note [Unused spec binders] + let arg_fvs = exprsFreeVars args + bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs + in if not (null bad_bndrs) + then do { warnDs (dead_msg bad_bndrs); return Nothing } + else do + + { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id) + + ; let spec_id = mkLocalId spec_name spec_ty + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id + | otherwise = spec_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) + -- See Note [Constant rule dicts] + | d <- varSetElems (arg_fvs `delVarSetList` bndrs) + , isDictId d] + + rule = mkRule False {- Not auto -} is_local_id + (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) + AlwaysActive poly_name + (extra_dict_bndrs ++ bndrs) args + (mkVarApps (Var spec_id) bndrs) + + spec_rhs = wrap_fn poly_rhs + spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs + + ; return (Just (spec_pair `consOL` unf_pairs, rule)) + } } } + where dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs <+> ptext (sLit "in specialied type:"), nest 2 (pprTheta (map get_pred bs))] @@ -545,6 +547,15 @@ dsSpecs poly_id poly_rhs prags = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) 2 (pprHsWrapper (ppr poly_id) spec_co) + is_local_id = isJust mb_poly_rhs + poly_rhs | Just rhs <- mb_poly_rhs + = rhs + | Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id) + = unfolding + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- In the Nothing case the specialisation is for an imported Id + -- whose unfolding gives the RHS to be specialised + -- The type checker has checked that it has an unfolding specUnfolding :: (CoreExpr -> CoreExpr) -> Type -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index d73cd53044..4d0a148e15 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -43,7 +43,7 @@ import Outputable import FastString import Config import Constants - +import OrdList import Data.Maybe import Data.List \end{code} @@ -66,9 +66,9 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out dsForeigns :: [LForeignDecl Id] - -> DsM (ForeignStubs, [Binding]) + -> DsM (ForeignStubs, OrdList Binding) dsForeigns [] - = return (NoStubs, []) + = return (NoStubs, nilOL) dsForeigns fos = do fives <- mapM do_ldecl fos let @@ -79,7 +79,7 @@ dsForeigns fos = do return (ForeignStubs (vcat hs) (vcat cs $$ vcat fe_init_code), - (concat bindss)) + foldr (appOL . toOL) nilOL bindss) where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 7b4c17cb67..da247c28ed 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -315,7 +315,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars where ppr_exp (tvs, gbl, lcl, prags) = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl, - nest 2 (pprTcSpecPrags gbl prags)] + nest 2 (pprTcSpecPrags prags)] \end{code} @@ -636,11 +636,14 @@ data FixitySig name = FixitySig (Located name) Fixity data TcSpecPrags = IsDefaultMethod -- Super-specialised: a default method should -- be macro-expanded at every call site - | SpecPrags [Located TcSpecPrag] + | SpecPrags [LTcSpecPrag] deriving (Data, Typeable) +type LTcSpecPrag = Located TcSpecPrag + data TcSpecPrag = SpecPrag + Id -- The Id to be specialised HsWrapper -- An wrapper, that specialises the polymorphic function InlinePragma -- Inlining spec for the specialised function deriving (Data, Typeable) @@ -776,14 +779,11 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl -pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc -pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "<default method>") -pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps) - -pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc -pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>") +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where - ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p + ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl \end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ec85995b45..9cc824a97f 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1430,7 +1430,7 @@ instance Binary IfaceClassOp where return (IfaceClassOp occ def ty) instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1438,6 +1438,7 @@ instance Binary IfaceRule where put_ bh a5 put_ bh a6 put_ bh a7 + put_ bh a8 get bh = do a1 <- get bh a2 <- get bh @@ -1446,7 +1447,8 @@ instance Binary IfaceRule where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7) + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) instance Binary IfaceAnnotation where put_ bh (IfaceAnnotation a1 a2) = do diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index c8348cb6cd..c753375162 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -163,6 +163,7 @@ data IfaceRule ifRuleHead :: Name, -- Head of lhs ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, ifRuleOrph :: Maybe OccName -- Just like IfaceInst } @@ -860,7 +861,8 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc freeNamesIfTc _ = emptyNameSet freeNamesIfRule :: IfaceRule -> NameSet -freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) = unitNameSet f &&& fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index fd8fbdb5ae..a8ea826c94 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -280,9 +280,11 @@ mkIface_ hsc_env maybe_old_fingerprint intermediate_iface decls -- Warn about orphans - ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans - | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns - | otherwise = emptyBag + ; let warn_orphs = dopt Opt_WarnOrphans dflags + warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags + orph_warnings --- Laziness means no work done unless -fwarn-orphans + | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns + | otherwise = emptyBag errs_and_warns = (orph_warnings, emptyBag) unqual = mkPrintUnqualified dflags rdr_env inst_warns = listToBag [ instOrphWarn unqual d @@ -290,7 +292,9 @@ mkIface_ hsc_env maybe_old_fingerprint , isNothing (ifInstOrph i) ] rule_warns = listToBag [ ruleOrphWarn unqual this_mod r | r <- iface_rules - , isNothing (ifRuleOrph r) ] + , isNothing (ifRuleOrph r) + , if ifRuleAuto r then warn_auto_orphs + else warn_orphs ] ; if errorsFound dflags errs_and_warns then return ( errs_and_warns, Nothing ) @@ -1569,12 +1573,14 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn}) coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs }) + ru_args = args, ru_rhs = rhs, + ru_auto = auto }) = IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = map toIfaceBndr bndrs, ifRuleHead = fn, ifRuleArgs = map do_arg args, ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, ifRuleOrph = orph } where -- For type args we must remove synonyms from the outermost @@ -1599,7 +1605,7 @@ bogusIfaceRule :: Name -> IfaceRule bogusIfaceRule id_name = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True } --------------------- toIfaceExpr :: CoreExpr -> IfaceExpr diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 45cc6ca774..cbb74bed48 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -627,7 +627,8 @@ tcIfaceRules ignore_prags if_rules tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto }) = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext (sLit "Rule") <+> ftext name) $ @@ -640,6 +641,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ru_bndrs = bndrs', ru_args = args', ru_rhs = occurAnalyseExpr rhs', ru_rough = mb_tcs, + ru_auto = auto, ru_local = False }) } -- An imported RULE is never for a local Id -- or, even if it is (module loop, perhaps) -- we'll just leave it in the non-local set diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c3ce170b0f..ae683f91de 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -202,6 +202,7 @@ data DynFlag | Opt_WarnDodgyExports | Opt_WarnDodgyImports | Opt_WarnOrphans + | Opt_WarnAutoOrphans | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports @@ -1441,6 +1442,7 @@ fFlags = [ ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), ( "warn-orphans", Opt_WarnOrphans, nop ), + ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), @@ -1759,6 +1761,7 @@ minuswRemovesOpts Opt_WarnIncompletePatternsRecUpd, Opt_WarnMonomorphism, Opt_WarnUnrecognisedPragmas, + Opt_WarnAutoOrphans, Opt_WarnTabs ] diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index b76e6db95e..4899adb077 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,11 +9,18 @@ type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code} -module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings - rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings - rnMethodBinds, renameSigs, mkSigTvFn, - rnMatchGroup, rnGRHSs, - makeMiniFixityEnv, MiniFixityEnv +module RnBinds ( + -- Renaming top-level bindings + rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, mkSigTvFn, + rnMatchGroup, rnGRHSs, + makeMiniFixityEnv, MiniFixityEnv, + misplacedSigErr ) where import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) @@ -158,17 +165,17 @@ rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds - = rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds + = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsRHS :: NameSet -- Names bound by these binds - -> HsValBindsLR Name RdrName +rnTopBindsRHS :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsRHS bound_names binds = - do { is_boot <- tcIsHsBoot +rnTopBindsRHS binds + = do { is_boot <- tcIsHsBoot ; if is_boot then rnTopBindsBoot binds - else rnValBindsRHSGen (\x -> x) -- don't trim free vars - bound_names binds } + else rnValBindsRHS noTrimFVs -- don't trim free vars + Nothing -- Allow SPEC prags for imports + binds } -- Wrapper if we don't need to do anything in between the left and right, -- or anything else in the scope of the left @@ -176,10 +183,11 @@ rnTopBindsRHS bound_names binds = -- Never used when there are fixity declarations rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBinds b = - do nl <- rnTopBindsLHS emptyFsEnv b - let bound_names = collectHsValBinders nl - bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl +rnTopBinds b + = do { nl <- rnTopBindsLHS emptyFsEnv b + ; let bound_names = collectHsValBinders nl + ; bindLocalNames bound_names $ + rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl } rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) @@ -193,7 +201,6 @@ rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} - %********************************************************* %* * HsLocalBinds @@ -211,7 +218,7 @@ rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds rnLocalBindsAndThen (HsValBinds val_binds) thing_inside - = rnValBindsAndThen val_binds $ \ val_binds' -> + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> thing_inside (HsValBinds val_binds') rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do @@ -241,10 +248,10 @@ rnIPBind (IPBind n expr) = do \begin{code} -- Renaming local binding gropus -- Does duplicate/shadow check -rnValBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM ([Name], HsValBindsLR Name RdrName) -rnValBindsLHS fix_env binds +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds RdrName + -> RnM ([Name], HsValBindsLR Name RdrName) +rnLocalValBindsLHS fix_env binds = do { -- Do error checking: we need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more. @@ -259,7 +266,7 @@ rnValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds + ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names @@ -268,41 +275,44 @@ rnValBindsLHS fix_env binds -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHSFromDoc :: NameMaker - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs) +rnValBindsLHS :: NameMaker + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnValBindsLHS topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds ; return $ ValBindsIn mbinds' sigs } where bndrs = collectHsBindsBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs -rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- General version used both from the top-level and for local things -- Assumes the LHS vars are in scope -- -- Does not bind the local fixity declarations -rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets +rnValBindsRHS :: (FreeVars -> FreeVars) -- for trimming free var sets -- The trimming function trims the free vars we attach to a -- binding so that it stays reasonably small - -> NameSet -- Names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) - -rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) - = do { -- rename the sigs - sigs' <- renameSigs (Just bound_names) okBindSig sigs - -- rename the RHSes + -> Maybe NameSet -- Names bound by the LHSes + -- Nothing if expect sigs for imports + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) + +rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs) + = do { sigs' <- renameSigs mb_bound_names okBindSig sigs ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds ; case depAnalBinds binds_w_dus of - (anal_binds, anal_dus) -> do - { let valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus - ; return (valbind', valbind'_dus) }} + (anal_binds, anal_dus) -> return (valbind', valbind'_dus) + where + valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + } + +rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b) -rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) +noTrimFVs :: FreeVars -> FreeVars +noTrimFVs fvs = fvs -- Wrapper for local binds -- @@ -310,11 +320,11 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) -- it doesn't (and can't: we don't have the thing inside the binds) happen here -- -- The client is also responsible for bringing the fixities into scope -rnValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) -rnValBindsRHS bound_names binds - = rnValBindsRHSGen trim bound_names binds +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS trim (Just bound_names) binds where trim fvs = intersectNameSet bound_names fvs -- Only keep the names the names from this group @@ -324,22 +334,22 @@ rnValBindsRHS bound_names binds -- -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs -rnValBindsAndThen :: HsValBinds RdrName - -> (HsValBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) -rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside +rnLocalValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = do { -- (A) Create the local fixity environment new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' -- Report unused bindings based on the (accurate) @@ -372,7 +382,7 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- The bound names are pruned out of all_uses -- by the bindLocalNamesFV call above -rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs) +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -644,16 +654,22 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns - -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False + -> (Sig Name -> Bool) -- Complain about the wrong kind of signature if this is False -> [LSig RdrName] -> RnM [LSig Name] -- Renames the signatures and performs error checks renameSigs mb_names ok_sig sigs - = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs - ; mapM_ unknownSigErr bad_sigs -- Misplaced - ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate - ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs - ; return sigs' } + = do { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate + -- Check for duplicates on RdrName version, + -- because renamed version has unboundName for + -- not-in-scope binders, which gives bogus dup-sig errors + + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs + + ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return good_sigs } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -678,8 +694,14 @@ renameSig _ (SpecInstSig ty) = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike alll other signatures renameSig mb_names sig@(SpecSig v ty inl) - = do { new_v <- lookupSigOccRn mb_names sig v + = do { new_v <- case mb_names of + Just {} -> lookupSigOccRn mb_names sig v + Nothing -> lookupLocatedOccRn v ; new_ty <- rnHsSigType (quotes (ppr v)) ty ; return (SpecSig new_v new_ty inl) } @@ -784,8 +806,8 @@ dupSigDeclErr sigs@(L loc sig : _) ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig dupSigDeclErr [] = panic "dupSigDeclErr" -unknownSigErr :: LSig RdrName -> RnM () -unknownSigErr (L loc sig) +misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr (L loc sig) = addErrAt loc $ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 9f6a96a4cd..862e33ff13 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -505,6 +505,8 @@ lookupQualifiedName rdr_name doc = ptext (sLit "Need to find") <+> ppr rdr_name \end{code} +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lookupSigOccRn is used for type signatures and pragmas Is this valid? module A @@ -525,10 +527,13 @@ return the imported 'f', so that later on the reanamer will correctly report "misplaced type sig". \begin{code} -lookupSigOccRn :: Maybe NameSet -- Just ns => source file; these are the binders +lookupSigOccRn :: Maybe NameSet -- Just ns => these are the binders -- in the same group - -- Nothing => hs-boot file; signatures without + -- Nothing => signatures without -- binders are expected + -- (a) top-level (SPECIALISE prags) + -- (b) class decls + -- (c) hs-boot files -> Sig RdrName -> Located RdrName -> RnM (Located Name) lookupSigOccRn mb_bound_names sig @@ -538,14 +543,13 @@ lookupSigOccRn mb_bound_names sig Left err -> do { addErr err; return (mkUnboundName rdr_name) } Right name -> return name } -lookupBindGroupOcc :: Maybe NameSet -- Just ns => source file; these are the binders - -- in the same group - -- Nothing => hs-boot file; signatures without - -- binders are expected - -> SDoc +lookupBindGroupOcc :: Maybe NameSet -- See notes on the (Maybe NameSet) + -> SDoc -- in lookupSigOccRn -> RdrName -> RnM (Either Message Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message +-- +-- See Note [Looking up signature names] lookupBindGroupOcc mb_bound_names what rdr_name = do { local_env <- getLocalRdrEnv ; case lookupLocalRdrEnv local_env rdr_name of @@ -557,7 +561,8 @@ lookupBindGroupOcc mb_bound_names what rdr_name ; case (filter isLocalGRE gres) of (gre:_) -> check_local_name (gre_name gre) -- If there is more than one local GRE for the - -- same OccName, that will be reported separately + -- same OccName 'f', that will be reported separately + -- as a duplicate top-level binding for 'f' [] | null gres -> bale_out_with empty | otherwise -> bale_out_with import_msg }} @@ -1100,7 +1105,7 @@ addNameClashErrRn rdr_name names (np1:nps) = names msg1 = ptext (sLit "either") <+> mk_ref np1 msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps] - mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre + mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre] shadowedNameWarn :: OccName -> [SDoc] -> SDoc shadowedNameWarn occ shadowed_locs diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 5598cc0580..4e8219555e 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -21,7 +21,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) #endif /* GHCI */ import RnSource ( rnSrcDecls, findSplice ) -import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, +import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad @@ -931,7 +931,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) - = do (_bound_names, binds') <- rnValBindsLHS fix_env binds + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds return [(L loc (LetStmt (HsValBinds binds')), -- Warning: this is bogus; see function invariant emptyFVs @@ -995,7 +995,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- -- fixities and unused are handled above in rn_rec_stmts_and_then - rnValBindsRHS (mkNameSet all_bndrs) binds' + rnLocalValBindsRHS (mkNameSet all_bndrs) binds' return [(duDefs du_binds, allUses du_binds, emptyNameSet, L loc (LetStmt (HsValBinds binds')))] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 07a596a177..3766e2148b 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -150,7 +150,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index b4b996248b..ce9f64aff2 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -24,7 +24,7 @@ module Rules ( -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, mkLocalRule, roughTopNames + lookupRule, mkRule, roughTopNames ) where #include "HsVersions.h" @@ -105,7 +105,7 @@ Note [Overall plumbing for rules] The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we generate a RuleBase for (c) by combing rules from all the modules - "below" us. That's whye we can't just select the home-package RuleBase + "below" us. That's why we can't just select the home-package RuleBase from HscEnv. [NB: we are inconsistent here. We should do the same for external @@ -156,22 +156,16 @@ might have a specialisation where pi' :: Lift Int# is the specialised version of pi. \begin{code} -mkLocalRule :: RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- ^ Used to make 'CoreRule' for an 'Id' defined in the module being --- compiled. See also 'CoreSyn.CoreRule' -mkLocalRule = mkRule True - -mkRule :: Bool -> RuleName -> Activation +mkRule :: Bool -> Bool -> RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'CoreSyn.CoreRule' -mkRule is_local name act fn bndrs args rhs +mkRule is_auto is_local name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, ru_rhs = occurAnalyseExpr rhs, ru_rough = roughTopNames args, - ru_local = is_local } + ru_auto = is_auto, ru_local = is_local } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] @@ -759,21 +753,19 @@ match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) match_alts _ _ _ _ _ = Nothing -\end{code} -Matching Core types: use the matcher in TcType. -Notice that we treat newtypes as opaque. For example, suppose -we have a specialised version of a function at a newtype, say - newtype T = MkT Int -We only want to replace (f T) with f', not (f Int). - -\begin{code} ------------------------------------------ match_ty :: MatchEnv -> SubstEnv -> Type -- Template -> Type -- Target -> Maybe SubstEnv +-- Matching Core types: use the matcher in TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + match_ty menv (tv_subst, id_subst, binds) ty1 ty2 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 ; return (tv_subst', id_subst, binds) } diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index f214f0cae8..d9c611a0ab 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1279,7 +1279,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) body_ty = exprType spec_body rule_rhs = mkVarApps (Var spec_id) spec_call_args inline_act = idInlineActivation fn - rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs + rule = mkRule True {- Auto -} True {- Local -} + rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation] ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 47a4f055f5..f6f85a1140 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -10,19 +10,21 @@ module Specialise ( specProgram ) where import Id import TcType +import CoreMonad import CoreSubst -import CoreUnfold ( mkSimpleUnfolding, mkInlineUnfolding ) +import CoreUnfold import VarSet import VarEnv import CoreSyn import Rules import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkPiTypes ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) -import UniqSupply ( UniqSupply, UniqSM, initUs_, MonadUnique(..) ) +import UniqSupply ( UniqSM, initUs_, MonadUnique(..) ) import Name import MkId ( voidArgId, realWorldPrimId ) import Maybes ( catMaybes, isJust ) -import BasicTypes ( isNeverActive, inlinePragmaActivation ) +import BasicTypes +import HscTypes import Bag import Util import Outputable @@ -558,24 +560,98 @@ Hence, the invariant is this: %************************************************************************ \begin{code} -specProgram :: UniqSupply -> [CoreBind] -> [CoreBind] -specProgram us binds = initSM us $ - do { (binds', uds') <- go binds - ; return (wrapDictBinds (ud_binds uds') binds') } +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts + = do { hpt_rules <- getRuleBase + ; let local_rules = mg_rules guts + rule_base = extendRuleBaseList hpt_rules (mg_rules guts) + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM (go (mg_binds guts)) + + -- Specialise imported functions + ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds + + ; return (guts { mg_binds = spec_binds ++ binds' + , mg_rules = local_rules ++ new_rules }) } where -- We need to start with a Subst that knows all the things -- that are in scope, so that the substitution engine doesn't -- accidentally re-use a unique that's already in use -- Easiest thing is to do it all at once, as if all the top-level -- decls were mutually recursive - top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) + top_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $ + bindersOfBinds $ mg_binds guts go [] = return ([], emptyUDs) go (bind:binds) = do (binds', uds) <- go binds (bind', uds') <- specBind top_subst bind uds return (bind' ++ binds', uds') + +specImports :: VarSet -- Don't specialise these ones + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> UsageDetails -- Calls for imported things, and floating bindings + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings and floating bindings +specImports done rb uds + = do { let import_calls = varEnvElts (ud_calls uds) + ; (rules, spec_binds) <- go rb import_calls + ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) } + where + go _ [] = return ([], []) + go rb (CIS fn calls_for_fn : other_calls) + = do { (rules1, spec_binds1) <- specImport done rb fn (Map.toList calls_for_fn) + ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls + ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +specImport :: VarSet -- Don't specialise these + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module + -> Id -> [CallInfo] -- Imported function and calls for it + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +specImport done rb fn calls_for_fn + | not (fn `elemVarSet` done) + , isInlinablePragma (idInlinePragma fn) + , Just rhs <- maybeUnfoldingTemplate (realIdUnfolding fn) + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; hsc_env <- getHscEnv + ; eps <- liftIO $ hscEPS hsc_env + ; let full_rb = unionRuleBase rb (eps_rule_base eps) + rules_for_fn = getRules full_rb fn + + ; (rules1, spec_pairs, uds) <- runSpecM $ + specCalls emptySubst rules_for_fn calls_for_fn fn rhs + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later + + -- Now specialise any cascaded calls + ; (rules2, spec_binds2) <- specImports (extendVarSet done fn) + (extendRuleBaseList rb rules1) + uds + + ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) } + + | otherwise + = WARN( True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn ) + return ([], []) \end{code} +Avoiding recursive specialisation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is the reason for the +'done' VarSet passed to specImports and specImport. + %************************************************************************ %* * \subsubsection{@specExpr@: the main function} @@ -763,7 +839,7 @@ to substitute sc -> sc_flt in the RHS %************************************************************************ %* * -\subsubsection{Dealing with a binding} + Dealing with a binding %* * %************************************************************************ @@ -863,6 +939,34 @@ specDefn :: Subst UsageDetails) -- Stuff to fling upwards from the specialised versions specDefn subst body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + ; (rules, spec_defns, spec_uds) <- specCalls subst rules_for_me + calls_for_me fn rhs + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `plusUDs` spec_uds) } + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Subst + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> Id -> CoreExpr + -> SpecM ([CoreRule], -- New RULES for the fn + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- New usage details from the specialised RHSs + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not nneed to do this filtering. +-- See 'already_covered' + +specCalls subst rules_for_me calls_for_me fn rhs -- The first case is the interesting one | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args @@ -875,26 +979,16 @@ specDefn subst body_uds fn rhs -- See Note [Inline specialisation] for why we do not -- switch off specialisation for inline functions - = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me) $ - do { -- Make a specialised version for each call in calls_for_me - stuff <- mapM spec_call calls_for_me + = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $ + do { stuff <- mapM spec_call calls_for_me ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) - fn' = addIdSpecialisations fn spec_rules - final_uds = body_uds_without_me `plusUDs` plusUDList spec_uds - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me - - ; return (fn', spec_defns, final_uds) } + ; return (spec_rules, spec_defns, plusUDList spec_uds) } | otherwise -- No calls or RHS doesn't fit our preconceptions = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn ) -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $ - return (fn, [], body_uds_without_me) + return ([], [], emptyUDs) where fn_type = idType fn @@ -903,21 +997,17 @@ specDefn subst body_uds fn rhs (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta - inl_act = inlinePragmaActivation (idInlinePragma fn) + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing - fn_has_inline_rule = case isStableUnfolding_maybe fn_unf of - Just (_,sat) -> Just sat - Nothing -> Nothing spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs - (body_uds_without_me, calls_for_me) = callsForMe fn body_uds - rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body -- Glue back on the non-dict lambdas @@ -926,7 +1016,7 @@ specDefn subst body_uds fn rhs already_covered args -- Note [Specialisations already covered] = isJust (lookupRule (const True) realIdUnfolding (substInScope subst) - fn args (idCoreRules fn)) + fn args rules_for_me) mk_ty_args :: [Maybe Type] -> [CoreExpr] mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts @@ -990,8 +1080,8 @@ specDefn subst body_uds fn rhs -- The rule to put in the function's specialisation is: -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) - spec_env_rule = mkLocalRule - rule_name + spec_env_rule = mkRule True {- Auto generated -} is_local + rule_name inl_act -- Note [Auto-specialisation and RULES] (idName fn) (poly_tyvars ++ inst_dict_ids) @@ -1001,25 +1091,23 @@ specDefn subst body_uds fn rhs -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr consDictBind rhs_uds dx_binds + -- Add an InlineRule if the parent has one + -- See Note [Inline specialisations] + spec_unf + = case inlinePragmaSpec inl_prag of + Inline -> mkInlineUnfolding (Just spec_arity) spec_rhs + Inlinable -> mkInlinableUnfolding spec_rhs + _ -> NoUnfolding + -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in Simplify -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_f spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) - `setInlineActivation` inl_act + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf - -- Add an InlineRule if the parent has one - -- See Note [Inline specialisations] - final_spec_f - | Just sat <- fn_has_inline_rule - = let - mb_spec_arity = if sat then Just spec_arity else Nothing - in - spec_f_w_arity `setIdUnfolding` mkInlineUnfolding mb_spec_arity spec_rhs - | otherwise - = spec_f_w_arity - - ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } + ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } where my_zipEqual xs ys zs | debugIsOn && not (equalLength xs ys && equalLength ys zs) @@ -1149,7 +1237,7 @@ group. (In this case it'll unravel a short moment later.) Conclusion: we catch the nasty case using filter_dfuns in -callsForMe To be honest I'm not 100% certain that this is 100% +callsForMe. To be honest I'm not 100% certain that this is 100% right, but it works. Sigh. @@ -1328,13 +1416,17 @@ newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argu -- -- The list of types and dictionaries is guaranteed to -- match the type of f -type CallInfoSet = Map CallKey ([DictExpr], VarSet) +data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) -- Range is dict args and the vars of the whole -- call (including tyvars) -- [*not* include the main id itself, of course] type CallInfo = (CallKey, ([DictExpr], VarSet)) +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (ptext (sLit "CIS") <+> ppr fn) + 2 (ppr map) + instance Outputable CallKey where ppr (CallKey ts) = ppr ts @@ -1352,22 +1444,23 @@ instance Ord CallKey where cmp (Just t1) (Just t2) = tcCmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusVarEnv_C Map.union c1 c2 +unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 --- plusCalls :: UsageDetails -> CallDetails -> UsageDetails --- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds } +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = CIS f (calls1 `Map.union` calls2) callDetailsFVs :: CallDetails -> VarSet callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs call_info = Map.foldRightWithKey (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info +callInfoFVs (CIS _ call_info) = Map.foldRight (\(_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info ------------------------------------------------------------ singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails singleCall id tys dicts = MkUD {ud_binds = emptyBag, - ud_calls = unitVarEnv id (Map.singleton (CallKey tys) (dicts, call_fvs)) } + ud_calls = unitVarEnv id $ CIS id $ + Map.singleton (CallKey tys) (dicts, call_fvs) } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) @@ -1383,8 +1476,8 @@ singleCall id tys dicts mkCallUDs :: Id -> [CoreExpr] -> UsageDetails mkCallUDs f args - | not (isLocalId f) -- Imported from elsewhere - || null theta -- Not overloaded + | not (want_calls_for f) -- Imported from elsewhere + || null theta -- Not overloaded || not (all isClassPred theta) -- Only specialise if all overloading is on class params. -- In ptic, with implicit params, the type args @@ -1411,6 +1504,8 @@ mkCallUDs f args mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars = Just ty | otherwise = Nothing + + want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) \end{code} Note [Interesting dictionary arguments] @@ -1541,7 +1636,7 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn } calls_for_me = case lookupVarEnv orig_calls fn of Nothing -> [] - Just cs -> filter_dfuns (Map.toList cs) + Just (CIS _ calls) -> filter_dfuns (Map.toList calls) dep_set = foldlBag go (unitVarSet fn) orig_dbs go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set @@ -1578,7 +1673,8 @@ deleteCallsMentioning bs calls = mapVarEnv filter_calls calls where filter_calls :: CallInfoSet -> CallInfoSet - filter_calls = Map.filterWithKey (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs)) + filter_calls (CIS f calls) = CIS f (Map.filter keep_call calls) + keep_call (_, fvs) = not (fvs `intersectsVarSet` bs) deleteCallsFor :: [Id] -> CallDetails -> CallDetails -- Remove calls *for* bs @@ -1595,8 +1691,9 @@ deleteCallsFor bs calls = delVarEnvList calls bs \begin{code} type SpecM a = UniqSM a -initSM :: UniqSupply -> SpecM a -> a -initSM = initUs_ +runSpecM:: SpecM a -> CoreM a +runSpecM spec = do { us <- getUniqueSupplyM + ; return (initUs_ us spec) } mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) mapAndCombineSM _ [] = return ([], emptyUDs) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 0db76d14f7..c918c9dd89 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -25,6 +25,7 @@ import TcHsType import TcPat import TcMType import TcType +import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -43,7 +44,10 @@ import BasicTypes import Outputable import FastString +import Data.List( partition ) import Control.Monad + +#include "HsVersions.h" \end{code} @@ -79,13 +83,19 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) +tcTopBinds :: HsValBinds Name + -> TcM ( LHsBinds TcId -- Typechecked bindings + , [LTcSpecPrag] -- SPECIALISE prags for imported Ids + , TcLclEnv) -- Augmented environment + -- Note: returning the TcLclEnv is more than we really -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds - = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv - ; return (foldr (unionBags . snd) emptyBag prs, env) } + = do { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv + ; let binds = foldr (unionBags . snd) emptyBag prs + ; specs <- tcImpPrags sigs + ; return (binds, specs, env) } -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive LHsBinds @@ -360,7 +370,7 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id) -- Zonk, mainly to expose unboxed types to checkStrictBinds ; let mono_id' = setIdType mono_id mono_ty' - ; _specs <- tcSpecPrags False mono_id' (prag_fn name) + ; _specs <- tcSpecPrags mono_id' (prag_fn name) ; return mono_id' } -- NB: tcPrags generates error messages for -- specialisation pragmas for non-overloaded sigs @@ -456,7 +466,7 @@ mkExport prag_fn inferred_tvs theta ; poly_id' <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags (notNull theta) poly_id prag_sigs + ; spec_prags <- tcSpecPrags poly_id prag_sigs -- tcPrags requires a zonked poly_id ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) } @@ -502,42 +512,74 @@ lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env lhsBindArity _ env = env -- PatBind/VarBind ------------------ -tcSpecPrags :: Bool -- True <=> function is overloaded - -> Id -> [LSig Name] - -> TcM [Located TcSpecPrag] +tcSpecPrags :: Id -> [LSig Name] + -> TcM [LTcSpecPrag] -- Add INLINE and SPECIALSE pragmas -- INLINE prags are added to the (polymorphic) Id directly -- SPECIALISE prags are passed to the desugarer via TcSpecPrags -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp -tcSpecPrags is_overloaded_id poly_id prag_sigs - = do { unless (null spec_sigs || is_overloaded_id) warn_discarded_spec - ; unless (null bad_sigs) warn_discarded_sigs - ; mapM (wrapLocM tc_spec) spec_sigs } +tcSpecPrags poly_id prag_sigs + = do { unless (null bad_sigs) warn_discarded_sigs + ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs } where spec_sigs = filter isSpecLSig prag_sigs bad_sigs = filter is_bad_sig prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s) + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + +-------------- +tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag +tcSpec poly_id prag@(SpecSig _ hs_ty inl) + -- The Name in the SpecSig may not be the same as that of the poly_id + -- Example: SPECIALISE for a class method: the Name in the SpecSig is + -- for the selector Id, but the poly_id is something like $cop + = addErrCtxt (spec_ctxt prag) $ + do { spec_ty <- tcHsSigType sig_ctxt hs_ty + ; checkTc (isOverloadedTy poly_ty) + (ptext (sLit "Discarding pragma for non-overloaded function") <+> quotes (ppr poly_id)) + ; wrap <- tcSubType origin skol_info (idType poly_id) spec_ty + ; return (SpecPrag poly_id wrap inl) } + where name = idName poly_id poly_ty = idType poly_id - sig_ctxt = FunSigCtxt name origin = SpecPragOrigin name + sig_ctxt = FunSigCtxt name skol_info = SigSkol sig_ctxt + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) - tc_spec prag@(SpecSig _ hs_ty inl) - = addErrCtxt (spec_ctxt prag) $ - do { spec_ty <- tcHsSigType sig_ctxt hs_ty - ; wrap <- tcSubType origin skol_info poly_ty spec_ty - ; return (SpecPrag wrap inl) } - tc_spec sig = pprPanic "tcSpecPrag" (ppr sig) - - warn_discarded_spec = warnPrags poly_id spec_sigs $ - ptext (sLit "SPECIALISE pragmas for non-overloaded function") - warn_discarded_sigs = warnPrags poly_id bad_sigs $ - ptext (sLit "Discarding unexpected pragmas for") +tcSpec _ prag = pprPanic "tcSpec" (ppr prag) - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) +-------------- +tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +tcImpPrags prags + = do { this_mod <- getModule + ; let is_imp prag + = case sigName prag of + Nothing -> False + Just name -> not (nameIsLocalOrFrom this_mod name) + (spec_prags, others) = partition isSpecLSig $ + filter is_imp prags + ; mapM_ misplacedSigErr others + -- Messy that this misplaced-sig error comes here + -- but the others come from the renamer + ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } + +tcImpSpec :: Sig Name -> TcM TcSpecPrag +tcImpSpec prag@(SpecSig (L _ name) _ _) + = do { id <- tcLookupId name + ; checkTc (isInlinePragma (idInlinePragma id)) + (impSpecErr name) + ; tcSpec id prag } +tcImpSpec p = pprPanic "tcImpSpec" (ppr p) + +impSpecErr :: Name -> SDoc +impSpecErr name + = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) + 2 (ptext (sLit "because its definition has no INLINE/INLINABLE pragma")) -------------- -- If typechecking the binds fails, then return with each diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index a4a00c9511..1a5697ed78 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -220,7 +220,7 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) prags = prag_fn sel_name ; dm_id_w_inline <- addInlinePrags dm_id prags - ; spec_prags <- tcSpecPrags True dm_id prags + ; spec_prags <- tcSpecPrags dm_id prags ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index e2ddc9d9c7..b994a27829 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -352,10 +352,8 @@ renameDeriv is_boot gen_binds insts rm_dups [] $ concat deriv_aux_binds aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; let aux_names = collectHsValBinders rn_aux_lhs - - ; bindLocalNames aux_names $ - do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs + ; bindLocalNames (collectHsValBinders rn_aux_lhs) $ + do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen, dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 46b8c04dfd..5341a4f2ec 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -270,13 +270,14 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet - -> [LRuleDecl TcId] -> [LForeignDecl TcId] + -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] -> TcM ([Id], Bag EvBind, Bag (LHsBind Id), [LForeignDecl Id], + [LTcSpecPrag], [LRuleDecl Id]) -zonkTopDecls ev_binds binds sig_ns rules fords +zonkTopDecls ev_binds binds sig_ns rules imp_specs fords = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds -- Warn about missing signatures @@ -288,8 +289,9 @@ zonkTopDecls ev_binds binds sig_ns rules fords ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds -- Top level is implicitly recursive ; rules' <- zonkRules env2 rules + ; specs' <- zonkLTcSpecPrags env2 imp_specs ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') } + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@ -430,12 +432,16 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- mapM zonk_prag ps +zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] +zonkLTcSpecPrags env ps + = mapM zonk_prag ps where - zonk_prag (L loc (SpecPrag co_fn inl)) + zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag co_fn' inl)) } + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index a76d87bdf2..76ba66fd03 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -789,7 +789,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; let spec_ty = mkSigmaTy tyvars theta tau ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) (idType dfun_id) spec_ty - ; return (SpecPrag co_fn defaultInlinePragma) } + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) @@ -840,15 +840,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let prags = prag_fn (idName sel_id) - ; meth_id1 <- addInlinePrags meth_id prags - ; spec_prags <- tcSpecPrags True meth_id prags - + ; meth_id1 <- addInlinePrags meth_id prags + ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol - tyvars dfun_ev_vars - mb_dict_ev - meth_id1 local_meth_id - meth_sig_fn - (SpecPrags (spec_inst_prags ++ spec_prags)) + tyvars dfun_ev_vars mb_dict_ev + meth_id1 local_meth_id meth_sig_fn + (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } @@ -898,7 +895,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id - , SpecPrags spec_inst_prags)] + , mk_meth_spec_prags meth_id1 [])] , abs_ev_binds = EvBinds (unitBag self_dict_ev) , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own @@ -909,6 +906,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, L loc bind) } ---------------------- + mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the SPECIALISE pragmas to work for this method Id + -- There are two sources: + -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper + -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} + mk_meth_spec_prags meth_id spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ + [ L loc (SpecPrag meth_id wrap inl) + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + loc = getSrcSpan dfun_id meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig" -- But there are no scoped type variables from local_method_id diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a42e85dadb..1e8fc1758a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -394,20 +394,22 @@ tcRnSrcDecls boot_iface decls -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_sigs = sig_ns, - tcg_ev_binds = cur_ev_binds, - tcg_rules = rules, - tcg_fords = fords } = tcg_env + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', rules') - <- zonkTopDecls all_ev_binds binds sig_ns rules fords ; + (bind_ids, ev_binds', binds', fords', imp_specs', rules') + <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', tcg_rules = rules', tcg_fords = fords' } } ; @@ -860,14 +862,14 @@ tcTopSrcDecls boot_details -- Now GHC-generated derived bindings, generics, and selectors -- Do not generate warnings from compiler-generated code; -- hence the use of discardWarnings - (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; - (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ - discardWarnings (tcTopBinds deriv_binds) ; + (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; -- Value declarations next traceTc "Tc5" empty ; - (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ - tcTopBinds val_binds; + (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; setLclTypeEnv tcl_env $ do { -- Environment doesn't change now @@ -900,6 +902,7 @@ tcTopSrcDecls boot_details -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3 , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names , tcg_rules = tcg_rules tcg_env ++ rules , tcg_anns = tcg_anns tcg_env ++ annotations diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index f171336f39..456bd7e45b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -107,20 +107,21 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_rn_exports = maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_binds = emptyLHsBinds, - tcg_sigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_insts = [], - tcg_fam_insts= [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 253a5c08bd..17f8d63012 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -257,6 +257,7 @@ data TcGblEnv tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_insts :: [Instance], -- ...Instances diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index ca918110e3..3acadf137c 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -4,7 +4,7 @@ module FiniteMap ( insertList, insertListWith, deleteList, - foldRightWithKey + foldRight, foldRightWithKey ) where import Data.Map (Map) @@ -23,6 +23,8 @@ insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs deleteList :: Ord key => [key] -> Map key elt -> Map key elt deleteList ks m = foldl (flip Map.delete) m ks +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.fold foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a #if (MIN_VERSION_containers(0,4,0)) foldRightWithKey = Map.foldrWithKey |