X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=cffcb9cfb939d42e64bb3a40c9b9628b44f703b5;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=a4d163a5141e79eba99053f4437a994989b4c637;hpb=81d9bd68cd5bc763ef7d675d5263f210e7dca9c0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a4d163a..cffcb9c 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(..), pprLHsBinds, - collectHsBindBinders, collectPatBinders, pprPatBind + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, + collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind ) -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 ) @@ -60,10 +62,10 @@ import SrcLoc ( Located(..), unLoc, getLoc ) import Bag import ErrUtils ( Message ) import Digraph ( SCC(..), stronglyConnComp ) -import Maybes ( fromJust, isJust, isNothing, orElse, catMaybes ) +import Maybes ( expectJust, isJust, isNothing, orElse ) import Util ( singleton ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - RecFlag(..), isNonRec ) + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) import Outputable \end{code} @@ -117,7 +119,7 @@ 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,9 +153,9 @@ 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')) ------------------------ @@ -161,23 +163,20 @@ tcValBinds :: TopLevelFlag -> HsValBinds Name -> TcM thing -> TcM (HsValBinds TcId, thing) +tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside + = pprPanic "tcValBinds" (ppr binds) + tcValBinds top_lvl (ValBindsOut 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 { -- Typecheck the signature ; let { prag_fn = mkPragFun sigs - ; sig_fn = lookupSig tc_ty_sigs - ; sig_ids = map sig_id tc_ty_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 binds thing_inside @@ -220,7 +219,7 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, 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 @@ -252,10 +251,8 @@ mkEdges :: TcSigFun -> LHsBinds Name 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, [key | n <- nameSetToList (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] where @@ -264,17 +261,13 @@ mkEdges sig_fn binds keyd_binds = bagToList 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] +bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat +bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] ------------------------ tcPolyBinds :: TopLevelFlag @@ -339,7 +332,7 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds 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) @@ -352,14 +345,14 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds -- These must be non-recursive etc, and are not generalised -- They desugar to a case expression in the end ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) - ; if any isUnLiftedType zonked_mono_tys then - do { -- Unlifted bindings - checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos - ; extendLIEs lie_req - ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys + ; is_strict <- checkStrictBinds top_lvl rec_group binds' + zonked_mono_tys mono_bind_infos + ; if is_strict then + do { 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 @@ -385,8 +378,7 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds ; 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 +392,24 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds 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] @@ -417,7 +417,8 @@ type TcPragFun = Name -> [LSig Name] mkPragFun :: [LSig Name] -> TcPragFun mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] where - prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig] + prs = [(expectJust "mkPragFun" (sigName sig), sig) + | sig <- sigs, isPragLSig sig] env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p @@ -431,52 +432,76 @@ 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, -- b) not top level, -- c) not a multiple-binding group (more or less implied by (a)) -checkUnliftedBinds :: TopLevelFlag -> RecFlag - -> LHsBinds TcId -> [MonoBindInfo] -> TcM () -checkUnliftedBinds top_lvl rec_group mbind infos +checkStrictBinds :: TopLevelFlag -> RecFlag + -> LHsBinds TcId -> [TcType] -> [MonoBindInfo] + -> TcM Bool +checkStrictBinds top_lvl rec_group mbind mono_tys infos + | unlifted || bang_pat = do { checkTc (isNotTopLevel top_lvl) - (unliftedBindErr "Top-level" mbind) + (strictBindErr "Top-level" unlifted mbind) ; checkTc (isNonRec rec_group) - (unliftedBindErr "Recursive" mbind) + (strictBindErr "Recursive" unlifted mbind) ; checkTc (isSingletonBag mbind) - (unliftedBindErr "Multiple" mbind) - ; mapM_ check_sig infos } + (strictBindErr "Multiple" unlifted mbind) + ; mapM_ check_sig infos + ; return True } + | otherwise + = return False where + unlifted = any isUnLiftedType mono_tys + bang_pat = anyBag (isBangHsBind . unLoc) mbind check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig)) - (badUnliftedSig sig) + (badStrictSig unlifted sig) check_sig other = return () + +strictBindErr flavour unlifted mbind + = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind) + where + msg | unlifted = ptext SLIT("bindings for unlifted types") + | otherwise = ptext SLIT("bang-pattern bindings") + +badStrictSig unlifted sig + = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) + 4 (ppr sig) + where + msg | unlifted = ptext SLIT("an unlifted binding") + | otherwise = ptext SLIT("a bang-pattern binding") \end{code} @@ -492,12 +517,13 @@ The signatures have been dealt with already. \begin{code} tcMonoBinds :: [LHsBind Name] -> TcSigFun - -> 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 + -> 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 -> 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, NonRecursive -- binder isn't mentioned in RHS, | Nothing <- sig_fn name -- ...with no type signature @@ -507,7 +533,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 #) @@ -520,31 +546,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 @@ -577,35 +622,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_lhs = pat, pat_rhs = grhss }) + = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names + + ; 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 -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) + 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. - -- Don't know how to deal with pattern-bound existentials yet - ; checkTc (null ex_tvs) (existentialExplode bind) + -- 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 @@ -613,14 +663,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 }) } --------------------- @@ -681,26 +733,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 @@ -750,15 +806,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 @@ -769,12 +820,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} @@ -840,13 +893,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) @@ -865,6 +911,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...) @@ -872,6 +922,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 + + %************************************************************************ %* * @@ -881,29 +939,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 = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs) - ; return (catMaybes mb_sigs) } - -tcTySig :: LSig Name -> TcM (Maybe TcSigInfo) -tcTySig (L span (Sig (L _ name) ty)) - = recoverM (return Nothing) $ - setSrcSpan span $ +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 [(expectJust "mkSigFun" (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} + +\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 (Just (TcSigInfo { sig_id = mkLocalId name sigma_ty, - sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = scoped_names, sig_loc = loc })) } + ; 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 @@ -912,10 +1065,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 @@ -949,27 +1102,11 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- -unliftedBindErr flavour mbind - = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) - 4 (ppr mbind) - -badUnliftedSig sig - = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding")) - 4 (ppr sig) - ------------------------------------------------ unboxedTupleErr name ty = hang (ptext SLIT("Illegal binding of unboxed tuple")) 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,