X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=9f11ade302005b8fe54f4e16980b8f5b2c6bcf0f;hb=820ddd55446773b33c797267bcad9e09a621ab2b;hp=076de00c37286c3711ee6d87f1bc9da1e9a8e235;hpb=176fb356fbbc4cf398fb66440d84a05ad333c881;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 076de00..9f11ade 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1,80 +1,60 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcBinds]{TcBinds} \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, - tcHsBootSigs, tcMonoBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, - TcSigInfo(..), TcSigFun, mkTcSigFun, - badBootDeclErr ) where - -#include "HsVersions.h" + tcHsBootSigs, tcPolyBinds, + PragFun, tcSpecPrags, mkPragFun, + TcSigInfo(..), SigFun, mkSigFun, + badBootDeclErr ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import DynFlags ( dopt, DynFlags, - DynFlag(Opt_MonomorphismRestriction, Opt_MonoPatBinds, 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 ) +import DynFlags +import HsSyn 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 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 TcEnv +import TcUnify +import TcSimplify +import TcHsType +import TcPat +import TcMType +import TcType +import RnBinds( misplacedSigErr ) +import Coercion +import TysPrim +import Id +import Var +import Name import NameSet import NameEnv import VarSet -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc import Bag -import ErrUtils ( Message ) -import Digraph ( SCC(..), stronglyConnComp ) -import Maybes ( expectJust, isJust, isNothing, orElse ) -import Util ( singleton ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) +import ErrUtils +import Digraph +import Maybes +import Util +import BasicTypes import Outputable +import FastString + +import Data.List( partition ) +import Control.Monad + +#include "HsVersions.h" \end{code} %************************************************************************ -%* * +%* * \subsection{Type-checking bindings} -%* * +%* * %************************************************************************ @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because @@ -103,162 +83,209 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -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 :: HsValBinds Name + -> TcM ( LHsBinds TcId -- Typechecked bindings + , [LTcSpecPrag] -- SPECIALISE prags for imported Ids + , TcLclEnv) -- Augmented environment + + -- 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 - = 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 + = do { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv + ; let binds = foldr (unionBags . snd) emptyBag prs + ; specs <- tcImpPrags sigs + ; return (binds, specs, 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) } + = do { checkTc (null binds) badBootDeclErr + ; mapM (addLocM tc_boot_sig) (filter isTypeLSig 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 + ; return (mkVanillaGlobal name sigma_ty) } + -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message -badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") +badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing - -> TcM (HsLocalBinds TcId, thing) + -> TcM (HsLocalBinds TcId, thing) tcLocalBinds EmptyLocalBinds thing_inside - = do { thing <- thing_inside - ; return (EmptyLocalBinds, thing) } + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } tcLocalBinds (HsValBinds binds) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside - ; return (HsValBinds binds', thing) } + = 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 + = do { (given_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 + -- See Note [Implicit parameter untouchables] + ; (ev_binds, result) <- checkConstraints (IPSkol ips) + [] given_ips thing_inside - -- 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) } + ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } where - -- 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')) + ips = [ip | L _ (IPBind ip _) <- ip_binds] + + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind (IPBind ip expr) + = do { ty <- newFlexiTyVarTy argTypeKind + ; ip_id <- newIP ip ty + ; expr' <- tcMonoExpr expr ty + ; return (ip_id, (IPBind (IPName ip_id) expr')) } +\end{code} ------------------------- +Note [Implicit parameter untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We add the type variables in the types of the implicit parameters +as untouchables, not so much because we really must not unify them, +but rather because we otherwise end up with constraints like this + Num alpha, Implic { wanted = alpha ~ Int } +The constraint solver solves alpha~Int by unification, but then +doesn't float that solved constraint out (it's not an unsolved +wanted. Result disaster: the (Num alpha) is again solved, this +time by defaulting. No no no. + +However [Oct 10] this is all handled automatically by the +untouchable-range idea. + +\begin{code} tcValBinds :: TopLevelFlag - -> HsValBinds Name -> TcM thing - -> TcM (HsValBinds TcId, thing) + -> HsValBinds Name -> TcM thing + -> TcM (HsValBinds TcId, thing) -tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside +tcValBinds _ (ValBindsIn binds _) _ = 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 = mkTcSigFun ty_sigs } - - ; poly_ids <- mapM tcTySig ty_sigs - -- No recovery from bad signatures, because the type sigs - -- may bind type variables, so proceeding without them - -- can lead to a cascade of errors - -- ToDo: this means we fall over immediately if any type sig - -- is wrong, which is over-conservative, see Trac bug #745 - - -- 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) } + = do { -- Typecheck the signature + ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) + ; ty_sigs = filter isTypeLSig sigs + ; sig_fn = mkSigFun ty_sigs } + + ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) + -- No recovery from bad signatures, because the type sigs + -- may bind type variables, so proceeding without them + -- can lead to a cascade of errors + -- ToDo: this means we fall over immediately if any type sig + -- is wrong, which is over-conservative, see Trac bug #745 + + -- Extend the envt right away with all + -- the Ids declared with type signatures + ; (binds', thing) <- tcExtendIdEnv poly_ids $ + tcBindGroups 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) +tcBindGroups :: TopLevelFlag -> SigFun -> PragFun + -> [(RecFlag, LHsBinds Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time +-- Here a "strongly connected component" has the strightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) -tc_val_binds top_lvl sig_fn prag_fn [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } +tcBindGroups _ _ _ [] 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) } +tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group $ + tcBindGroups 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) +tc_group :: forall thing. + TopLevelFlag -> SigFun -> PragFun + -> (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 + -- 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) } + = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive + (bagToList binds) + ; thing <- tcExtendIdEnv ids thing_inside + ; return ( [(NonRecursive, binds1)], 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 + = -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + do { traceTc "tc_group rec" (pprLHsBinds binds) + ; (binds1, _ids, thing) <- go sccs + -- Here is where we should do bindInstsOfLocalFuns + -- if we start having Methods again + ; return ([(Recursive, binds1)], thing) } + -- Rec them all together where - new_sccs :: [SCC (LHsBind Name)] - new_sccs = stronglyConnComp (mkEdges sig_fn binds) + sccs :: [SCC (LHsBind Name)] + sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds) + + go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) + go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc + ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs + ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, [], 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) } + tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] + tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds - go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) - go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) + tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive - tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds ------------------------ -mkEdges :: TcSigFun -> LHsBinds Name - -> [(LHsBind Name, BKey, [BKey])] +{- +bindLocalInsts :: TopLevelFlag + -> TcM (LHsBinds TcId, [TcId], a) + -> TcM (LHsBinds TcId, TcEvBinds, a) +bindLocalInsts top_lvl thing_inside + | isTopLevel top_lvl + = do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) } + -- For the top level don't bother with 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 + + | otherwise -- Nested case + = do { ((binds, ids, thing), lie) <- captureConstraints thing_inside + ; lie_binds <- bindLocalMethods lie ids + ; return (binds, lie_binds, thing) } +-} + +------------------------ +mkEdges :: SigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] type BKey = Int -- Just number off the bindings mkEdges sig_fn binds = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ]) + Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] where @@ -267,433 +294,462 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] - key_map :: NameEnv BKey -- Which binding it comes from + key_map :: NameEnv BKey -- Which binding it comes from key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- bindersOfHsBind bind ] + , bndr <- bindersOfHsBind bind ] bindersOfHsBind :: HsBind Name -> [Name] bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] +bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" +bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ -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) +tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId]) -- 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. +-- +-- Knows nothing about the scope of the bindings -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) }} +tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list + = setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do + -- Set up main recoer; take advantage of any type sigs ------------------------- -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 + { traceTc "------------------------------------------------" empty + ; traceTc "Bindings for" (ppr binder_names) + + ; tc_sig_fn <- tcInstSigs sig_fn binder_names + + ; dflags <- getDOpts + ; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn + ; traceTc "Generalisation plan" (ppr plan) + ; (binds, poly_ids) <- case plan of + NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list + InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list + CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list -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 - { dflags <- getDOpts - ; (tyvars_to_gen, dict_binds, dict_ids) - <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise dflags top_lvl bind_list sig_fn 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) - } } + -- Check whether strict bindings are ok + -- These must be non-recursive etc, and are not generalised + -- They desugar to a case expression in the end + ; checkStrictBinds top_lvl rec_group bind_list poly_ids + + ; return (binds, poly_ids) } + where + binder_names = collectHsBindListBinders bind_list + loc = getLoc (head bind_list) + -- TODO: location a bit awkward, but the mbinds have been + -- dependency analysed and may no longer be adjacent + +------------------ +tcPolyNoGen + :: TcSigFun -> PragFun + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId]) +-- No generalisation whatsoever + +tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list + = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) + rec_tc bind_list + ; mono_ids' <- mapM tc_mono_info mono_infos + ; return (binds', mono_ids') } + where + tc_mono_info (name, _, mono_id) + = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id) + -- Zonk, mainly to expose unboxed types to checkStrictBinds + ; let mono_id' = setIdType mono_id mono_ty' + ; _specs <- tcSpecPrags mono_id' (prag_fn name) + ; return mono_id' } + -- NB: tcPrags generates error messages for + -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! + -- So we can safely ignore _specs + +------------------ +tcPolyCheck :: TcSigInfo -> PragFun + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId]) +-- There is just one binding, +-- it binds a single variable, +-- it has a signature, +tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped + , sig_theta = theta, sig_loc = loc }) + prag_fn rec_tc bind_list + = do { ev_vars <- newEvVars theta + + ; let skol_info = SigSkol (FunSigCtxt (idName id)) + ; (ev_binds, (binds', [mono_info])) + <- checkConstraints skol_info tvs ev_vars $ + tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ + tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list + + ; export <- mkExport prag_fn tvs theta mono_info + + ; let (_, poly_id, _, _) = export + abs_bind = L loc $ AbsBinds + { abs_tvs = tvs + , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds + , abs_exports = [export], abs_binds = binds' } + ; return (unitBag abs_bind, [poly_id]) } + +------------------ +tcPolyInfer + :: TopLevelFlag + -> Bool -- True <=> apply the monomorphism restriction + -> TcSigFun -> PragFun + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId]) +tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list + = do { ((binds', mono_infos), wanted) + <- captureConstraints $ + tcMonoBinds sig_fn LetLclBndr rec_tc bind_list + + ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] + + ; let get_tvs | isTopLevel top_lvl = tyVarsOfType + | otherwise = exactTyVarsOfType + -- See Note [Silly type synonym] in TcType + tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos + + ; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted + + ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens)) + mono_infos + + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] + ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) + + ; loc <- getSrcSpanM + ; let abs_bind = L loc $ AbsBinds { abs_tvs = qtvs + , abs_ev_vars = givens, abs_ev_binds = ev_binds + , abs_exports = exports, abs_binds = binds' } + + ; return (unitBag abs_bind, poly_ids) -- poly_ids are guaranteed zonked by mkExport + } -------------- -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 +mkExport :: PragFun -> [TyVar] -> TcThetaType + -> MonoBindInfo + -> TcM ([TyVar], Id, Id, TcSpecPrags) +-- mkExport generates exports with +-- zonked type variables, +-- zonked poly_ids +-- The former is just because no further unifications will change +-- the quantified type variables, so we can fix their final form +-- right now. +-- The latter is needed because the poly_ids are used to extend the +-- type environment; see the invariant on TcEnv.tcExtendIdEnv + +-- Pre-condition: the inferred_tvs are already zonked + +mkExport prag_fn inferred_tvs theta + (poly_name, mb_sig, mono_id) + = do { (tvs, poly_id) <- mk_poly_id mb_sig + -- poly_id has a zonked type + + ; poly_id' <- addInlinePrags poly_id prag_sigs + + ; spec_prags <- tcSpecPrags poly_id prag_sigs + -- tcPrags requires a zonked poly_id + + ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) } + where + prag_sigs = prag_fn poly_name + poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id) + + mk_poly_id Nothing = do { poly_ty' <- zonkTcTypeCarefully poly_ty + ; return (inferred_tvs, mkLocalId poly_name poly_ty') } + mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig) + ; return (tvs, sig_id sig) } + zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) } ------------------------ -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 +type PragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun +mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] + where + prs = mapCatMaybes get_sig sigs + + get_sig :: LSig Name -> Maybe (Located Name, LSig Name) + get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl)) + get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl)) + get_sig _ = Nothing + + add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function + | Just ar <- lookupNameEnv ar_env n, + Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar } + -- add arity only for real INLINE pragmas, not INLINABLE + | otherwise = inl_prag + + prag_env :: NameEnv [LSig Name] + prag_env = foldl add emptyNameEnv prs + add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldrBag lhsBindArity emptyNameEnv binds + +lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + +------------------ +tcSpecPrags :: Id -> [LSig Name] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALSE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { unless (null bad_sigs) warn_discarded_sigs + ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s) + + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + +-------------- +tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag +tcSpec poly_id prag@(SpecSig _ hs_ty inl) + -- The Name in the SpecSig may not be the same as that of the poly_id + -- Example: SPECIALISE for a class method: the Name in the SpecSig is + -- for the selector Id, but the poly_id is something like $cop + = addErrCtxt (spec_ctxt prag) $ + do { spec_ty <- tcHsSigType sig_ctxt hs_ty + ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) + (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id)) + -- Note [SPECIALISE pragmas] + ; wrap <- tcSubType origin skol_info (idType poly_id) spec_ty + ; return (SpecPrag poly_id wrap inl) } 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) } - -- Most of the work of specialisation is done by - -- the desugarer, guided by the SpecPrag - + name = idName poly_id + poly_ty = idType poly_id + origin = SpecPragOrigin name + sig_ctxt = FunSigCtxt name + skol_info = SigSkol sig_ctxt + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpec _ prag = pprPanic "tcSpec" (ppr prag) + +-------------- +tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +tcImpPrags prags + = do { this_mod <- getModule + ; let is_imp prag + = case sigName prag of + Nothing -> False + Just name -> not (nameIsLocalOrFrom this_mod name) + (spec_prags, others) = partition isSpecLSig $ + filter is_imp prags + ; mapM_ misplacedSigErr others + -- Messy that this misplaced-sig error comes here + -- but the others come from the renamer + ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } + +tcImpSpec :: Sig Name -> TcM TcSpecPrag +tcImpSpec prag@(SpecSig (L _ name) _ _) + = do { id <- tcLookupId name + ; checkTc (isAnyInlinePragma (idInlinePragma id)) + (impSpecErr name) + ; tcSpec id prag } +tcImpSpec p = pprPanic "tcImpSpec" (ppr p) + +impSpecErr :: Name -> SDoc +impSpecErr name + = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) + 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") + , ptext (sLit "(or you compiled its definining module without -O)")]) -------------- -- 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) } +recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id]) +recoveryCode binder_names sig_fn + = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return (emptyBag, 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 + mk_dummy name + | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up + | otherwise = return (mkLocalId name forall_a_a) -- No signature forall_a_a :: TcType -forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) +forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) +\end{code} +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} --- 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)) +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) -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 (pprLHsBinds mbind) - where - msg | unlifted = ptext SLIT("bindings for unlifted types") - | otherwise = ptext SLIT("bang-pattern bindings") - -badStrictSig unlifted sig - = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) - 4 (ppr sig) - where - msg | unlifted = ptext SLIT("an unlifted binding") - | otherwise = ptext SLIT("a bang-pattern binding") -\end{code} + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. %************************************************************************ -%* * +%* * \subsection{tcMonoBind} -%* * +%* * %************************************************************************ @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. The signatures have been dealt with already. \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 scoped_tvs <- 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 name scoped_tvs - ; 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) } +tcMonoBinds :: TcSigFun -> LetBndrSpec + -> 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 + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [MonoBindInfo]) + +tcMonoBinds sig_fn no_gen is_rec + [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + -- Single function binding, + | NonRecursive <- is_rec -- ...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 inf matches) + + ; mono_id <- newNoSigLetBndr no_gen name 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, fun_tick = Nothing })), + [(name, Nothing, mono_id)]) } + +tcMonoBinds sig_fn no_gen _ binds + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) 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 $ do + traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + 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 +-- 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 +-- 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) +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo SrcSpan 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] + -- Type signature (if any), and + -- the monomorphic bound things 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 - -tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) - = do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names - ; mono_pat_binds <- doptM Opt_MonoPatBinds - -- With -fmono-pat-binds, we do no generalisation of pattern bindings - -- But the signature can still be polymoprhic! - -- data T = MkT (forall a. a->a) - -- x :: forall a. a->a - -- MkT x =