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
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
- ; let ip_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet given_ips
-- If the binding binds ?x = E, we must now
-- discharge any ?x constraints in expr_lie
+ -- See Note [Implicit parameter untouchables]
; (ev_binds, result) <- checkConstraints (IPSkol ips)
- ip_tvs -- See Note [Implicit parameter untouchables]
- [] given_ips $
- thing_inside
+ [] given_ips thing_inside
; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
where
wanted. Result disaster: the (Num alpha) is again solved, this
time by defaulting. No no no.
+However [Oct 10] this is all handled automatically by the
+untouchable-range idea.
+
\begin{code}
tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-- leave them to the tcSimplifyTop, and quite a bit faster too
| otherwise -- Nested case
- = do { ((binds, ids, thing), lie) <- getConstraints thing_inside
+ = do { ((binds, ids, thing), lie) <- captureConstraints thing_inside
; lie_binds <- bindLocalMethods lie ids
; return (binds, lie_binds, thing) }
-}
= 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
; let skol_info = SigSkol (FunSigCtxt (idName id))
; (ev_binds, (binds', [mono_info]))
- <- checkConstraints skol_info emptyVarSet tvs ev_vars $
+ <- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
- <- getConstraints $
+ <- captureConstraints $
tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
; 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) }
get_sig _ = Nothing
add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
- | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+ | Just ar <- lookupNameEnv ar_env n,
+ Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar }
+ -- add arity only for real INLINE pragmas, not INLINABLE
| otherwise = inl_prag
prag_env :: NameEnv [LSig Name]
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
projects / ghc-hetmet.git / blobdiff