X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=38f4306e06a751819ab122ff31f83820bb20a8a8;hb=21044c2db566270297baef26c0a8d9228e66af7c;hp=f410897174958b9535a29707fb7cb30b6ae3d647;hpb=23e0ac3e0f326bc7d08811105bf71a3195cc84b7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f410897..38f4306 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -7,12 +7,13 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), badBootDeclErr ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcCheckRho ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) ) import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), @@ -20,34 +21,35 @@ import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), LSig, Match(..), IPBind(..), Prag(..), HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, sigName, placeHolderNames, isPragLSig, - LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds, + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, collectHsBindBinders, collectPatBinders, pprPatBind ) -import TcHsSyn ( zonkId, (<$>) ) +import TcHsSyn ( zonkId ) import TcRnMonad import Inst ( newDictsAtLoc, newIPDict, instToId ) import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, - tcLookupLocalIds, pprBinders, + pprBinders, tcLookupLocalId_maybe, tcLookupId, tcGetGlobalTyVars ) -import TcUnify ( Expected(..), tcInfer, unifyTheta, tcSub, +import TcUnify ( tcInfer, tcSubExp, unifyTheta, bleatEscapedTvs, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars, - TcSigInfo(..), TcSigFun, lookupSig - ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar, - tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar ) -import TcType ( TcType, TcTyVar, SkolemInfo(SigSkol), +import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar, + tcInstSigTyVars, tcInstSkolTyVars, tcInstType, + zonkTcType, zonkTcTypes, zonkTcTyVars ) +import TcType ( TcType, TcTyVar, TcThetaType, + SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), TcTauType, TcSigmaType, isUnboxedTupleType, - mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, + mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, mkForAllTy, isUnLiftedType, tcGetTyVar, mkTyVarTys, tidyOpenTyVar ) import Kind ( argTypeKind ) -import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv ) +import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) +import TysWiredIn ( unitTy ) import TysPrim ( alphaTyVar ) import Id ( Id, mkLocalId, mkVanillaGlobal ) import IdInfo ( vanillaIdInfo ) @@ -59,11 +61,11 @@ import VarSet import SrcLoc ( Located(..), unLoc, getLoc ) import Bag import ErrUtils ( Message ) -import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) -import Maybes ( fromJust, isJust, orElse ) +import Digraph ( SCC(..), stronglyConnComp ) +import Maybes ( fromJust, isJust, isNothing, orElse ) import Util ( singleton ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - RecFlag(..), isNonRec ) + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) import Outputable \end{code} @@ -105,7 +107,7 @@ tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) -- 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 + = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv ; return (foldr (unionBags . snd) emptyBag prs, env) } -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive LHsBinds @@ -113,11 +115,11 @@ tcTopBinds binds tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this -tcHsBootSigs (ValBindsIn binds sigs) - = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr +tcHsBootSigs (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } where - tc_boot_sig (Sig (L _ name) ty) + tc_boot_sig (TypeSig (L _ name) ty) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } -- Notice that we make GlobalIds, not LocalIds @@ -151,73 +153,38 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Consider ?x = 4 -- ?y = ?x + 1 tc_ip_bind (IPBind ip expr) - = newTyFlexiVarTy argTypeKind `thenM` \ ty -> + = newFlexiTyVarTy argTypeKind `thenM` \ ty -> newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> - tcCheckRho expr ty `thenM` \ expr' -> + tcMonoExpr expr ty `thenM` \ expr' -> returnM (ip_inst, (IPBind ip' expr')) ------------------------ -mkEdges :: (Name -> Bool) -> [LHsBind Name] - -> [(LHsBind Name, BKey, [BKey])] - -type BKey = Int -- Just number off the bindings - -mkEdges exclude_fn binds - = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)), - let mb_key = lookupNameEnv key_map n, - isJust mb_key, - not (exclude_fn n) ]) - | (bind, key) <- keyd_binds - ] - where - keyd_binds = binds `zip` [0::BKey ..] - - bind_fvs (FunBind _ _ _ fvs) = fvs - bind_fvs (PatBind _ _ _ fvs) = fvs - bind_fvs bind = pprPanic "mkEdges" (ppr bind) - - key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- bindersOfHsBind bind ] - -bindersOfHsBind :: HsBind Name -> [Name] -bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat -bindersOfHsBind (FunBind (L _ f) _ _ _) = [f] - ------------------------- tcValBinds :: TopLevelFlag -> HsValBinds Name -> TcM thing -> TcM (HsValBinds TcId, thing) tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside - = tcAddLetBoundTyVars binds $ - -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE - -- Notice that they scope over - -- a) the type signatures in the binding group - -- b) the bindings in the group - -- c) the scope of the binding group (the "in" part) - - do { -- Typecheck the signature - tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs) - - -- Do the basic strongly-connected component thing - ; let { sccs :: [SCC (LHsBind Name)] - ; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds)) - ; prag_fn = mkPragFun sigs - ; sig_fn = lookupSig tc_ty_sigs - ; sig_ids = map sig_id tc_ty_sigs } + = pprPanic "tcValBinds" (ppr binds) + +tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside + = do { -- Typecheck the signature + ; let { prag_fn = mkPragFun sigs + ; ty_sigs = filter isVanillaLSig sigs + ; sig_fn = mkSigFun ty_sigs } + + ; poly_ids <- mapM tcTySig ty_sigs -- Extend the envt right away with all -- the Ids declared with type signatures - ; (binds', thing) <- tcExtendIdEnv sig_ids $ + ; (binds', thing) <- tcExtendIdEnv poly_ids $ tc_val_binds top_lvl sig_fn prag_fn - sccs thing_inside + binds thing_inside - ; return (ValBindsOut binds', thing) } + ; return (ValBindsOut binds' sigs, thing) } ------------------------ tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun - -> [SCC (LHsBind Name)] -> TcM thing + -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time @@ -226,62 +193,90 @@ tc_val_binds top_lvl sig_fn prag_fn [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside +tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside = do { (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn scc $ - tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside + <- tc_group top_lvl sig_fn prag_fn group $ + tc_val_binds top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun - -> SCC (LHsBind Name) -> TcM thing + -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck one strongly-connected component of the original program. -- We get a list of groups back, because there may -- be specialisations etc as well -tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside = -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly - do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive - sig_fn prag_fn scc thing_inside + do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive + sig_fn prag_fn binds thing_inside ; return ([(NonRecursive, b) | b <- binds], thing) } -tc_group top_lvl sig_fn prag_fn scc@(CyclicSCC binds) thing_inside +tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside = -- A recursive strongly-connected component -- To maximise polymorphism (with -fglasgow-exts), we do a new - -- strongly-connected component analysis, this time omitting + -- strongly-connected-component analysis, this time omitting -- any references to variables with type signatures. -- -- Then we bring into scope all the variables with type signatures - do { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds]) + do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) ; gla_exts <- doptM Opt_GlasgowExts ; (binds,thing) <- if gla_exts then go new_sccs - else go1 scc thing_inside + else tc_binds Recursive binds thing_inside ; return ([(Recursive, unionManyBags binds)], thing) } -- Rec them all together where new_sccs :: [SCC (LHsBind Name)] - new_sccs = stronglyConnComp (mkEdges has_sig binds) + new_sccs = stronglyConnComp (mkEdges sig_fn binds) -- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing) go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs) ; return (binds1 ++ binds2, thing) } go [] = do { thing <- thing_inside; return ([], thing) } - go1 scc thing_inside = tcPolyBinds top_lvl Recursive - sig_fn prag_fn scc thing_inside + go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) + go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) - has_sig :: Name -> Bool - has_sig n = isJust (sig_fn n) + tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds ------------------------ -tcPolyBinds :: TopLevelFlag -> RecFlag +mkEdges :: TcSigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] + +type BKey = Int -- Just number off the bindings + +mkEdges sig_fn binds + = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)), + let mb_key = lookupNameEnv key_map n, + isJust mb_key, + no_sig n ]) + | (bind, key) <- keyd_binds + ] + where + no_sig :: Name -> Bool + no_sig n = isNothing (sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- bindersOfHsBind bind ] + +bindersOfHsBind :: HsBind Name -> [Name] +bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat +bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] + +------------------------ +tcPolyBinds :: TopLevelFlag + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive for typechecking purposes -> TcSigFun -> TcPragFun - -> SCC (LHsBind Name) + -> LHsBinds Name -> TcM thing -> TcM ([LHsBinds TcId], thing) @@ -295,14 +290,14 @@ tcPolyBinds :: TopLevelFlag -> RecFlag -- in which case the dependency order of the resulting bindings is -- important. -tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside +tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside = -- NB: polymorphic recursion means that a function -- may use an instance of itself, we must look at the LIE arising -- from the function's own right hand side. Hence the getLIE - -- encloses the tc_poly_binds. - do { traceTc (text "tcPolyBinds" <+> ppr scc) + -- encloses the tc_poly_binds. + do { traceTc (text "tcPolyBinds" <+> ppr scc) ; ((binds1, poly_ids, thing), lie) <- getLIE $ - do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec + do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn scc ; thing <- tcExtendIdEnv poly_ids thing_inside ; return (binds1, poly_ids, thing) } @@ -320,33 +315,33 @@ tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside ; return (binds1 ++ [lie_binds], thing) }} ------------------------ -tc_poly_binds :: TopLevelFlag -> RecFlag +tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds + -> RecFlag -> RecFlag -> TcSigFun -> TcPragFun - -> SCC (LHsBind Name) + -> LHsBinds Name -> TcM ([LHsBinds TcId], [TcId]) -- Typechecks the bindings themselves -- Knows nothing about the scope of the bindings -tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc +tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds = let - non_rec = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False } - binds = flattenSCC bind_scc - binder_names = collectHsBindBinders (listToBag binds) + binder_names = collectHsBindBinders binds + bind_list = bagToList binds - loc = getLoc (head binds) + loc = getLoc (head bind_list) -- TODO: location a bit awkward, but the mbinds have been -- dependency analysed and may no longer be adjacent in -- SET UP THE MAIN RECOVERY; take advantage of any type sigs setSrcSpan loc $ - recoverM (recoveryCode binder_names sig_fn) $ do + recoverM (recoveryCode binder_names) $ do { traceTc (ptext SLIT("------------------------------------------------")) ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) - <- getLIE (tcMonoBinds binds sig_fn non_rec) + <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) -- CHECK FOR UNLIFTED BINDINGS -- These must be non-recursive etc, and are not generalised @@ -354,18 +349,18 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) ; if any isUnLiftedType zonked_mono_tys then do { -- Unlifted bindings - checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos + checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos ; extendLIEs lie_req ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, []) mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, []) - -- ToDo: prags + -- ToDo: prags for unlifted bindings ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked else do -- The normal lifted case: GENERALISE - { is_unres <- isUnRestrictedGroup binds sig_fn + { is_unres <- isUnRestrictedGroup bind_list sig_fn ; (tyvars_to_gen, dict_binds, dict_ids) <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ generalise top_lvl is_unres mono_bind_infos lie_req @@ -385,8 +380,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; zonked_poly_ids <- mappM zonkId poly_ids - ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds), - map idType zonked_poly_ids)) + ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids)) ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' dict_ids exports @@ -400,16 +394,24 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo -> TcM ([TyVar], Id, Id, [Prag]) mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) - = do { prags <- tcPrags poly_id (prag_fn poly_name) - ; return (tvs, poly_id, mono_id, prags) } - where - (tvs, poly_id) = case mb_sig of - Just sig -> (sig_tvs sig, sig_id sig) - Nothing -> (inferred_tvs, mkLocalId poly_name poly_ty) - where - poly_ty = mkForAllTys inferred_tvs - $ mkFunTys dict_tys - $ idType mono_id + = case mb_sig of + Nothing -> do { prags <- tcPrags poly_id (prag_fn poly_name) + ; return (inferred_tvs, poly_id, mono_id, prags) } + where + poly_id = mkLocalId poly_name poly_ty + poly_ty = mkForAllTys inferred_tvs + $ mkFunTys dict_tys + $ idType mono_id + + Just sig -> do { let poly_id = sig_id sig + ; prags <- tcPrags poly_id (prag_fn poly_name) + ; sig_tys <- zonkTcTyVars (sig_tvs sig) + ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys + ; return (sig_tvs', poly_id, mono_id, prags) } + -- We zonk the sig_tvs here so that the export triple + -- always has zonked type variables; + -- a convenient invariant + ------------------------ type TcPragFun = Name -> [LSig Name] @@ -431,32 +433,36 @@ tcPrags poly_id prags = mapM tc_prag prags pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty -tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty -tcPrag poly_id (InlineSig inl _ act) = return (InlinePrag inl act) +tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl +tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec +tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) -tcSpecPrag :: TcId -> LHsType Name -> TcM Prag -tcSpecPrag poly_id hs_ty +tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag +tcSpecPrag poly_id hs_ty inl = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty - ; (co_fn, lie) <- getLIE (tcSub spec_ty (idType poly_id)) + ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) ; extendLIEs lie ; let const_dicts = map instToId lie - ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) } + ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode binder_names sig_fn +recoveryCode binder_names = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names ; return ([], poly_ids) } where - forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - poly_ids = map mk_dummy binder_names - mk_dummy name = case sig_fn name of - Just sig -> sig_id sig -- Signature - Nothing -> mkLocalId name forall_a_a -- No signature + mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name + ; case mb_id of + Just id -> return id -- Had signature, was in envt + Nothing -> return (mkLocalId name forall_a_a) } -- No signature + +forall_a_a :: TcType +forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) + -- Check that non-overloaded unlifted bindings are -- a) non-recursive, @@ -465,10 +471,10 @@ recoveryCode binder_names sig_fn checkUnliftedBinds :: TopLevelFlag -> RecFlag -> LHsBinds TcId -> [MonoBindInfo] -> TcM () -checkUnliftedBinds top_lvl is_rec mbind infos +checkUnliftedBinds top_lvl rec_group mbind infos = do { checkTc (isNotTopLevel top_lvl) (unliftedBindErr "Top-level" mbind) - ; checkTc (isNonRec is_rec) + ; checkTc (isNonRec rec_group) (unliftedBindErr "Recursive" mbind) ; checkTc (isSingletonBag mbind) (unliftedBindErr "Multiple" mbind) @@ -492,13 +498,15 @@ The signatures have been dealt with already. \begin{code} tcMonoBinds :: [LHsBind Name] -> TcSigFun - -> Bool -- True <=> either the binders are not mentioned - -- in their RHSs or they have type sigs + -> RecFlag -- True <=> 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 -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)] +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] sig_fn -- Single function binding, - True -- binder isn't mentioned in RHS, + NonRecursive -- binder isn't mentioned in RHS, | Nothing <- sig_fn name -- ...with no type signature = -- In this very special case we infer the type of the -- right hand side first (it may have a higher-rank type) @@ -506,7 +514,7 @@ tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)] -- e.g. f = \(x::forall a. a->a) -> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches) + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) -- Check for an unboxed tuple type -- f = (# True, False #) @@ -519,31 +527,50 @@ tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)] ; mono_name <- newLocalName name ; let mono_id = mkLocalId mono_name zonked_rhs_ty - ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches' fvs)), + ; 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 })), [(name, Nothing, mono_id)]) } +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + sig_fn -- Single function binding + non_rec + | Just sig <- sig_fn name -- ...with a type signature + = -- When we have a single function binding, with a type signature + -- we can (a) use genuine, rigid skolem constants for the type variables + -- (b) bring (rigid) scoped type variables into scope + setSrcSpan b_loc $ + do { tc_sig <- tcInstSig True sig + ; mono_name <- newLocalName name + ; let mono_ty = sig_tau tc_sig + mono_id = mkLocalId mono_name mono_ty + rhs_tvs = [ (name, mkTyVarTy tv) + | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] + + ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ + tcMatchesFun mono_name matches mono_ty + + ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, + fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn } + ; return (unitBag (L b_loc fun_bind'), + [(name, Just tc_sig, mono_id)]) } + tcMonoBinds binds sig_fn non_rec = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds - -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs - -- For (a) it's ok to bring them all into scope at once, even - -- though each type sig should scope only over its own RHS, - -- because the renamer has sorted all that out. + -- Bring the monomorphic Ids, into scope for the RHSs ; let mono_info = getMonoBindInfo tc_binds - rhs_tvs = [ (name, mkTyVarTy tv) - | (_, Just sig, _) <- mono_info, - (name, tv) <- sig_scoped sig `zip` sig_tvs sig ] - rhs_id_env = map mk mono_info -- A binding for each term variable + rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] + -- A monomorphic binding for each term variable that lacks + -- a type sig. (Ones with a sig are already in scope.) - ; binds' <- tcExtendTyVarEnv2 rhs_tvs $ - tcExtendIdEnv2 rhs_id_env $ + ; binds' <- tcExtendIdEnv2 rhs_id_env $ traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_` mapM (wrapLocM tcRhs) tc_binds ; return (listToBag binds', mono_info) } - where - mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one - mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version ------------------------ -- tcLhs typechecks the LHS of the bindings, to construct the environment in which @@ -576,35 +603,40 @@ getMonoType :: MonoBindInfo -> TcTauType getMonoType (_,_,mono_id) = idType mono_id tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind -tcLhs sig_fn (FunBind (L nm_loc name) inf matches _) - = do { let mb_sig = sig_fn name +tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) + = do { mb_sig <- tcInstSig_maybe (sig_fn name) ; mono_name <- newLocalName name ; mono_ty <- mk_mono_ty mb_sig ; let mono_id = mkLocalId mono_name mono_ty ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) } where mk_mono_ty (Just sig) = return (sig_tau sig) - mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind + mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind -tcLhs sig_fn bind@(PatBind pat grhss _ _) - = do { let tc_pat exp_ty = tcPat (LetPat sig_fn) pat exp_ty lookup_infos - ; ((pat', ex_tvs, infos), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) - (tcInfer tc_pat) +tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) + = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names - -- Don't know how to deal with pattern-bound existentials yet - ; checkTc (null ex_tvs) (existentialExplode bind) + ; let nm_sig_prs = names `zip` mb_sigs + tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs] + sig_tau_fn = lookupNameEnv tau_sig_env + + tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ -> + mapM lookup_info nm_sig_prs + -- The unitTy is a bit bogus; it's the "result type" for lookup_info. + + -- After typechecking the pattern, look up the binder + -- names, which the pattern has brought into scope. + lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo + lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name + ; return (name, mb_sig, mono_id) } + + ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer tc_pat ; return (TcPatBind infos pat' grhss pat_ty) } where names = collectPatBinders pat - -- After typechecking the pattern, look up the binder - -- names, which the pattern has brought into scope. - lookup_infos :: TcM [MonoBindInfo] - lookup_infos = do { mono_ids <- tcLookupLocalIds names - ; return [ (name, sig_fn name, mono_id) - | (name, mono_id) <- names `zip` mono_ids] } tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible @@ -612,14 +644,16 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) - = do { matches' <- tcMatchesFun (idName mono_id) matches - (Check (idType mono_id)) - ; return (FunBind fun' inf matches' placeHolderNames) } + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches + (idType mono_id) + ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn }) } tcRhs bind@(TcPatBind _ pat' grhss pat_ty) = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss (Check pat_ty) - ; return (PatBind pat' grhss' pat_ty placeHolderNames) } + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, + bind_fvs = placeHolderNames }) } --------------------- @@ -680,26 +714,30 @@ generalise top_lvl is_unrestricted mono_infos lie_req where bndrs = bndrNames mono_infos sigs = [sig | (_, Just sig, _) <- mono_infos] - tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos + tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos + -- NB: exactTyVarsOfType; see Note [Silly type synonym] + -- near defn of TcType.exactTyVarsOfType is_mono_sig sig = null (sig_theta sig) doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, - sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id - = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc + sig_theta = theta, sig_loc = loc }) mono_id + = Method mono_id poly_id (mkTyVarTys tvs) theta loc +\end{code} +unifyCtxts checks that all the signature contexts are the same +The type signatures on a mutually-recursive group of definitions +must all have the same context (or none). --- Check that all the signature contexts are the same --- The type signatures on a mutually-recursive group of definitions --- must all have the same context (or none). --- --- The trick here is that all the signatures should have the same --- context, and we want to share type variables for that context, so that --- all the right hand sides agree a common vocabulary for their type --- constraints --- --- We unify them because, with polymorphic recursion, their types --- might not otherwise be related. This is a rather subtle issue. +The trick here is that all the signatures should have the same +context, and we want to share type variables for that context, so that +all the right hand sides agree a common vocabulary for their type +constraints + +We unify them because, with polymorphic recursion, their types +might not otherwise be related. This is a rather subtle issue. + +\begin{code} unifyCtxts :: [TcSigInfo] -> TcM [Inst] unifyCtxts (sig1 : sigs) -- Argument is always non-empty = do { mapM unify_ctxt sigs @@ -749,15 +787,10 @@ checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] -- (b) been unified with each other (all distinct) checkDistinctTyVars sig_tvs - = do { zonked_tvs <- mapM zonk_one sig_tvs + = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) ; return zonked_tvs } where - zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv - ; return (tcGetTyVar "checkDistinctTyVars" ty) } - -- 'ty' is bound to be a type variable, because SigSkolTvs - -- can only be unified with type variables - check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar) -- The TyVarEnv maps each zonked type variable back to its -- corresponding user-written signature type variable @@ -768,12 +801,14 @@ checkDistinctTyVars sig_tvs Nothing -> return (extendVarEnv acc zonked_tv sig_tv) bomb_out sig_tv1 sig_tv2 - = failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) - <+> ptext SLIT("is unified with another quantified type variable") - <+> quotes (ppr tidy_tv2)) + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1 + (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 + msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) + <+> ptext SLIT("is unified with another quantified type variable") + <+> quotes (ppr tidy_tv2) + ; failWithTcM (env2, msg) } where - (env1, tidy_tv1) = tidyOpenTyVar emptyTidyEnv sig_tv1 - (_env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 \end{code} @@ -839,13 +874,6 @@ If we don't take care, after typechecking we get Notice the the stupid construction of (f a d), which is of course identical to the function we're executing. In this case, the polymorphic recursion isn't being used (but that's a very common case). -We'd prefer - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm - This can lead to a massive space leak, from the following top-level defn (post-typechecking) @@ -864,6 +892,10 @@ up with a chain of identical values all hung onto by the CAF ff. in \ys. ...f'... Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + Solution: when typechecking the RHSs we always have in hand the *monomorphic* Ids for each binding. So we just need to make sure that if (Method f a d) shows up in the constraints emerging from (...f...) @@ -871,6 +903,14 @@ we just use the monomorphic Id. We achieve this by adding monomorphic Ids to the "givens" when simplifying constraints. That's what the "lies_avail" is doing. +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm + + %************************************************************************ %* * @@ -880,27 +920,124 @@ is doing. Type signatures are tricky. See Note [Signature skolems] in TcType +@tcSigs@ checks the signatures for validity, and returns a list of +{\em freshly-instantiated} signatures. That is, the types are already +split up, and have fresh type variables installed. All non-type-signature +"RenamedSigs" are ignored. + +The @TcSigInfo@ contains @TcTypes@ because they are unified with +the variable's type, and after that checked to see whether they've +been instantiated. + \begin{code} -tcTySigs :: [LSig Name] -> TcM [TcSigInfo] -tcTySigs sigs = mappM tcTySig (filter isVanillaLSig sigs) +type TcSigFun = Name -> Maybe (LSig Name) + +mkSigFun :: [LSig Name] -> TcSigFun +-- Search for a particular type signature +-- Precondition: the sigs are all type sigs +-- Precondition: no duplicates +mkSigFun sigs = lookupNameEnv env + where + env = mkNameEnv [(fromJust (sigName sig), sig) | sig <- sigs] + +--------------- +data TcSigInfo + = TcSigInfo { + sig_id :: TcId, -- *Polymorphic* binder for this value... + + sig_scoped :: [Name], -- Names for any scoped type variables + -- Invariant: correspond 1-1 with an initial + -- segment of sig_tvs (see Note [Scoped]) + + sig_tvs :: [TcTyVar], -- Instantiated type variables + -- See Note [Instantiate sig] + + sig_theta :: TcThetaType, -- Instantiated theta + sig_tau :: TcTauType, -- Instantiated tau + sig_loc :: InstLoc -- The location of the signature + } + +-- Note [Scoped] +-- There may be more instantiated type variables than scoped +-- ones. For example: +-- type T a = forall b. b -> (a,b) +-- f :: forall c. T c +-- Here, the signature for f will have one scoped type variable, c, +-- but two instantiated type variables, c' and b'. +-- +-- We assume that the scoped ones are at the *front* of sig_tvs, +-- and remember the names from the original HsForAllTy in sig_scoped + +-- Note [Instantiate sig] +-- It's vital to instantiate a type signature with fresh variable. +-- For example: +-- type S = forall a. a->a +-- f,g :: S +-- f = ... +-- g = ... +-- Here, we must use distinct type variables when checking f,g's right hand sides. +-- (Instantiation is only necessary because of type synonyms. Otherwise, +-- it's all cool; each signature has distinct type variables from the renamer.) + +instance Outputable TcSigInfo where + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) + = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau +\end{code} -tcTySig :: LSig Name -> TcM TcSigInfo -tcTySig (L span (Sig (L _ name) ty)) +\begin{code} +tcTySig :: LSig Name -> TcM TcId +tcTySig (L span (TypeSig (L _ name) ty)) = setSrcSpan span $ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty - ; loc <- getInstLoc (SigOrigin (SigSkol name)) - ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty, + ; return (mkLocalId name sigma_ty) } + +------------------- +tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo) +-- Instantiate with *meta* type variables; +-- this signature is part of a multi-signature group +tcInstSig_maybe Nothing = return Nothing +tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig + ; return (Just tc_sig) } + +tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo +-- Instantiate the signature, with either skolems or meta-type variables +-- depending on the use_skols boolean +-- +-- We always instantiate with freshs uniques, +-- although we keep the same print-name +-- +-- type T = forall a. [a] -> [a] +-- f :: T; +-- f = g where { g :: T; g = } +-- +-- We must not use the same 'a' from the defn of T at both places!! + +tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) + = setSrcSpan loc $ + do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into + -- scope when starting the binding group + ; let skol_info = SigSkol (FunSigCtxt name) + inst_tyvars | use_skols = tcInstSkolTyVars skol_info + | otherwise = tcInstSigTyVars skol_info + ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) + ; loc <- getInstLoc (SigOrigin skol_info) + ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, sig_scoped = scoped_names, sig_loc = loc }) } + -- Note that the scoped_names and the sig_tvs will have + -- different Names. That's quite ok; when we bring the + -- scoped_names into scope, we just bind them to the sig_tvs where -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) - scoped_names = case ty of - L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs - other -> [] + -- We also only have scoped type variables when we are instantiating + -- with true skolems + scoped_names = case (use_skols, hs_ty) of + (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs + other -> [] +------------------- isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool isUnRestrictedGroup binds sig_fn = do { mono_restriction <- doptM Opt_MonomorphismRestriction @@ -909,10 +1046,10 @@ isUnRestrictedGroup binds sig_fn all_unrestricted = all (unrestricted . unLoc) binds has_sig n = isJust (sig_fn n) - unrestricted (PatBind other _ _ _) = False - unrestricted (VarBind v _) = has_sig v - unrestricted (FunBind v _ matches _) = unrestricted_match matches - || has_sig (unLoc v) + unrestricted (PatBind {}) = False + unrestricted (VarBind { var_id = v }) = has_sig v + unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches + || has_sig (unLoc v) unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False -- No args => like a pattern binding @@ -960,13 +1097,6 @@ unboxedTupleErr name ty 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- -existentialExplode mbinds - = hang (vcat [text "My brain just exploded.", - text "I can't handle pattern bindings for existentially-quantified constructors.", - text "In the binding group"]) - 4 (ppr mbinds) - ------------------------------------------------ restrictedBindCtxtErr binder_names = hang (ptext SLIT("Illegal overloaded type signature(s)")) 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,