X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=b5bbeb1940e47b9cb989922a9c0c96f622df59ad;hp=368ede48694003858982a0a45c2dbb018d9689f8;hb=HEAD;hpb=6eff70f0286a307a7266c87358493478b5f54933 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 368ede4..b5bbeb1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcPolyBinds, - PragFun, tcPrags, mkPragFun, + PragFun, tcSpecPrags, tcVectDecls, mkPragFun, TcSigInfo(..), SigFun, mkSigFun, badBootDeclErr ) where @@ -32,9 +32,9 @@ import Var import Name import NameSet import NameEnv -import VarSet import SrcLoc import Bag +import ListSetOps import ErrUtils import Digraph import Maybes @@ -43,8 +43,9 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad + +#include "HsVersions.h" \end{code} @@ -80,13 +81,19 @@ At the top-level the LIE is sure to contain nothing but constant 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 @@ -121,14 +128,12 @@ tcLocalBinds (HsValBinds binds) thing_inside 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 @@ -155,6 +160,9 @@ doesn't float that solved constraint out (it's not an unsolved 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 @@ -262,7 +270,7 @@ bindLocalInsts top_lvl thing_inside -- 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) } -} @@ -315,52 +323,48 @@ tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun 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 @@ -368,16 +372,15 @@ tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list = 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] @@ -386,18 +389,18 @@ tcPolyCheck :: TcSigInfo -> PragFun -- 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 @@ -405,31 +408,26 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped , 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] @@ -445,10 +443,7 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list -------------- -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 @@ -462,17 +457,19 @@ mkExport :: RecFlag -- 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 @@ -496,7 +493,9 @@ mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] 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] @@ -512,89 +511,152 @@ lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env = 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 @@ -614,6 +676,26 @@ forall_a_a :: TcType 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. %************************************************************************ %* * @@ -625,8 +707,7 @@ forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) 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 @@ -647,7 +728,7 @@ tcMonoBinds sig_fn no_gen is_rec 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 })), @@ -685,22 +766,22 @@ tcMonoBinds sig_fn no_gen _ binds -- 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 $ @@ -720,28 +801,17 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) 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 }) } @@ -801,7 +871,7 @@ unifyCtxts (sig1 : sigs) -- 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} @@ -905,8 +975,6 @@ Then we get in fm - - %************************************************************************ %* * Signatures @@ -1051,7 +1119,10 @@ tcInstSig sig_fn use_skols name | 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 @@ -1078,22 +1149,25 @@ instance Outputable GeneralisationPlan where 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 else CheckGen sig - | (dopt Opt_MonoLocalBinds dflags + | (xopt Opt_MonoLocalBinds dflags && 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 = dopt 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 = dopt Opt_MonomorphismRestriction dflags + mono_restriction = xopt Opt_MonomorphismRestriction dflags && any (restricted . unLoc) binds no_sig n = isNothing (sig_fn n) @@ -1134,24 +1208,30 @@ checkStrictBinds top_lvl rec_group binds poly_ids ; 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 @@ -1191,35 +1271,4 @@ sigContextsCtxt sig1 sig2 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}