X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=cffcb9cfb939d42e64bb3a40c9b9628b44f703b5;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=26e5fc590387879fc4ef5b775559d041afa83150;hpb=2f6d1e5ed861d3ece3e51050d7cd11b2f48330bf;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 26e5fc5..cffcb9c 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,61 +4,68 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, - tcHsBootSigs, tcMonoBinds, tcSpecSigs, +module TcBinds ( tcLocalBinds, tcTopBinds, + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), badBootDeclErr ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) - -import DynFlags ( DynFlag(Opt_MonomorphismRestriction) ) -import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), - LSig, Match(..), HsBindGroup(..), IPBind(..), - HsType(..), HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, - LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, - collectHsBindBinders, collectPatBinders, pprPatBind +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 TcHsSyn ( zonkId, mkHsLet ) +import TcHsSyn ( zonkId ) import TcRnMonad import Inst ( newDictsAtLoc, newIPDict, instToId ) import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, - newLocalName, tcLookupLocalIds, pprBinders, + pprBinders, tcLookupLocalId_maybe, tcLookupId, tcGetGlobalTyVars ) -import TcUnify ( Expected(..), tcInfer, unifyTheta, +import TcUnify ( tcInfer, tcSubExp, unifyTheta, bleatEscapedTvs, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, - tcSimplifyToDicts, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars, - TcSigInfo(..), TcSigFun, lookupSig - ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, + tcSimplifyRestricted, tcSimplifyIPs ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar, - tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar ) -import 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, mkSpecPragmaId, setInlinePragma ) +import Id ( Id, mkLocalId, mkVanillaGlobal ) import IdInfo ( vanillaIdInfo ) -import Var ( idType, idName ) +import Var ( TyVar, idType, idName ) import Name ( Name ) import NameSet +import NameEnv import VarSet -import SrcLoc ( Located(..), unLoc, noLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc ) import Bag import ErrUtils ( Message ) -import Util ( isIn ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, - isNotTopLevel, isAlwaysActive ) -import FiniteMap ( listToFM, lookupFM ) +import Digraph ( SCC(..), stronglyConnComp ) +import Maybes ( expectJust, isJust, isNothing, orElse ) +import Util ( singleton ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) import Outputable \end{code} @@ -95,29 +102,24 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) +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 $ - do { env <- getLclEnv - ; return (emptyLHsBinds, env) } - where + = 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 MonoBinds - glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env) - glue (HsIPBinds _) _ = panic "Top-level HsIpBinds" - -- Can't have a HsIPBinds at top level + -- implicitly-mutually-recursive LHsBinds -tcHsBootSigs :: [HsBindGroup Name] -> TcM [Id] +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 [HsBindGroup binds sigs _] - = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr +tcHsBootSigs (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } where - tc_boot_sig (Sig (L _ name) ty) + tc_boot_sig (TypeSig (L _ name) ty) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } -- Notice that we make GlobalIds, not LocalIds @@ -126,180 +128,240 @@ tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") -tcBindsAndThen - :: (HsBindGroup TcId -> thing -> thing) -- Combinator - -> [HsBindGroup Name] - -> TcM thing - -> TcM thing +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) -tcBindsAndThen = tc_binds_and_then NotTopLevel +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } -tc_binds_and_then top_lvl combiner [] do_next - = do_next -tc_binds_and_then top_lvl combiner (group : groups) do_next - = tc_bind_and_then top_lvl combiner group $ - tc_binds_and_then top_lvl combiner groups do_next +tcLocalBinds (HsValBinds binds) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside + ; return (HsValBinds binds', thing) } -tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next - = getLIE do_next `thenM` \ (result, expr_lie) -> - mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') -> +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 - tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - - returnM (combiner (HsIPBinds binds') $ - combiner (HsBindGroup dict_binds [] Recursive) result) + ; dict_binds <- tcSimplifyIPs avail_ips lie + ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } where -- I wonder if we should do these one at at time -- 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')) -tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next - | isEmptyLHsBinds binds - = do_next - | otherwise - = -- 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) - tcAddLetBoundTyVars binds $ - - case top_lvl of - TopLevel -- 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 - -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (combiner (HsBindGroup - (poly_binds `unionBags` prag_binds) - [] -- no sigs - Recursive) - thing) - - NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing. - | not (isRec is_rec) -- Non-recursive group - -> -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> - - -- Create specialisations of functions bound here - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - - returnM ( - combiner (HsBindGroup poly_binds [] NonRecursive) $ - combiner (HsBindGroup prag_binds [] NonRecursive) $ - combiner (HsBindGroup lie_binds [] Recursive) $ - -- NB: the binds returned by tcSimplify and - -- bindInstsOfLocalFuns aren't guaranteed in - -- dependency order (though we could change that); - -- hence the Recursive marker. - thing) - - | otherwise - -> -- 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 tcBindWithSigs. - - getLIE ( - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (poly_ids, poly_binds `unionBags` prag_binds, thing) - ) `thenM` \ ((poly_ids, extra_binds, thing), lie) -> - - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - - returnM (combiner (HsBindGroup - (extra_binds `unionBags` lie_binds) - [] Recursive) thing - ) +------------------------ +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 - tc_body poly_ids -- Type check the pragmas and "thing inside" - = -- Extend the environment to bind the new polymorphic Ids - tcExtendIdEnv poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenM` \ prag_binds -> + new_sccs :: [SCC (LHsBind Name)] + new_sccs = stronglyConnComp (mkEdges sig_fn binds) - -- Now do whatever happens next, in the augmented envt - do_next `thenM` \ thing -> +-- 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) } - returnM (prag_binds, thing) -\end{code} + go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) + go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) + tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds -%************************************************************************ -%* * -\subsection{tcBindWithSigs} -%* * -%************************************************************************ +------------------------ +mkEdges :: TcSigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] -@tcBindWithSigs@ deals with a single binding group. It does generalisation, -so all the clever stuff is in here. +type BKey = Int -- Just number off the bindings -* binder_names and mbind must define the same set of Names +mkEdges sig_fn binds + = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ]) + | (bind, key) <- keyd_binds + ] + where + no_sig :: Name -> Bool + no_sig n = isNothing (sig_fn n) -* The Names in tc_ty_sigs must be a subset of binder_names + keyd_binds = bagToList binds `zip` [0::BKey ..] -* The Ids in tc_ty_sigs don't necessarily have to have the same name - as the Name in the tc_ty_sig + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- bindersOfHsBind bind ] -\begin{code} -tcBindWithSigs :: TopLevelFlag - -> LHsBinds Name - -> [LSig Name] - -> RecFlag - -> TcM (LHsBinds TcId, [TcId]) - -- The returned TcIds are guaranteed zonked - -tcBindWithSigs top_lvl mbind sigs is_rec = do - { -- TYPECHECK THE SIGNATURES - tc_ty_sigs <- recoverM (returnM []) $ - tcTySigs (filter isVanillaLSig sigs) - ; let lookup_sig = lookupSig tc_ty_sigs +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 - ; recoverM (recoveryCode mbind lookup_sig) $ do + setSrcSpan loc $ + recoverM (recoveryCode binder_names) $ do - { traceTc (ptext SLIT("--------------------------------------------------------")) - ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) + { traceTc (ptext SLIT("------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) -- TYPECHECK THE BINDINGS - ; ((mbind', mono_bind_infos), lie_req) - <- getLIE (tcMonoBinds mbind lookup_sig is_rec) + ; ((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) - ; if any isUnLiftedType zonked_mono_tys then - do { -- Unlifted bindings - checkUnliftedBinds top_lvl is_rec mbind - ; 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) - - ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind', - [poly_id | (_, poly_id, _) <- exports]) } -- Guaranteed zonked + ; 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 mbind tc_ty_sigs + { is_unres <- isUnRestrictedGroup bind_list sig_fn ; (tyvars_to_gen, dict_binds, dict_ids) - <- setSrcSpan (getLoc (head (bagToList mbind))) $ - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent - addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise top_lvl is_unres mono_bind_infos tc_ty_sigs lie_req + <- 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 @@ -308,138 +370,139 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen -- BUILD THE POLYMORPHIC RESULT IDs - ; let - exports = map mk_export mono_bind_infos - poly_ids = [poly_id | (_, poly_id, _) <- exports] - dict_tys = map idType dict_ids - - inlines = mkNameSet [ name - | L _ (InlineSig True (L _ name) _) <- sigs] - -- Any INLINE sig (regardless of phase control) - -- makes the RHS look small - inline_phases = listToFM [ (name, phase) - | L _ (InlineSig _ (L _ name) phase) <- sigs, - not (isAlwaysActive phase)] - -- Set the IdInfo field to control the inline phase - -- AlwaysActive is the default, so don't bother with them - add_inlines id = attachInlinePhase inline_phases id - - mk_export (binder_name, mb_sig, mono_id) - = case mb_sig of - Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id) - Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id) - where - new_poly_id = mkLocalId binder_name poly_ty - poly_ty = mkForAllTys tyvars_to_gen' - $ mkFunTys dict_tys - $ idType mono_id + ; 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 ((dict_ids, dict_binds), - exports, map idType zonked_poly_ids)) + ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids)) - ; return ( - unitBag $ noLoc $ - AbsBinds tyvars_to_gen' - dict_ids - exports - inlines - (dict_binds `unionBags` mbind'), - zonked_poly_ids - ) - } } } + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' + dict_ids exports + (dict_binds `unionBags` binds') --- If typechecking the binds fails, then return with each --- signature-less binder given type (forall a.a), to minimise --- subsequent error messages -recoveryCode mbind lookup_sig - = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) - ; return (emptyLHsBinds, poly_ids) } - where - forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - binder_names = collectHsBindBinders mbind - poly_ids = map mk_dummy binder_names - mk_dummy name = case lookup_sig name of - Just sig -> sig_id sig -- Signature - Nothing -> mkLocalId name forall_a_a -- No signature - -attachInlinePhase inline_phases bndr - = case lookupFM inline_phases (idName bndr) of - Just prag -> bndr `setInlinePragma` prag - Nothing -> bndr + ; return ([unitBag abs_bind], zonked_poly_ids) + } } --- 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 top_lvl is_rec mbind - = checkTc (isNotTopLevel top_lvl) - (unliftedBindErr "Top-level" mbind) `thenM_` - checkTc (isNonRec is_rec) - (unliftedBindErr "Recursive" mbind) `thenM_` - checkTc (isSingletonBag mbind) - (unliftedBindErr "Multiple" mbind) -\end{code} - - -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. +-------------- +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 -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: + 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 - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... +------------------------ +type TcPragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> TcPragFun +mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] + where + 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 + +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 -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 +pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm +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) -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - ff :: [Int] -> [Int] - ff = f Int dEqInt +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) } + +-------------- +-- 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 -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. +forall_a_a :: TcType +forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - ff = f Int dEqInt - = let f' = f Int dEqInt in \ys. ...f'... +-- 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)) - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... +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") -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. +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} %************************************************************************ @@ -448,25 +511,30 @@ is doing. %* * %************************************************************************ -@tcMonoBinds@ deals with a single @MonoBind@. +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. The signatures have been dealt with already. \begin{code} -tcMonoBinds :: LHsBinds Name - -> TcSigFun -> RecFlag +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 binds lookup_sig is_rec - | isNonRec is_rec, -- Non-recursive, single function binding - [L b_loc (FunBind (L nm_loc name) inf matches)] <- bagToList binds, - Nothing <- lookup_sig name -- ...with no type signature +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 { (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 #) -- Zonk first just in case it's hidden inside a meta type variable @@ -475,32 +543,53 @@ tcMonoBinds binds lookup_sig is_rec ; 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 (L nm_loc mono_id) inf matches')), + ; 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)]) } - | otherwise - = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds +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 - - ; binds' <- tcExtendTyVarEnv2 rhs_tvs $ - tcExtendIdEnv2 rhs_id_env $ - traceTc (text "tcMonoBinds" <+> vcat [ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_` - mapBagM (wrapLocM tcRhs) tc_binds - ; return (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 + 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 @@ -533,56 +622,63 @@ getMonoType :: MonoBindInfo -> TcTauType getMonoType (_,_,mono_id) = idType mono_id tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind -tcLhs lookup_sig (FunBind (L nm_loc name) inf matches) - = do { let mb_sig = lookup_sig 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 + + 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. -tcLhs lookup_sig bind@(PatBind pat grhss _) - = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos - ; ((pat', ex_tvs, infos), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) - (tcInfer tc_pat) + -- 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) } - -- Don't know how to deal with pattern-bound existentials yet - ; checkTc (null ex_tvs) (existentialExplode bind) + ; ((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, lookup_sig name, mono_id) - | (name, mono_id) <- names `zip` mono_ids] } -tcLhs lookup_sig other_bind = pprPanic "tcLhs" (ppr other_bind) +tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- 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') } + = 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) } + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, + bind_fvs = placeHolderNames }) } --------------------- -getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo] +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds - = foldrBag (get_info . unLoc) [] tc_binds + = foldr (get_info . unLoc) [] tc_binds where get_info (TcFunBind info _ _ _) rest = info : rest get_info (TcPatBind infos _ _ _) rest = infos ++ rest @@ -591,68 +687,23 @@ getMonoBindInfo tc_binds %************************************************************************ %* * -\subsection{getTyVarsToGen} + Generalisation %* * %************************************************************************ -Type signatures are tricky. See Note [Signature skolems] in TcType - -\begin{code} -tcTySigs :: [LSig Name] -> TcM [TcSigInfo] --- 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 -tcTySigs [] = return [] - -tcTySigs sigs - = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs - ; mapM (check_ctxt tc_sig1) tc_sigs - ; return (tc_sig1 : tc_sigs) } - where - -- Check tha 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). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - check_ctxt :: TcSigInfo -> TcSigInfo -> TcM () - check_ctxt sig1@(TcSigInfo { sig_theta = theta1 }) sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ - addErrCtxt (sigContextsCtxt sig1 sig) $ - unifyTheta theta1 theta - - -tcTySig :: LSig Name -> TcM TcSigInfo -tcTySig (L span (Sig (L _ name) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty - ; loc <- getInstLoc (SigOrigin (SigSkol name)) - ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty, - sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = scoped_names, sig_loc = loc }) } - 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 -> [] -\end{code} - \begin{code} -generalise :: TopLevelFlag -> Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst] +generalise :: TopLevelFlag -> Bool + -> [MonoBindInfo] -> [Inst] -> TcM ([TcTyVar], TcDictBinds, [TcId]) -generalise top_lvl is_unrestricted mono_infos sigs lie_req +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 bndr_names) + (restrictedBindCtxtErr bndrs) -- Now simplify with exactly that set of tyvars -- We have to squash those Methods - ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndr_names + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs tau_tvs lie_req -- Check that signature type variables are OK @@ -664,11 +715,10 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req = tcSimplifyInfer doc tau_tvs lie_req | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS - = do { let sig1 = head sigs - ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1) + = 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 comments at end of fn) + -- 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 @@ -680,16 +730,44 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req ; final_qtvs <- checkSigsTyVars forall_tvs sigs ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } - where - bndr_names = bndrNames mono_infos - tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos + 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 bndr_names + 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). + +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 @@ -728,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 @@ -747,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} @@ -795,104 +870,213 @@ 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} -isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool -isUnRestrictedGroup binds sigs - = do { mono_restriction <- doptM Opt_MonomorphismRestriction - ; return (not mono_restriction || all_unrestricted) } - where - all_unrestricted = all (unrestricted . unLoc) (bagToList binds) - tysig_names = map (idName . sig_id) sigs +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is - unrestricted (PatBind other _ _) = False - unrestricted (VarBind v _) = v `is_elem` tysig_names - unrestricted (FunBind v _ matches) = unrestricted_match matches - || unLoc v `is_elem` tysig_names + * 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. - unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False - -- No args => like a pattern binding - unrestricted_match other = True - -- Some args => a function binding +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... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +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) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +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. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + 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...) +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 -is_elem v vs = isIn "isUnResMono" v vs -\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: - {-# RULES (f::) = g #-} +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} -tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId) -tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs) - = -- SPECIALISE f :: forall b. theta => tau = g - setSrcSpan loc $ - addErrCtxt (valSpecSigCtxt name poly_ty) $ - - -- Get and instantiate its alleged specialised type - tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty -> - - -- Check that f has a more general type, and build a RHS for - -- the spec-pragma-id at the same time - getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) -> - - -- Squeeze out any Methods (see comments with tcSimplifyToDicts) - tcSimplifyToDicts spec_lie `thenM` \ 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. - newLocalName name `thenM` \ spec_name -> - let - spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty) - (mkHsLet spec_binds spec_expr) - in +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} - -- Do the rest and combine - tcSpecSigs sigs `thenM` \ binds_rest -> - returnM (binds_rest `snocBag` L loc spec_bind) +\begin{code} +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) } -tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnM emptyLHsBinds +------------------- +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} + %************************************************************************ %* * \subsection[TcBinds-errors]{Error contexts and messages} @@ -907,11 +1091,6 @@ 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), @@ -923,23 +1102,11 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- -unliftedBindErr flavour mbind - = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) - 4 (ppr mbind) - ------------------------------------------------ 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,