\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcPolyBinds,
- PragFun, tcPrags, mkPragFun,
+ PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
TcSigInfo(..), SigFun, mkSigFun,
badBootDeclErr ) where
import Name
import NameSet
import NameEnv
-import VarSet
import SrcLoc
import Bag
+import ListSetOps
import ErrUtils
import Digraph
import Maybes
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) }
-}
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
= setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
- -- Set up main recoer; take advantage of any type sigs
+ -- Set up main recover; take advantage of any type sigs
{ traceTc "------------------------------------------------" empty
; traceTc "Bindings for" (ppr binder_names)
+ -- Instantiate the polytypes of any binders that have signatures
+ -- (as determined by sig_fn), returning a TcSigInfo for each
; tc_sig_fn <- tcInstSigs sig_fn binder_names
; dflags <- getDOpts
; 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
-- They desugar to a case expression in the end
; checkStrictBinds top_lvl rec_group bind_list poly_ids
- -- Warn about missing signatures
- -- Do this only when we we have a type to offer
- ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
- ; when (isTopLevel top_lvl && warn_missing_sigs) $
- mapM_ missingSigWarn (filter no_sig poly_ids)
-
; return (binds, poly_ids) }
where
- no_sig id = isNothing (sig_fn (idName id))
-
binder_names = collectHsBindListBinders bind_list
- loc = getLoc (head bind_list)
- -- TODO: location a bit awkward, but the mbinds have been
- -- dependency analysed and may no longer be adjacent
+ loc = foldr1 combineSrcSpans (map getLoc bind_list)
+ -- The mbinds have been dependency analysed and
+ -- may no longer be adjacent; so find the narrowest
+ -- span that includes them all
+------------------
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 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 binds a single variable,
-- 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
+ , sig_theta = theta, sig_tau = tau })
+ prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta
-
- ; let skol_info = SigSkol (FunSigCtxt (idName id))
+ ; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
; (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) 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
+ ; loc <- getSrcSpanM
; let (_, poly_id, _, _) = export
abs_bind = L loc $ AbsBinds
{ abs_tvs = tvs
, 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 tc_sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
- <- getConstraints $
- tcMonoBinds sig_fn False rec_tc bind_list
+ <- captureConstraints $
+ tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
- ; let get_tvs | isTopLevel top_lvl = tyVarsOfType
- | otherwise = exactTyVarsOfType
- -- See Note [Silly type synonym] in TcType
- tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
-
- ; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted
+ ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
+ ; (qtvs, givens, ev_binds) <- simplifyInfer top_lvl mono name_taus 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 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
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]
= 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 :: 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
-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
-
- ; unless (null bad_sigs) warn_discarded_sigs
-
- ; return (poly_id', spec_prags) }
+tcSpecPrags poly_id prag_sigs
+ = do { unless (null bad_sigs) warn_discarded_sigs
+ ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) 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)
- 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") )
--}
+--------------
+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
+ ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
+ (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
+ -- Note [SPECIALISE pragmas]
+ ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
+ ; return (SpecPrag poly_id wrap inl) }
+ where
+ name = idName poly_id
+ poly_ty = idType poly_id
+ origin = SpecPragOrigin name
+ sig_ctxt = FunSigCtxt name
+ spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+
+tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
-warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
-warnPrags id bad_sigs herald
- = addWarnTc (hang (herald <+> quotes (ppr id))
- 2 (ppr_sigs bad_sigs))
+--------------
+tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
+-- SPECIALISE pragamas for imported things
+tcImpPrags prags
+ = do { this_mod <- getModule
+ ; dflags <- getDOpts
+ ; if (not_specialising dflags) then
+ return []
+ else
+ mapAndRecoverM (wrapLocM tcImpSpec)
+ [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ] }
+ where
+ -- Ignore SPECIALISE pragmas for imported things
+ -- when we aren't specialising, or when we aren't generating
+ -- code. The latter happens when Haddocking the base library;
+ -- we don't wnat complaints about lack of INLINABLE pragmas
+ not_specialising dflags
+ | not (dopt Opt_Specialise dflags) = True
+ | otherwise = case hscTarget dflags of
+ HscNothing -> True
+ HscInterpreted -> True
+ _other -> False
+
+tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
+tcImpSpec (name, prag)
+ = do { id <- tcLookupId name
+ ; unless (isAnyInlinePragma (idInlinePragma id))
+ (addWarnTc (impSpecErr name))
+ ; tcSpec id prag }
+
+impSpecErr :: Name -> SDoc
+impSpecErr name
+ = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
+ 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
+ , parens $ sep
+ [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
+ , ptext (sLit "was compiled without -O")]])
where
- ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
+ mod = nameModule name
--------------
-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) }
+tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
+tcVectDecls decls
+ = do { decls' <- mapM (wrapLocM tcVect) decls
+ ; let ids = map lvectDeclName decls'
+ dups = findDupsEq (==) ids
+ ; mapM_ reportVectDups dups
+ ; traceTcConstraints "End of tcVectDecls"
+ ; return decls'
+ }
where
- spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
-tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig)
+ reportVectDups (first:_second:_more)
+ = addErrAt (getSrcSpan first) $
+ ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
+ reportVectDups _ = return ()
+
+--------------
+tcVect :: VectDecl Name -> TcM (VectDecl TcId)
+-- We can't typecheck the expression of a vectorisation declaration against the vectorised type
+-- of the original definition as this requires internals of the vectoriser not available during
+-- type checking. Instead, we infer the type of the expression and leave it to the vectoriser
+-- to check the compatibility of the Core types.
+tcVect (HsVect name Nothing)
+ = addErrCtxt (vectCtxt name) $
+ do { id <- wrapLocM tcLookupId name
+ ; return $ HsVect id Nothing
+ }
+tcVect (HsVect name@(L loc _) (Just rhs))
+ = addErrCtxt (vectCtxt name) $
+ do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined
+
+ -- turn the vectorisation declaration into a single non-recursive binding
+ ; let bind = L loc $ mkFunBind name [mkSimpleMatch [] rhs]
+ sigFun = const Nothing
+ pragFun = mkPragFun [] (unitBag bind)
+
+ -- perform type inference (including generalisation)
+ ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
+
+ ; traceTc "tcVect inferred type" $ ppr (varType id')
+ ; traceTc "tcVect bindings" $ ppr binds
+
+ -- add all bindings, including the type variable and dictionary bindings produced by type
+ -- generalisation to the right-hand side of the vectorisation declaration
+ ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
+ ; let [bind'] = bagToList actualBinds
+ MatchGroup
+ [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
+ _ = (fun_matches . unLoc) bind'
+ rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
+
+ -- We return the type-checked 'Id', to propagate the inferred signature
+ -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
+ ; return $ HsVect (L loc id') (Just rhsWrapped)
+ }
+tcVect (HsNoVect name)
+ = addErrCtxt (vectCtxt name) $
+ do { id <- wrapLocM tcLookupId name
+ ; return $ HsNoVect id
+ }
+
+vectCtxt :: Located Name -> SDoc
+vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
--------------
-- If typechecking the binds fails, then return with each
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
\end{code}
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+ reverse :: [a] -> [a]
+ {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+ data Arr e where
+ ArrInt :: !Int -> ByteArray# -> Arr Int
+ ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+ (!:) :: Arr e -> Int -> e
+ {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
+ {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+ (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
+ (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
%************************************************************************
%* *
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)
-- Type signature (if any), and
-- the monomorphic bound things
-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 }) }
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoI cois)
+ checkTc (all isReflCo cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
\end{code}
in
fm
-
-
%************************************************************************
%* *
Signatures
| Just (scoped_tvs, loc) <- sig_fn name
= do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
- ; (tvs, theta, tau) <- tcInstSigType use_skols name (idType poly_id)
+ ; let poly_ty = idType poly_id
+ ; (tvs, theta, tau) <- if use_skols
+ then tcInstType tcInstSkolTyVars poly_ty
+ else tcInstType tcInstSigTyVars poly_ty
; let sig = TcSigInfo { sig_id = poly_id
, sig_scoped = scoped_tvs
, sig_tvs = tvs, sig_theta = theta, sig_tau = tau
decideGeneralisationPlan
:: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
+ | bang_pat_binds = NoGen
| mono_pat_binds = NoGen
| Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
then NoGen -- Optimise common case
&& 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
+ bang_pat_binds = any (isBangHsBind . unLoc) binds
+ -- Bang patterns must not be polymorphic,
+ -- because we are going to force them
+ -- See Trac #4498
+
+ mono_pat_binds = xopt Opt_MonoPatBinds dflags
&& any (is_pat_bind . unLoc) binds
mono_restriction = xopt Opt_MonomorphismRestriction dflags
; checkTc (isNonRec rec_group)
(strictBindErr "Recursive" unlifted binds)
; checkTc (isSingleton binds)
- (strictBindErr "Multiple" unlifted binds)
+ (strictBindErr "Multiple" unlifted binds)
-- This should be a checkTc, not a warnTc, but as of GHC 6.11
-- the versions of alex and happy available have non-conforming
-- templates, so the GHC build fails if it's an error:
; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
- ; warnTc (warnUnlifted && not bang_pat)
+ ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
+ -- No outer bang, but it's a compound pattern
+ -- E.g (I# x#) = blah
+ -- Warn about this, but not about
+ -- x# = 4# +# 1#
+ -- (# a, b #) = ...
(unliftedMustBeBang binds) }
| otherwise
= return ()
where
- unlifted = any is_unlifted poly_ids
- bang_pat = any (isBangHsBind . unLoc) binds
+ unlifted = any is_unlifted poly_ids
+ bang_pat = any (isBangHsBind . unLoc) binds
+ lifted_pat = any (isLiftedPatBind . unLoc) binds
is_unlifted id = case tcSplitForAllTys (idType id) of
(_, rho) -> isUnLiftedType rho
unliftedMustBeBang :: [LHsBind Name] -> SDoc
unliftedMustBeBang binds
- = hang (text "Bindings containing unlifted types should use an outermost bang pattern:")
+ = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
2 (pprBindList binds)
strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
where
id1 = sig_id sig1
id2 = sig_id sig2
-
------------------------------------------------
-{-
-badStrictSig :: Bool -> TcSigInfo -> SDoc
-badStrictSig unlifted sig
- = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg)
- 2 (ppr sig)
- where
- msg | unlifted = ptext (sLit "an unlifted binding")
- | otherwise = ptext (sLit "a bang-pattern binding")
-
-restrictedBindSigErr :: [Name] -> SDoc
-restrictedBindSigErr binder_names
- = hang (ptext (sLit "Illegal type signature(s)"))
- 2 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names,
- ptext (sLit "that falls under the monomorphism restriction")])
-
-genCtxt :: [Name] -> SDoc
-genCtxt binder_names
- = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names
--}
-
-missingSigWarn :: TcId -> TcM ()
-missingSigWarn id
- = do { env0 <- tcInitTidyEnv
- ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
- ; addWarnTcM (env1, mk_msg tidy_ty) }
- where
- name = idName id
- mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name),
- sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]]
\end{code}
projects / ghc-hetmet.git / blobdiff