X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=b5bbeb1940e47b9cb989922a9c0c96f622df59ad;hp=0da6cdb3b61d47a708bf8b31616f5a3edcd9d014;hb=3bb66cc52ced70cd7081fb8a2e32a1005528d5a0;hpb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 0da6cdb..b5bbeb1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,6 @@ import TcHsType import TcPat import TcMType import TcType -import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -44,7 +43,6 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad #include "HsVersions.h" @@ -325,11 +323,13 @@ 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 @@ -348,9 +348,10 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ; return (binds, poly_ids) } where 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 @@ -388,7 +389,7 @@ 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_tau = tau, sig_loc = loc }) + , sig_theta = theta, sig_tau = tau }) prag_fn rec_tc bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau) @@ -399,6 +400,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped ; export <- mkExport prag_fn tvs theta mono_info + ; loc <- getSrcSpanM ; let (_, poly_id, _, _) = export abs_bind = L loc $ AbsBinds { abs_tvs = tvs @@ -415,10 +417,10 @@ tcPolyInfer -- dependencies based on type signatures -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) -tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list +tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list = do { ((binds', mono_infos), wanted) <- captureConstraints $ - tcMonoBinds sig_fn LetLclBndr rec_tc bind_list + tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] @@ -553,40 +555,53 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) -------------- tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +-- SPECIALISE pragamas for imported things 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) _ _) + ; 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 - ; checkTc (isAnyInlinePragma (idInlinePragma id)) - (impSpecErr name) + ; unless (isAnyInlinePragma (idInlinePragma id)) + (addWarnTc (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 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") - , ptext (sLit "(or you compiled its defining module without -O)")]) + , parens $ sep + [ ptext (sLit "or its defining module") <+> quotes (ppr mod) + , ptext (sLit "was compiled without -O")]]) + where + mod = nameModule name -------------- -tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId] +tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) tcVectDecls decls = do { decls' <- mapM (wrapLocM tcVect) decls - ; let ids = [unLoc id | L _ (HsVect id _) <- decls'] + ; let ids = map lvectDeclName decls' dups = findDupsEq (==) ids ; mapM_ reportVectDups dups + ; traceTcConstraints "End of tcVectDecls" ; return decls' } where @@ -604,7 +619,7 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId) tcVect (HsVect name Nothing) = addErrCtxt (vectCtxt name) $ do { id <- wrapLocM tcLookupId name - ; return (HsVect id Nothing) + ; return $ HsVect id Nothing } tcVect (HsVect name@(L loc _) (Just rhs)) = addErrCtxt (vectCtxt name) $ @@ -619,9 +634,10 @@ tcVect (HsVect name@(L loc _) (Just rhs)) ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind] ; traceTc "tcVect inferred type" $ ppr (varType id') + ; traceTc "tcVect bindings" $ ppr binds - -- add the type variable and dictionary bindings produced by type generalisation to the - -- right-hand side of the vectorisation declaration + -- 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 @@ -633,6 +649,11 @@ tcVect (HsVect name@(L loc _) (Just rhs)) -- 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 @@ -850,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}