= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; body' <- mkOptTickBox tick body
; wrap_fn' <- dsHsWrapper co_fn
- ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
+ ; let rhs = wrap_fn' (mkLams args body')
+ ; return (unitOL (makeCorePair fun False 0 rhs)) }
dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
= do { body_expr <- dsGuarded grhss ty
; sel_binds <- mkSelectorBinds pat body_expr
+ -- We silently ignore inline pragmas; no makeCorePair
+ -- Not so cool, but really doesn't matter
; return (toOL sel_binds) }
-{-
-dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
- , abs_exports = exports, abs_ev_binds = ev_binds
- , abs_binds = binds })
- = do { bind_prs <- ds_lhs_binds NoSccs binds
- ; ds_ev_binds <- dsTcEvBinds ev_binds
-
- ; let core_prs = addEvPairs ds_ev_binds bind_prs
- env = mkABEnv exports
- do_one (lcl_id, rhs)
- | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
- = do { let rhs' = addAutoScc auto_scc gbl_id rhs
- ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
- -- See Note [Specialising in no-dict case]
- ; let gbl_id' = addIdSpecialisations gbl_id rules
- main_bind = makeCorePair gbl_id' False 0 rhs'
- ; return (main_bind : spec_binds) }
-
- | otherwise = return [(lcl_id, rhs)]
-
- locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
- -- Note [Rules and inlining]
- ; export_binds <- mapM do_one core_prs
- ; return (concat export_binds ++ locals' ++ rest) }
- -- No Rec needed here (contrast the other AbsBinds cases)
- -- because we can rely on the enclosing dsBind to wrap in Rec
-
-
-dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
- , abs_exports = exports, abs_ev_binds = ev_binds
- , abs_binds = binds })
- | opt_DsMultiTyVar -- This (static) debug flag just lets us
- -- switch on and off this optimisation to
- -- see if it has any impact; it is on by default
- , allOL isLazyEvBind ev_binds
- = -- Note [Abstracting over tyvars only]
- do { bind_prs <- ds_lhs_binds NoSccs binds
- ; ds_ev_binds <- dsTcEvBinds ev_binds
-
- ; let core_prs = addEvPairs ds_ev_binds bind_prs
- arby_env = mkArbitraryTypeEnv tyvars exports
- bndrs = mkVarSet (map fst core_prs)
-
- add_lets | core_prs `lengthExceeds` 10 = add_some
- | otherwise = mkLets
- add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
- , b `elemVarSet` fvs] rhs
- where
- fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
-
- env = mkABEnv exports
- mk_lg_bind lcl_id gbl_id tyvars
- = NonRec (setIdInfo lcl_id vanillaIdInfo)
- -- Nuke the IdInfo so that no old unfoldings
- -- confuse use (it might mention something not
- -- even in scope at the new site
- (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
-
- do_one lg_binds (lcl_id, rhs)
- | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
- = do { let rhs' = addAutoScc auto_scc gbl_id $
- mkLams id_tvs $
- mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
- | tv <- tyvars, not (tv `elem` id_tvs)] $
- add_lets lg_binds rhs
- ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
- ; let gbl_id' = addIdSpecialisations gbl_id rules
- main_bind = makeCorePair gbl_id' False 0 rhs'
- ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
- | otherwise
- = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
- ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
- [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
-
- ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
- ; return (concat core_prs' ++ rest) }
--}
-
-- A common case: one exported variable
-- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings
because they desugar to
M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
Although I'm a bit worried about whether full laziness might
-float the f_lcl binding out and then inline M.f at its call site -}
+float the f_lcl binding out and then inline M.f at its call site
Note [Specialising in no-dict case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcPolyBinds,
- PragFun, tcPrags, mkPragFun,
+ PragFun, tcSpecPrags, mkPragFun,
TcSigInfo(..), SigFun, mkSigFun,
badBootDeclErr ) where
import Outputable
import FastString
-import Data.List( partition )
import Control.Monad
\end{code}
; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn
; traceTc "Generalisation plan" (ppr plan)
; (binds, poly_ids) <- case plan of
- NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list
- InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_group rec_tc bind_list
- CheckGen sig -> tcPolyCheck sig prag_fn rec_group rec_tc bind_list
+ NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
+ InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
+ CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list
-- Check whether strict bindings are ok
-- These must be non-recursive etc, and are not generalised
-- TODO: location a bit awkward, but the mbinds have been
-- dependency analysed and may no longer be adjacent
+------------------
tcPolyNoGen
:: TcSigFun -> PragFun
- -> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-- No generalisation whatsoever
-tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list
- = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn True rec_tc bind_list
+tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
+ = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn)
+ rec_tc bind_list
; mono_ids' <- mapM tc_mono_info mono_infos
; return (binds', mono_ids') }
where
= do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
-- Zonk, mainly to expose unboxed types to checkStrictBinds
; let mono_id' = setIdType mono_id mono_ty'
- ; (mono_id'', _specs) <- tcPrags rec_group False False
- mono_id' (prag_fn name)
- ; return mono_id'' }
- -- NB: tcPrags generates and error message for
+ ; _specs <- tcSpecPrags False mono_id' (prag_fn name)
+ ; return mono_id' }
+ -- NB: tcPrags generates error messages for
-- specialisation pragmas for non-overloaded sigs
+ -- Indeed that is why we call it here!
-- So we can safely ignore _specs
------------------
tcPolyCheck :: TcSigInfo -> PragFun
- -> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-- it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
, sig_theta = theta, sig_loc = loc })
- prag_fn rec_group rec_tc bind_list
+ prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName id))
; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info emptyVarSet tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
- tcMonoBinds (\_ -> Just sig) False rec_tc bind_list
+ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
- ; export <- mkExport rec_group False prag_fn tvs theta mono_info
+ ; export <- mkExport prag_fn tvs theta mono_info
; let (_, poly_id, _, _) = export
abs_bind = L loc $ AbsBinds
, abs_exports = [export], abs_binds = binds' }
; return (unitBag abs_bind, [poly_id]) }
+------------------
tcPolyInfer
:: TopLevelFlag
-> Bool -- True <=> apply the monomorphism restriction
-> TcSigFun -> PragFun
- -> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list
+tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
<- getConstraints $
- tcMonoBinds sig_fn False rec_tc bind_list
+ tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted
- ; exports <- mapM (mkExport rec_group (length mono_infos > 1)
- prag_fn qtvs (map evVarPred givens))
+ ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
mono_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
--------------
-mkExport :: RecFlag
- -> Bool -- More than one variable is bound, so we'll desugar to
- -- a tuple, so INLINE pragmas won't work
- -> PragFun -> [TyVar] -> TcThetaType
+mkExport :: PragFun -> [TyVar] -> TcThetaType
-> MonoBindInfo
-> TcM ([TyVar], Id, Id, TcSpecPrags)
-- mkExport generates exports with
-- Pre-condition: the inferred_tvs are already zonked
-mkExport rec_group multi_bind prag_fn inferred_tvs theta
+mkExport prag_fn inferred_tvs theta
(poly_name, mb_sig, mono_id)
= do { (tvs, poly_id) <- mk_poly_id mb_sig
-- poly_id has a zonked type
- ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull theta)
- poly_id (prag_fn poly_name)
+ ; poly_id' <- addInlinePrags poly_id prag_sigs
+
+ ; spec_prags <- tcSpecPrags (notNull theta) poly_id prag_sigs
-- tcPrags requires a zonked poly_id
; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
where
+ prag_sigs = prag_fn poly_name
poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id)
mk_poly_id Nothing = do { poly_ty' <- zonkTcTypeCarefully poly_ty
= extendNameEnv env (unLoc id) (matchGroupArity ms)
lhsBindArity _ env = env -- PatBind/VarBind
-tcPrags :: RecFlag
- -> Bool -- True <=> AbsBinds binds more than one variable
- -> Bool -- True <=> function is overloaded
- -> Id -> [LSig Name]
- -> TcM (Id, [Located TcSpecPrag])
+------------------
+tcSpecPrags :: Bool -- True <=> function is overloaded
+ -> Id -> [LSig Name]
+ -> TcM [Located TcSpecPrag]
-- 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
-tcPrags _rec_group _multi_bind is_overloaded_id poly_id prag_sigs
- = do { poly_id' <- tc_inl inl_sigs
-
- ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs
-
- ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec
-
+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
-
- ; return (poly_id', spec_prags) }
+ ; mapM (wrapLocM tc_spec) spec_sigs }
where
- (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs
- (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs
+ spec_sigs = filter isSpecLSig prag_sigs
+ bad_sigs = filter is_bad_sig prag_sigs
+ is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
+
+ name = idName poly_id
+ poly_ty = idType poly_id
+ sig_ctxt = FunSigCtxt name
+ origin = SpecPragOrigin name
+ skol_info = SigSkol sig_ctxt
+
+ 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_dup_inline = warnPrags poly_id inl_sigs $
- ptext (sLit "Duplicate INLINE pragmas for")
warn_discarded_sigs = warnPrags poly_id bad_sigs $
ptext (sLit "Discarding unexpected pragmas for")
- -----------
- tc_inl [] = return poly_id
- tc_inl (L loc (InlineSig _ prag) : other_inls)
- = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
- ; return (poly_id `setInlinePragma` prag) }
- tc_inl _ = panic "tc_inl"
-
-{- Earlier we tried to warn about
- (a) INLINE for recursive function
- (b) INLINE for function that is part of a multi-binder group
- Code fragments below. But we want to allow
- {-# INLINE f #-}
- f x = x : g y
- g y = ....f...f....
- even though they are mutually recursive.
- So I'm just omitting the warnings for now
-
- | multi_bind && isInlinePragma prag
- = do { setSrcSpan loc $ addWarnTc multi_bind_warn
- ; return poly_id }
- | otherwise
- ; when (isInlinePragma prag && isRec rec_group)
- (setSrcSpan loc (addWarnTc rec_inline_warn))
-
- rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder")
- <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded")
-
- multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id))
- 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") )
--}
-
-
-warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
-warnPrags id bad_sigs herald
- = addWarnTc (hang (herald <+> quotes (ppr id))
- 2 (ppr_sigs bad_sigs))
- where
- ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
-
---------------
-tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag
-tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl)
- = addErrCtxt (spec_ctxt prag) $
- do { let name = idName poly_id
- sig_ctxt = FunSigCtxt name
- ; spec_ty <- tcHsSigType sig_ctxt hs_ty
- ; wrap <- tcSubType (SpecPragOrigin name) (SigSkol sig_ctxt)
- (idType poly_id) spec_ty
- ; return (SpecPrag wrap inl) }
- where
spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
-tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig)
--------------
-- If typechecking the binds fails, then return with each
The signatures have been dealt with already.
\begin{code}
-tcMonoBinds :: TcSigFun
- -> Bool -- True <=> no generalisation will be done for this binding
+tcMonoBinds :: TcSigFun -> LetBndrSpec
-> RecFlag -- Whether the binding is recursive for typechecking purposes
-- i.e. the binders are mentioned in their RHSs, and
-- we are not resuced by a type signature
setSrcSpan b_loc $
do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
- ; mono_id <- newLetBndr no_gen name rhs_ty
+ ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
fun_matches = matches', bind_fvs = fvs,
fun_co_fn = co_fn, fun_tick = Nothing })),
-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
data TcMonoBind -- Half completed; LHS done, RHS not done
- = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
+ = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name)
| TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
getMonoType :: MonoBindInfo -> TcTauType
getMonoType (_,_,mono_id) = idType mono_id
-tcLhs :: TcSigFun -> Bool -> HsBind Name -> TcM TcMonoBind
+tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
- = do { mono_id <- newLhsBndr mb_sig no_gen name
- ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
- where
- mb_sig = sig_fn name
+ | Just sig <- sig_fn name
+ = do { mono_id <- newSigLetBndr no_gen name sig
+ ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
+ | otherwise
+ = do { mono_ty <- newFlexiTyVarTy argTypeKind
+ ; mono_id <- newNoSigLetBndr no_gen name mono_ty
+ ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
= do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-- AbsBind, VarBind impossible
------------------
-newLhsBndr :: Maybe TcSigInfo -> Bool -> Name -> TcM TcId
--- cf TcPat.tcPatBndr (LetPat case)
-newLhsBndr (Just sig) no_gen name
- | no_gen = return (sig_id sig)
- | otherwise = do { mono_name <- newLocalName name
- ; return (mkLocalId mono_name (sig_tau sig)) }
-
-newLhsBndr Nothing no_gen name
- = do { mono_ty <- newFlexiTyVarTy argTypeKind
- ; newLetBndr no_gen name mono_ty }
-
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-- When we are doing pattern bindings, or multiple function bindings at a time
-- we *don't* bring any scoped type variables into scope
-- Wny not? They are not completely rigid.
-- That's why we have the special case for a single FunBind in tcMonoBinds
-tcRhs (TcFunBind (_,_,mono_id) fun' inf matches)
+tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
= do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
matches (idType mono_id)
- ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches'
+ ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
+ , fun_matches = matches'
, fun_co_fn = co_fn
, bind_fvs = placeHolderNames, fun_tick = Nothing }) }
in
fm
-
-
%************************************************************************
%* *
Signatures
&& isNotTopLevel top_lvl) = NoGen
| otherwise = InferGen mono_restriction
--- | all no_sig bndrs = InferGen mono_restriction
--- | otherwise = NoGen -- A mixture of function
--- -- and pattern bindings
where
mono_pat_binds = xopt Opt_MonoPatBinds dflags
&& any (is_pat_bind . unLoc) binds
TcPat: Typechecking patterns
\begin{code}
-module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..)
- , tcPat, tcPats, newLetBndr
+module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..), TcPragFun
+ , LetBndrSpec(..), addInlinePrags, warnPrags
+ , tcPat, tcPats, newNoSigLetBndr, newSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
%************************************************************************
\begin{code}
-tcLetPat :: (Name -> Maybe TcSigInfo)
- -> Bool -- True <=> monomorphic
+tcLetPat :: TcSigFun -> LetBndrSpec
-> LPat Name -> TcSigmaType
-> TcM a
-> TcM (LPat TcId, a)
-tcLetPat sig_fn is_mono pat pat_ty thing_inside
+tcLetPat sig_fn no_gen pat pat_ty thing_inside
= tc_lpat pat pat_ty penv thing_inside
where
penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True
- , pe_ctxt = LetPat sig_fn is_mono }
+ , pe_ctxt = LetPat sig_fn no_gen }
-----------------
tcPats :: HsMatchContext Name
| LetPat -- Used only for let(rec) bindings
-- See Note [Let binders]
- TcSigFun -- Tells type sig if any
- Bool -- True <=> no generalisation of this let
-
+ TcSigFun -- Tells type sig if any
+ LetBndrSpec -- True <=> no generalisation of this let
+
+data LetBndrSpec
+ = LetLclBndr -- The binder is just a local one;
+ -- an AbsBinds will provide the global version
+
+ | LetGblBndr TcPragFun -- There isn't going to be an AbsBinds;
+ -- here is the inline-pragma information
+
makeLazy :: PatEnv -> PatEnv
makeLazy penv = penv { pe_lazy = True }
patSigCtxt (PE { pe_ctxt = LamPat {} }) = LamPatSigCtxt
---------------
-type TcSigFun = Name -> Maybe TcSigInfo
+type TcPragFun = Name -> [LSig Name]
+type TcSigFun = Name -> Maybe TcSigInfo
data TcSigInfo
= TcSigInfo {
--
tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
| Just sig <- lookup_sig bndr_name
- = do { bndr_id <- if no_gen then return (sig_id sig)
- else do { mono_name <- newLocalName bndr_name
- ; return (Id.mkLocalId mono_name (sig_tau sig)) }
+ = do { bndr_id <- newSigLetBndr no_gen bndr_name sig
; coi <- unifyPatType (idType bndr_id) pat_ty
; return (coi, bndr_id) }
| otherwise
- = do { bndr_id <- newLetBndr no_gen bndr_name pat_ty
+ = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
; return (IdCo pat_ty, bndr_id) }
tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
= do { bndr <- mkLocalBinder bndr_name pat_ty
; return (IdCo pat_ty, bndr) }
-newLetBndr :: Bool -> Name -> TcType -> TcM TcId
+------------
+newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId
+newSigLetBndr LetLclBndr name sig
+ = do { mono_name <- newLocalName name
+ ; mkLocalBinder mono_name (sig_tau sig) }
+newSigLetBndr (LetGblBndr prags) name sig
+ = addInlinePrags (sig_id sig) (prags name)
+
+------------
+newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
-- In the polymorphic case (no_gen = False), generate a "monomorphic version"
-- of the Id; the original name will be bound to the polymorphic version
-- by the AbsBinds
-- In the monomorphic case there is no AbsBinds, and we use the original
-- name directly
-newLetBndr no_gen name ty
- | no_gen = mkLocalBinder name ty
- | otherwise = do { mono_name <- newLocalName name
- ; mkLocalBinder mono_name ty }
+newNoSigLetBndr LetLclBndr name ty
+ =do { mono_name <- newLocalName name
+ ; mkLocalBinder mono_name ty }
+newNoSigLetBndr (LetGblBndr prags) name ty
+ = do { id <- mkLocalBinder name ty
+ ; addInlinePrags id (prags name) }
+
+----------
+addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
+addInlinePrags poly_id prags
+ = tc_inl inl_sigs
+ where
+ inl_sigs = filter isInlineLSig prags
+ tc_inl [] = return poly_id
+ tc_inl (L loc (InlineSig _ prag) : other_inls)
+ = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+ ; return (poly_id `setInlinePragma` prag) }
+ tc_inl _ = panic "tc_inl"
+
+ warn_dup_inline = warnPrags poly_id inl_sigs $
+ ptext (sLit "Duplicate INLINE pragmas for")
+
+warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
+warnPrags id bad_sigs herald
+ = addWarnTc (hang (herald <+> quotes (ppr id))
+ 2 (ppr_sigs bad_sigs))
+ where
+ ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
-----------------
mkLocalBinder :: Name -> TcType -> TcM TcId
projects / ghc-hetmet.git / commitdiff