X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=c765699b9ec4df932ce3a09d4aa90fc1f23df451;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=4f81c0dc7ad0472a9147bea6db3ff9979989f826;hpb=20d387c481324aed48e8469d3fbf0695b3b2e365;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 4f81c0d..c765699 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,63 +4,68 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, - tcSpecSigs, tcBindWithSigs ) where +module TcBinds ( tcLocalBinds, tcTopBinds, + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), + badBootDeclErr ) where #include "HsVersions.h" -import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcExpr ) - -import CmdLineOpts ( opt_NoMonomorphismRestriction ) -import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..), - Match(..), collectMonoBinders, andMonoBinds - ) -import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) - -import TcMonad -import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), - newDicts, tyVarsOfInst, instToId, - getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps +import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) + +import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) ) +import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), + HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), + LSig, Match(..), IPBind(..), Prag(..), + HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, + isVanillaLSig, sigName, placeHolderNames, isPragLSig, + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, + collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind ) -import TcEnv ( tcExtendLocalValEnv, - newSpecPragmaId, newLocalId, - tcLookupTyCon, - tcGetGlobalTyVars, tcExtendGlobalTyVars - ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) -import TcImprove ( tcImprove ) -import TcMonoType ( tcHsSigType, checkSigTyVars, - TcSigInfo(..), tcTySig, maybeSig, sigCtxt - ) -import TcPat ( tcPat ) +import TcHsSyn ( zonkId ) + +import TcRnMonad +import Inst ( newDictsAtLoc, newIPDict, instToId ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, + pprBinders, tcLookupLocalId_maybe, tcLookupId, + tcGetGlobalTyVars ) +import TcUnify ( tcInfer, tcSubExp, unifyTheta, + bleatEscapedTvs, sigCtxt ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, + tcSimplifyRestricted, tcSimplifyIPs ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( TcThetaType, newTyVarTy, newTyVar, - zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar - ) -import TcUnify ( unifyTauTy, unifyTauTyLists ) - -import CoreFVs ( idFreeTyVars ) -import Id ( mkVanillaId, setInlinePragma ) -import Var ( idType, idName ) -import IdInfo ( InlinePragInfo(..) ) -import Name ( Name, getOccName, getSrcLoc ) +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, exactTyVarsOfType, + mkForAllTy, isUnLiftedType, tcGetTyVar, + mkTyVarTys, tidyOpenTyVar ) +import Kind ( argTypeKind ) +import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) +import TysWiredIn ( unitTy ) +import TysPrim ( alphaTyVar ) +import Id ( Id, mkLocalId, mkVanillaGlobal ) +import IdInfo ( vanillaIdInfo ) +import Var ( TyVar, idType, idName ) +import Name ( Name ) import NameSet -import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp, - mkForAllTys, mkFunTys, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind - ) -import FunDeps ( oclose ) -import Var ( tyVarKind ) +import NameEnv import VarSet +import SrcLoc ( Located(..), unLoc, getLoc ) import Bag -import Util ( isIn ) -import Maybes ( maybeToBool ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) -import FiniteMap ( listToFM, lookupFM ) -import PrelNames ( ioTyConName, mainKey, hasKey ) +import ErrUtils ( Message ) +import Digraph ( SCC(..), stronglyConnComp ) +import Maybes ( fromJust, isJust, isNothing, orElse ) +import Util ( singleton ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) import Outputable \end{code} @@ -97,413 +102,735 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE) +tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) + -- 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 - = tc_binds_and_then TopLevel glue binds $ - tcGetEnv `thenNF_Tc` \ env -> - returnTc ((EmptyMonoBinds, env), emptyLIE) + = 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 + +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 (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr + ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } + where + 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 +tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) + +badBootDeclErr :: Message +badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") + +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) + +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } + +tcLocalBinds (HsValBinds binds) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside + ; return (HsValBinds binds', thing) } + +tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside + = do { (thing, lie) <- getLIE thing_inside + ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + ; dict_binds <- tcSimplifyIPs avail_ips lie + ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } where - glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing) + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind (IPBind ip expr) + = newFlexiTyVarTy argTypeKind `thenM` \ ty -> + newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> + tcMonoExpr expr ty `thenM` \ expr' -> + returnM (ip_inst, (IPBind ip' expr')) + +------------------------ +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 + = 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 poly_ids $ + tc_val_binds top_lvl sig_fn prag_fn + binds thing_inside + + ; return (ValBindsOut binds' sigs, thing) } + +------------------------ +tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun + -> [(RecFlag, LHsBinds Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time + +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 (group : groups) thing_inside + = do { (group', (groups', thing)) + <- 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 + -> (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 (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 NonRecursive + sig_fn prag_fn binds thing_inside + ; return ([(NonRecursive, b) | b <- binds], thing) } + +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 + -- any references to variables with type signatures. + -- + -- Then we bring into scope all the variables with type signatures + do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) + ; gla_exts <- doptM Opt_GlasgowExts + ; (binds,thing) <- if gla_exts + then go new_sccs + 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 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) } -tcBindsAndThen - :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator - -> RenamedHsBinds - -> TcM (thing, LIE) - -> TcM (thing, LIE) + go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) + go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) -tcBindsAndThen = tc_binds_and_then NotTopLevel + tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds -tc_binds_and_then top_lvl combiner EmptyBinds do_next - = do_next -tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next - = do_next +------------------------ +mkEdges :: TcSigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] -tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next - = tc_binds_and_then top_lvl combiner b1 $ - tc_binds_and_then top_lvl combiner b2 $ - do_next +type BKey = Int -- Just number off the bindings -tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next - = -- TYPECHECK THE SIGNATURES - mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs -> - - tcBindWithSigs top_lvl bind tc_ty_sigs - sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) -> - - -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $ +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 + -> LHsBinds Name + -> TcM thing + -> TcM ([LHsBinds TcId], thing) + +-- Typechecks a single bunch of bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Deals with the bindInstsOfLocalFuns thing too +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. + +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) + ; ((binds1, poly_ids, thing), lie) <- getLIE $ + 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) } + + ; if isTopLevel top_lvl + then -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, + -- and quite a bit faster too + do { extendLIEs lie; return (binds1, thing) } + + else do -- Nested case + { lie_binds <- bindInstsOfLocalFuns lie poly_ids + ; return (binds1 ++ [lie_binds], thing) }} + +------------------------ +tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds + -> RecFlag -> RecFlag + -> TcSigFun -> TcPragFun + -> LHsBinds Name + -> TcM ([LHsBinds TcId], [TcId]) +-- Typechecks the bindings themselves +-- Knows nothing about the scope of the bindings + +tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds + = let + binder_names = collectHsBindBinders binds + bind_list = bagToList 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) $ do + + { traceTc (ptext SLIT("------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + + -- TYPECHECK THE BINDINGS + ; ((binds', mono_bind_infos), lie_req) + <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + + -- CHECK FOR UNLIFTED BINDINGS + -- 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) + ; 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 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 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 + + -- FINALISE THE QUANTIFIED TYPE VARIABLES + -- The quantified type variables often include meta type variables + -- we want to freeze them into ordinary type variables, and + -- default their kind (e.g. from OpenTypeKind to TypeKind) + ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen + + -- BUILD THE POLYMORPHIC RESULT IDs + ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + mono_bind_infos + + -- ZONK THE poly_ids, because they are used to extend the type + -- environment; see the invariant on TcEnv.tcExtendIdEnv + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] + ; zonked_poly_ids <- mappM zonkId 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 + (dict_binds `unionBags` binds') + + ; return ([unitBag abs_bind], zonked_poly_ids) + } } + + +-------------- +mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [Prag]) +mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, 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] + +mkPragFun :: [LSig Name] -> TcPragFun +mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] + where + prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig] + env = foldl add emptyNameEnv prs + add env (n,p) = extendNameEnv_Acc (:) singleton env n p + +tcPrags :: Id -> [LSig Name] -> TcM [Prag] +tcPrags poly_id prags = mapM tc_prag prags + where + tc_prag (L loc prag) = setSrcSpan loc $ + addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag + +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 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 -> InlineSpec -> TcM Prag +tcSpecPrag poly_id hs_ty inl + = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty + ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) + ; extendLIEs lie + ; let const_dicts = map instToId lie + ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) -> - - -- Now do whatever happens next, in the augmented envt - do_next `thenTc` \ (thing, thing_lie) -> - - -- Create specialisations of functions bound here - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - case (top_lvl, is_rec) of - - -- For the top level don't bother will all this bindInstsOfLocalFuns stuff - -- All the top level things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - (TopLevel, _) - -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing, - thing_lie `plusLIE` prag_lie `plusLIE` poly_lie) - - (NotTopLevel, NonRecursive) - -> bindInstsOfLocalFuns - (thing_lie `plusLIE` prag_lie) - poly_ids `thenTc` \ (thing_lie', lie_binds) -> - - returnTc ( - combiner NonRecursive poly_binds $ - combiner NonRecursive prag_binds $ - combiner Recursive lie_binds $ - -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns - -- aren't guaranteed in dependency order (though we could change - -- that); hence the Recursive marker. - thing, - - thing_lie' `plusLIE` poly_lie - ) - - (NotTopLevel, Recursive) - -> bindInstsOfLocalFuns - (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie) - poly_ids `thenTc` \ (final_lie, lie_binds) -> - - returnTc ( - combiner Recursive ( - poly_binds `andMonoBinds` - lie_binds `andMonoBinds` - prag_binds) thing, - final_lie - ) -\end{code} +-------------- +-- 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 + = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return ([], poly_ids) } + where + 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)) + +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) + (strictBindErr "Top-level" unlifted mbind) + ; checkTc (isNonRec rec_group) + (strictBindErr "Recursive" unlifted mbind) + ; checkTc (isSingletonBag mbind) + (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)) + (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") -An aside. The original version of @tcBindsAndThen@ which lacks a -combiner function, appears below. Though it is perfectly well -behaved, it cannot be typed by Haskell, because the recursive call is -at a different type to the definition itself. There aren't too many -examples of this, which is why I thought it worth preserving! [SLPJ] - -\begin{pseudocode} -% tcBindsAndThen -% :: RenamedHsBinds -% -> TcM (thing, LIE, thing_ty)) -% -> TcM ((TcHsBinds, thing), LIE, thing_ty) -% -% tcBindsAndThen EmptyBinds do_next -% = do_next `thenTc` \ (thing, lie, thing_ty) -> -% returnTc ((EmptyBinds, thing), lie, thing_ty) -% -% tcBindsAndThen (ThenBinds binds1 binds2) do_next -% = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next) -% `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) -> -% -% returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty) -% -% tcBindsAndThen (MonoBind bind sigs is_rec) do_next -% = tcBindAndThen bind sigs do_next -\end{pseudocode} +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} %************************************************************************ %* * -\subsection{tcBindWithSigs} +\subsection{tcMonoBind} %* * %************************************************************************ -@tcBindWithSigs@ deals with a single binding group. It does generalisation, -so all the clever stuff is in here. +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. -* binder_names and mbind must define the same set of Names +\begin{code} +tcMonoBinds :: [LHsBind Name] + -> TcSigFun + -> 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 { 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 + = -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + + -- Check for an unboxed tuple type + -- f = (# True, False #) + -- Zonk first just in case it's hidden inside a meta type variable + -- (This shows up as a (more obscure) kind error + -- in the 'otherwise' case of tcMonoBinds.) + ; zonked_rhs_ty <- zonkTcType rhs_ty + ; checkTc (not (isUnboxedTupleType zonked_rhs_ty)) + (unboxedTupleErr name zonked_rhs_ty) + + ; mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name zonked_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 })), + [(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 the monomorphic Ids, into scope for the RHSs + ; let mono_info = getMonoBindInfo tc_binds + 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' <- 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) } + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- 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) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +bndrNames :: [MonoBindInfo] -> [Name] +bndrNames mbi = [n | (n,_,_) <- mbi] + +getMonoType :: MonoBindInfo -> TcTauType +getMonoType (_,_,mono_id) = idType mono_id + +tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind +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 = newFlexiTyVarTy argTypeKind -* The Names in tc_ty_sigs must be a subset of binder_names +tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) + = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names -* The Ids in tc_ty_sigs don't necessarily have to have the same name - as the Name in the tc_ty_sig + ; 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 -\begin{code} -tcBindWithSigs - :: TopLevelFlag - -> RenamedMonoBinds - -> [TcSigInfo] - -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs - -> RecFlag - -> TcM (TcMonoBinds, LIE, [TcId]) - -tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec - = recoverTc ( - -- If typechecking the binds fails, then return with each - -- signature-less binder given type (forall a.a), to minimise subsequent - -- error messages - newTyVar liftedTypeKind `thenNF_Tc` \ alpha_tv -> - let - forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - binder_names = collectMonoBinders mbind - poly_ids = map mk_dummy binder_names - mk_dummy name = case maybeSig tc_ty_sigs name of - Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature - Nothing -> mkVanillaId name forall_a_a -- No signature - in - returnTc (EmptyMonoBinds, emptyLIE, poly_ids) - ) $ - - -- TYPECHECK THE BINDINGS - tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> - - -- CHECK THAT THE SIGNATURES MATCH - -- (must do this before getTyVarsToGen) - checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta -> - - -- IMPROVE the LIE - -- Force any unifications dictated by functional dependencies. - -- Because unification may happen, it's important that this step - -- come before: - -- - computing vars over which to quantify - -- - zonking the generalized type vars - let lie_avail = case maybe_sig_theta of - Nothing -> emptyLIE - Just (_, la) -> la - lie_avail_req = lie_avail `plusLIE` lie_req in - tcImprove lie_avail_req `thenTc_` - - -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen - -- The tyvars_not_to_gen are free in the environment, and hence - -- candidates for generalisation, but sometimes the monomorphism - -- restriction means we can't generalise them nevertheless - let - mono_id_tys = map idType mono_ids - in - getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) -> - - -- Finally, zonk the generalised type variables to real TyVars - -- This commits any unbound kind variables to lifted kind - -- I'm a little worried that such a kind variable might be - -- free in the environment, but I don't think it's possible for - -- this to happen when the type variable is not free in the envt - -- (which it isn't). SLPJ Nov 98 - mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list -> - let - real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list - -- It's important that the final list - -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully - -- zonked, *including boxity*, because they'll be included in the forall types of - -- the polymorphic Ids, and instances of these Ids will be generated from them. - -- - -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass - -- real_tyvars_to_gen - in + 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. - -- SIMPLIFY THE LIE - tcExtendGlobalTyVars tyvars_not_to_gen ( - let ips = getIPsOfLIE lie_avail_req in - if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then - -- No polymorphism, and no IPs, so no need to simplify context - returnTc (lie_req, EmptyMonoBinds, []) - else - case maybe_sig_theta of - Nothing -> - -- No signatures, so just simplify the lie - -- NB: no signatures => no polymorphic recursion, so no - -- need to use lie_avail (which will be empty anyway) - tcSimplify (text "tcBinds1" <+> ppr binder_names) - real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> - returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) - - Just (sig_theta, lie_avail) -> - -- There are signatures, and their context is sig_theta - -- Furthermore, lie_avail is an LIE containing the 'method insts' - -- for the things bound here - - zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' -> - newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) -> - -- It's important that sig_theta is zonked, because - -- dict_id is later used to form the type of the polymorphic thing, - -- and forall-types must be zonked so far as their bound variables - -- are concerned - - let - -- The "givens" is the stuff available. We get that from - -- the context of the type signature, BUT ALSO the lie_avail - -- so that polymorphic recursion works right (see comments at end of fn) - givens = dicts_sig `plusLIE` lie_avail - in - - -- Check that the needed dicts can be expressed in - -- terms of the signature ones - tcAddErrCtxt (bindSigsCtxt tysig_names) $ - tcSimplifyAndCheck - (ptext SLIT("type signature for") <+> pprQuotedList binder_names) - real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) -> - - returnTc (lie_free, dict_binds, dict_ids) - - ) `thenTc` \ (lie_free, dict_binds, dicts_bound) -> - - -- GET THE FINAL MONO_ID_TYS - zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types -> - - - -- CHECK FOR BOGUS UNPOINTED BINDINGS - (if any isUnLiftedType zonked_mono_id_types then - -- Unlifted bindings must be non-recursive, - -- not top level, and non-polymorphic - checkTc (isNotTopLevel top_lvl) - (unliftedBindErr "Top-level" mbind) `thenTc_` - checkTc (case is_rec of {Recursive -> False; NonRecursive -> True}) - (unliftedBindErr "Recursive" mbind) `thenTc_` - checkTc (null real_tyvars_to_gen_list) - (unliftedBindErr "Polymorphic" mbind) - else - returnTc () - ) `thenTc_` - - ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen_list) ) - -- The instCantBeGeneralised stuff in tcSimplify should have - -- already raised an error if we're trying to generalise an - -- unlifted tyvar (NB: unlifted tyvars are always introduced - -- along with a class constraint) and it's better done there - -- because we have more precise origin information. - -- That's why we just use an ASSERT here. - - - -- BUILD THE POLYMORPHIC RESULT IDs - mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids -> - let - exports = zipWith mk_export binder_names zonked_mono_ids - dict_tys = map idType dicts_bound - - inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs] - no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++ - [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase]) - -- "INLINE n foo" means inline foo, but not until at least phase n - -- "NOINLINE n foo" means don't inline foo until at least phase n, and even - -- then only if it is small enough etc. - -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing) - -- See comments in CoreUnfold.blackListed for the Authorised Version - - mk_export binder_name zonked_mono_id - = (tyvars, - attachNoInlinePrag no_inlines poly_id, - zonked_mono_id) - where - (tyvars, poly_id) = - case maybeSig tc_ty_sigs binder_name of - Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) -> - (sig_tyvars, sig_poly_id) - Nothing -> (real_tyvars_to_gen_list, new_poly_id) - - new_poly_id = mkVanillaId binder_name poly_ty - poly_ty = mkForAllTys real_tyvars_to_gen_list - $ mkFunTys dict_tys - $ idType (zonked_mono_id) - -- It's important to build a fully-zonked poly_ty, because - -- we'll slurp out its free type variables when extending the - -- local environment (tcExtendLocalValEnv); if it's not zonked - -- it appears to have free tyvars that aren't actually free - -- at all. - - pat_binders :: [Name] - pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds) - in - -- CHECK FOR UNLIFTED BINDERS IN PATTERN BINDINGS - mapTc (\id -> checkTc (not (idName id `elem` pat_binders - && isUnLiftedType (idType id))) - (unliftedPatBindErr id)) zonked_mono_ids - `thenTc_` - - -- BUILD RESULTS - returnTc ( - -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $ - AbsBinds real_tyvars_to_gen_list - dicts_bound - exports - inlines - (dict_binds `andMonoBinds` mbind'), - lie_free, - [poly_id | (_, poly_id, _) <- exports] - ) - where - tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs] - is_unrestricted | opt_NoMonomorphismRestriction = True - | otherwise = isUnRestrictedGroup tysig_names mbind - -justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds -justPatBindings (AndMonoBinds b1 b2) binds = - justPatBindings b1 (justPatBindings b2 binds) -justPatBindings other_bind binds = binds - -attachNoInlinePrag no_inlines bndr - = case lookupFM no_inlines (idName bndr) of - Just prag -> bndr `setInlinePragma` prag - Nothing -> bndr -\end{code} + -- 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) } -Polymorphic recursion -~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is + ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer tc_pat - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. + ; return (TcPatBind infos pat' grhss pat_ty) } + where + names = collectPatBinders pat -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - f :: Eq a => [a] -> [a] - f xs = ...f... +tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible -If we don't take care, after typechecking we get +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) + = 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 }) } - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... +tcRhs bind@(TcPatBind _ pat' grhss pat_ty) + = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, + bind_fvs = placeHolderNames }) } -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 +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest +\end{code} -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - ff :: [Int] -> [Int] - ff = f Int dEqInt +%************************************************************************ +%* * + Generalisation +%* * +%************************************************************************ -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. +\begin{code} +generalise :: TopLevelFlag -> Bool + -> [MonoBindInfo] -> [Inst] + -> TcM ([TcTyVar], TcDictBinds, [TcId]) +generalise top_lvl is_unrestricted mono_infos lie_req + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + do { checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr bndrs) + + -- Now simplify with exactly that set of tyvars + -- We have to squash those Methods + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs + tau_tvs lie_req + + -- Check that signature type variables are OK + ; final_qtvs <- checkSigsTyVars qtvs sigs + + ; return (final_qtvs, binds, []) } + + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + ; let -- The "sig_avails" is the stuff available. We get that from + -- the context of the type signature, BUT ALSO the lie_avail + -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) + local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] + sig_avails = sig_lie ++ local_meths - ff = f Int dEqInt + -- Check that the needed dicts can be + -- expressed in terms of the signature ones + ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req + + -- Check that signature type variables are OK + ; final_qtvs <- checkSigsTyVars forall_tvs sigs - = let f' = f Int dEqInt in \ys. ...f'... + ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } + where + bndrs = bndrNames mono_infos + sigs = [sig | (_, Just sig, _) <- 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_loc = loc }) mono_id + = Method mono_id poly_id (mkTyVarTys tvs) theta loc +\end{code} - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... +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). -Etc. -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...) -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. +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 + ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) } + where + theta1 = sig_theta sig1 + unify_ctxt :: TcSigInfo -> TcM () + unify_ctxt sig@(TcSigInfo { sig_theta = theta }) + = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + addErrCtxt (sigContextsCtxt sig1 sig) $ + unifyTheta theta1 theta + +checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] +checkSigsTyVars qtvs sigs + = do { gbl_tvs <- tcGetGlobalTyVars + ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs + + ; let -- Sigh. Make sure that all the tyvars in the type sigs + -- appear in the returned ty var list, which is what we are + -- going to generalise over. Reason: we occasionally get + -- silly types like + -- type T a = () -> () + -- f :: T a + -- f () = () + -- Here, 'a' won't appear in qtvs, so we have to add it + sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s + all_tvs = varSetElems (extendVarSetList sig_tvs qtvs) + ; returnM all_tvs } + where + check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, + sig_theta = theta, sig_tau = tau}) + = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ + addErrCtxtM (sigCtxt id tvs theta tau) $ + do { tvs' <- checkDistinctTyVars tvs + ; ifM (any (`elemVarSet` gbl_tvs) tvs') + (bleatEscapedTvs gbl_tvs tvs tvs') + ; return tvs' } + +checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] +-- (checkDistinctTyVars tvs) checks that the tvs from one type signature +-- are still all type variables, and all distinct from each other. +-- It returns a zonked set of type variables. +-- For example, if the type sig is +-- f :: forall a b. a -> b -> b +-- we want to check that 'a' and 'b' haven't +-- (a) been unified with a non-tyvar type +-- (b) been unified with each other (all distinct) + +checkDistinctTyVars sig_tvs + = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs + ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) + ; return zonked_tvs } + where + 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 + check_dup acc (sig_tv, zonked_tv) + = case lookupVarEnv acc zonked_tv of + Just sig_tv' -> bomb_out sig_tv sig_tv' + + Nothing -> return (extendVarEnv acc zonked_tv sig_tv) + + bomb_out sig_tv1 sig_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 +\end{code} -%************************************************************************ -%* * -\subsection{getTyVarsToGen} -%* * -%************************************************************************ @getTyVarsToGen@ decides what type variables to generalise over. @@ -533,6 +860,8 @@ generalise. We must be careful about doing this: Another, more common, example is when there's a Method inst in the LIE, whose type might very well involve non-overloaded type variables. + [NOTE: Jan 2001: I don't understand the problem here so I'm doing + the simple thing instead] (b) On the other hand, we mustn't generalise tyvars which are constrained, because we are going to pass on out the unmodified LIE, with those @@ -542,359 +871,210 @@ So we are careful, and do a complete simplification just to find the constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. -\begin{code} -getTyVarsToGen is_unrestricted mono_id_tys lie - = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> - zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> - let - body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars - fds = getAllFunDepsOfLIE lie - in - if is_unrestricted - then - -- We need to augment the type variables that appear explicitly in - -- the type by those that are determined by the functional dependencies. - -- e.g. suppose our type is C a b => a -> a - -- with the fun-dep a->b - -- Then we should generalise over b too; otherwise it will be - -- reported as ambiguous. - zonkFunDeps fds `thenNF_Tc` \ fds' -> - let - extended_tyvars = oclose fds' body_tyvars - in - returnNF_Tc (emptyVarSet, extended_tyvars) - else - -- This recover and discard-errs is to avoid duplicate error - -- messages; this, after all, is an "extra" call to tcSimplify - recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $ - discardErrsTc $ - - tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) -> - let - -- ASSERT: dicts_sig is already zonked! - constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts - reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars - in - returnTc (constrained_tyvars, reduced_tyvars_to_gen) -\end{code} +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. -\begin{code} -isUnRestrictedGroup :: [Name] -- Signatures given for these - -> RenamedMonoBinds - -> Bool - -is_elem v vs = isIn "isUnResMono" v vs - -isUnRestrictedGroup sigs (PatMonoBind other _ _) = False -isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs -isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches || - v `is_elem` sigs -isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && - isUnRestrictedGroup sigs mb2 -isUnRestrictedGroup sigs EmptyMonoBinds = True - -isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature -isUnRestrictedMatch other = True -- Some args or a signature -\end{code} +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + f :: Eq a => [a] -> [a] + f xs = ...f... -%************************************************************************ -%* * -\subsection{tcMonoBind} -%* * -%************************************************************************ +If we don't take care, after typechecking we get -@tcMonoBinds@ deals with a single @MonoBind@. -The signatures have been dealt with already. + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... -\begin{code} -tcMonoBinds :: RenamedMonoBinds - -> [TcSigInfo] - -> RecFlag - -> TcM (TcMonoBinds, - LIE, -- LIE required - [Name], -- Bound names - [TcId]) -- Corresponding monomorphic bound things - -tcMonoBinds mbinds tc_ty_sigs is_rec - = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) -> - let - id_list = bagToList ids - (names, mono_ids) = unzip id_list - - -- This last defn is the key one: - -- extend the val envt with bindings for the - -- things bound in this group, overriding the monomorphic - -- ids with the polymorphic ones from the pattern - extra_val_env = case is_rec of - Recursive -> map mk_bind id_list - NonRecursive -> [] - in - -- Don't know how to deal with pattern-bound existentials yet - checkTc (isEmptyBag tvs && isEmptyBag lie_avail) - (existentialExplode mbinds) `thenTc_` - - -- *Before* checking the RHSs, but *after* checking *all* the patterns, - -- extend the envt with bindings for all the bound ids; - -- and *then* override with the polymorphic Ids from the signatures - -- That is the whole point of the "complete_it" stuff. - -- - -- There's a further wrinkle: we have to delay extending the environment - -- until after we've dealt with any pattern-bound signature type variables - -- Consider f (x::a) = ...f... - -- We're going to check that a isn't unified with anything in the envt, - -- so f itself had better not be! So we pass the envt binding f into - -- complete_it, which extends the actual envt in TcMatches.tcMatch, after - -- dealing with the signature tyvars +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). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) - complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) -> + ff :: [Int] -> [Int] + ff = f Int dEqInt - returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids) - where +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. - -- This function is used when dealing with a LHS binder; we make a monomorphic - -- version of the Id. We check for type signatures - tc_pat_bndr name pat_ty - = case maybeSig tc_ty_sigs name of - Nothing - -> newLocalId (getOccName name) pat_ty (getSrcLoc name) - - Just (TySigInfo _ _ _ _ _ mono_id _ _) - -> tcAddSrcLoc (getSrcLoc name) $ - unifyTauTy (idType mono_id) pat_ty `thenTc_` - returnTc mono_id - - mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of - Nothing -> (name, mono_id) - Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id) - - tc_mb_pats EmptyMonoBinds - = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE) - - tc_mb_pats (AndMonoBinds mb1 mb2) - = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) -> - tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) -> - let - complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) -> - complete_it2 xve `thenTc` \ (mb2', lie2) -> - returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2) - in - returnTc (complete_it, - lie_req1 `plusLIE` lie_req2, - tvs1 `unionBags` tvs2, - ids1 `unionBags` ids2, - lie_avail1 `plusLIE` lie_avail2) - - tc_mb_pats (FunMonoBind name inf matches locn) - = newTyVarTy kind `thenNF_Tc` \ bndr_ty -> - tc_pat_bndr name bndr_ty `thenTc` \ bndr_id -> - let - complete_it xve = tcAddSrcLoc locn $ - tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) -> - returnTc (FunMonoBind bndr_id inf matches' locn, lie) - in - returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE) - - tc_mb_pats bind@(PatMonoBind pat grhss locn) - = tcAddSrcLoc locn $ - newTyVarTy kind `thenNF_Tc` \ pat_ty -> - - -- Now typecheck the pattern - -- We don't support binding fresh type variables in the - -- pattern of a pattern binding. For example, this is illegal: - -- (x::a, y::b) = e - -- whereas this is ok - -- (x::Int, y::Bool) = e - -- - -- We don't check explicitly for this problem. Instead, we simply - -- type check the pattern with tcPat. If the pattern mentions any - -- fresh tyvars we simply get an out-of-scope type variable error - tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> - let - complete_it xve = tcAddSrcLoc locn $ - tcAddErrCtxt (patMonoBindsCtxt bind) $ - tcExtendLocalValEnv xve $ - tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) -> - returnTc (PatMonoBind pat' grhss' locn, lie) - in - returnTc (complete_it, lie_req, tvs, ids, lie_avail) - - -- Figure out the appropriate kind for the pattern, - -- and generate a suitable type variable - kind = case is_rec of - Recursive -> liftedTypeKind -- Recursive, so no unlifted types - NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types -\end{code} + ff = f Int dEqInt -%************************************************************************ -%* * -\subsection{Signatures} -%* * -%************************************************************************ + = let f' = f Int dEqInt in \ys. ...f'... -@checkSigMatch@ does the next step in checking signature matching. -The tau-type part has already been unified. What we do here is to -check that this unification has not over-constrained the (polymorphic) -type variables of the original signature type. + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... -The error message here is somewhat unsatisfactory, but it'll do for -now (ToDo). +Etc. -\begin{code} -checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM (Maybe (TcThetaType, LIE)) -checkSigMatch top_lvl binder_names mono_ids sigs - | main_bound_here - = -- First unify the main_id with IO t, for any old t - tcSetErrCtxt mainTyCheckCtxt ( - tcLookupTyCon ioTyConName `thenTc` \ ioTyCon -> - newTyVarTy liftedTypeKind `thenNF_Tc` \ t_tv -> - unifyTauTy ((mkTyConApp ioTyCon [t_tv])) - (idType main_mono_id) - ) `thenTc_` - - -- Now check the signatures - -- Must do this after the unification with IO t, - -- in case of a silly signature like - -- main :: forall a. a - -- The unification to IO t will bind the type variable 'a', - -- which is just waht check_one_sig looks for - mapTc check_one_sig sigs `thenTc_` - mapTc check_main_ctxt sigs `thenTc_` - returnTc (Just ([], emptyLIE)) - - | not (null sigs) - = mapTc check_one_sig sigs `thenTc_` - mapTc check_one_ctxt all_sigs_but_first `thenTc_` - returnTc (Just (theta1, sig_lie)) +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 - | otherwise - = returnTc Nothing -- No constraints from type sigs +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...) +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 - where - (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs - - sig1_dict_tys = mk_dict_tys theta1 - n_sig1_dict_tys = length sig1_dict_tys - sig_lie = mkLIE (concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]) - - maybe_main = find_main top_lvl binder_names mono_ids - main_bound_here = maybeToBool maybe_main - Just main_mono_id = maybe_main - - -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK - -- Doesn't affect substitution - check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $ - checkSigTyVars sig_tyvars (idFreeTyVars id) - - - -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - -- ToDo: amplify - check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigContextsCtxt id1 id) $ - checkTc (length this_sig_dict_tys == n_sig1_dict_tys) - sigContextsErr `thenTc_` - unifyTauTyLists sig1_dict_tys this_sig_dict_tys - where - this_sig_dict_tys = mk_dict_tys theta - - -- CHECK THAT FOR A GROUP INVOLVING Main.main, all - -- the signature contexts are empty (what a bore) - check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc) - = tcAddSrcLoc src_loc $ - checkTc (null theta) (mainContextsErr id) - - mk_dict_tys theta = map mkPredTy theta - - sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id) - - -- Search for Main.main in the binder_names, return corresponding mono_id - find_main NotTopLevel binder_names mono_ids = Nothing - find_main TopLevel binder_names mono_ids = go binder_names mono_ids - go [] [] = Nothing - go (n:ns) (m:ms) | n `hasKey` mainKey = Just m - | otherwise = go ns ms -\end{code} %************************************************************************ %* * -\subsection{SPECIALIZE pragmas} + Signatures %* * %************************************************************************ -@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user* -pragmas. It is convenient for them to appear in the @[RenamedSig]@ -part of a binding because then the same machinery can be used for -moving them into place as is done for type signatures. - -They look like this: - -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b #-} -\end{verbatim} - -For this we generate: -\begin{verbatim} - f* = /\ b -> let d1 = ... - in f Int b d1 -\end{verbatim} - -where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to -retain a right-hand-side that the simplifier will otherwise discard as -dead code... the simplifier has a flag that tells it not to discard -SpecPragmaId bindings. - -In this case the f* retains a call-instance of the overloaded -function, f, (including appropriate dictionaries) so that the -specialiser will subsequently discover that there's a call of @f@ at -Int, and will create a specialisation for @f@. After that, the -binding for @f*@ can be discarded. - -We used to have a form - {-# SPECIALISE f :: = g #-} -which promised that g implemented f at , but we do that with -a RULE now: - {-# SPECIALISE (f:: 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} \begin{code} -tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE) -tcSpecSigs (SpecSig name poly_ty src_loc : sigs) - = -- SPECIALISE f :: forall b. theta => tau = g - tcAddSrcLoc src_loc $ - tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ - - -- Get and instantiate its alleged specialised type - tcHsSigType poly_ty `thenTc` \ sig_ty -> - - -- Check that f has a more general type, and build a RHS for - -- the spec-pragma-id at the same time - tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) -> - - -- Squeeze out any Methods (see comments with tcSimplifyToDicts) - tcSimplifyToDicts spec_lie `thenTc` \ (spec_lie1, spec_binds) -> - - -- Just specialise "f" by building a SpecPragmaId binding - -- It is the thing that makes sure we don't prematurely - -- dead-code-eliminate the binding we are really interested in. - newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id -> - - -- Do the rest and combine - tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) -> - returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr), - lie_rest `plusLIE` spec_lie1) - -tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE) +tcTySig :: LSig Name -> TcM TcId +tcTySig (L span (TypeSig (L _ name) ty)) + = setSrcSpan span $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name) 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.) + -- 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 + ; return (not mono_restriction || all_unrestricted) } + where + all_unrestricted = all (unrestricted . unLoc) binds + has_sig n = isJust (sig_fn n) + + 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 + unrestricted_match other = True + -- Some args => a function binding \end{code} @@ -906,50 +1086,33 @@ tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE) \begin{code} -patMonoBindsCtxt bind - = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind) +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt pat grhss + = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- -valSpecSigCtxt v ty - = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"), - nest 4 (ppr v <+> dcolon <+> ppr ty)] +sigContextsCtxt sig1 sig2 + = vcat [ptext SLIT("When matching the contexts of the signatures for"), + nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), + ppr id2 <+> dcolon <+> ppr (idType id2)]), + ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + where + id1 = sig_id sig1 + id2 = sig_id sig2 ------------------------------------------------ -unliftedPatBindErr id - = ptext SLIT("variable in a lazy pattern binding has unlifted type: ") - <+> quotes (ppr id) ----------------------------------------------- -bindSigsCtxt ids - = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids +unboxedTupleErr name ty + = hang (ptext SLIT("Illegal binding of unboxed tuple")) + 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- -sigContextsErr - = ptext SLIT("Mismatched contexts") +restrictedBindCtxtErr binder_names + = hang (ptext SLIT("Illegal overloaded type signature(s)")) + 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, + ptext SLIT("that falls under the monomorphism restriction")]) -sigContextsCtxt s1 s2 - = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), - quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)]) - 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) - -mainContextsErr id - | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded") - | otherwise - = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal - ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings. - -mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")), - ptext SLIT("has the required type")] - ------------------------------------------------ -unliftedBindErr flavour mbind - = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) - 4 (ppr mbind) - -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) +genCtxt binder_names + = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names \end{code}