InlineSpec(..),
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
- isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
+ isDefaultInlinePragma, isInlinePragma, isInlinablePragma,
+ inlinePragmaSpec, inlinePragmaSat,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
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
= 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
-- 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,
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}
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,
<- 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
(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
; 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
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
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
%************************************************************************
\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
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)
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
\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))]
= 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))
import FastString
import Config
import Constants
-
+import OrdList
import Data.Maybe
import Data.List
\end{code}
-- 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
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)
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}
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)
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}
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
put_ bh a5
put_ bh a6
put_ bh a7
+ put_ bh a8
get bh = do
a1 <- get bh
a2 <- get bh
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
ifRuleHead :: Name, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
+ ifRuleAuto :: Bool,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
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 &&&
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
, 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 )
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
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
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) $
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
| Opt_WarnDodgyExports
| Opt_WarnDodgyImports
| Opt_WarnOrphans
+ | Opt_WarnAutoOrphans
| Opt_WarnTabs
| Opt_WarnUnrecognisedPragmas
| Opt_WarnDodgyForeignImports
( "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),
Opt_WarnIncompletePatternsRecUpd,
Opt_WarnMonomorphism,
Opt_WarnUnrecognisedPragmas,
+ Opt_WarnAutoOrphans,
Opt_WarnTabs
]
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 )
-> 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
-- 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)
\end{code}
-
%*********************************************************
%* *
HsLocalBinds
= 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
\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.
-- 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
-- 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
--
-- 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
--
-- 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)
-- 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
\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
= 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) }
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]
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
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
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
; 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
}}
(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
#endif /* GHCI */
import RnSource ( rnSrcDecls, findSplice )
-import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
+import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
= 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
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')))]
-- (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
-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
- lookupRule, mkRule, mkLocalRule, roughTopNames
+ lookupRule, mkRule, roughTopNames
) where
#include "HsVersions.h"
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
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]
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) }
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) }
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
%************************************************************************
\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}
%************************************************************************
%* *
-\subsubsection{Dealing with a binding}
+ Dealing with a binding
%* *
%************************************************************************
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
-- 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
(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
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
-- 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)
-- 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)
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.
--
-- 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
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)
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
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]
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
= 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
\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)
import TcPat
import TcMType
import TcType
+import RnBinds( misplacedSigErr )
import Coercion
import TysPrim
import Id
import Outputable
import FastString
+import Data.List( partition )
import Control.Monad
+
+#include "HsVersions.h"
\end{code}
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
= 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
; 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) }
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
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")
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)) } }
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
; (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)
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}
%************************************************************************
; 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)
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) }
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
; 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
-- 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' } } ;
-- 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
-- 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
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,
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
insertList,
insertListWith,
deleteList,
- foldRightWithKey
+ foldRight, foldRightWithKey
) where
import Data.Map (Map)
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
projects / ghc-hetmet.git / commitdiff