Commit 92267aa2 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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
parent 861e1d55
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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))
......
......@@ -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)
......
......@@ -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}
......@@ -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
......
......@@ -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 &&&
......
......@@ -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
......
......@@ -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
......
......@@ -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
]
......
......@@ -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