X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=ce668509705c64cf1942f43b2cba276026c9fc82;hb=8655d6ca41df4aa77a559d4067ad3815797b9803;hp=c2aeb1364f5fadc9b6e5a08924f5d06093ef9227;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index c2aeb13..ce66850 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,36 +4,34 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, - tcSpecSigs, tcBindWithSigs ) where +module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcExpr ) +import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), - Match(..), HsMatchContext(..), + Match(..), HsMatchContext(..), mkMonoBind, collectMonoBinders, andMonoBinds, collectSigTysFromMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) +import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) import TcRnMonad -import Inst ( InstOrigin(..), newDicts, instToId ) +import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) -import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts ) +import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, + tcSimplifyToDicts, tcSimplifyIPs ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars ) import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyVar, newTyVarTy, newHoleTyVarTy, - zonkTcTyVarToTyVar, readHoleResult - ) +import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar ) import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, mkPredTy, mkForAllTy, isUnLiftedType, unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind @@ -88,16 +86,25 @@ dictionaries, which we resolve at the module level. \begin{code} tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, 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 $ getLclEnv `thenM` \ env -> returnM (EmptyMonoBinds, env) where - glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing) + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive MonoBinds + glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env) + flatten EmptyBinds = EmptyMonoBinds + flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2 + flatten (MonoBind b _ _) = b + -- Can't have a IPBinds at top level tcBindsAndThen - :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator + :: (TcHsBinds -> thing -> thing) -- Combinator -> RenamedHsBinds -> TcM thing -> TcM thing @@ -114,6 +121,27 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next tc_binds_and_then top_lvl combiner b2 $ do_next +tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next + = getLIE do_next `thenM` \ (result, expr_lie) -> + mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, 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 (IPBinds binds' is_with) $ + combiner (mkMonoBind Recursive dict_binds) result) + where + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind (ip, expr) + = newTyVarTy openTypeKind `thenM` \ ty -> + getSrcLocM `thenM` \ loc -> + newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> + tcCheckRho expr ty `thenM` \ expr' -> + returnM (ip_inst, (ip', expr')) + tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE -- Notice that they scope over @@ -122,57 +150,57 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- c) the scope of the binding group (the "in" part) tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $ - -- TYPECHECK THE SIGNATURES - mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenM` \ tc_ty_sigs -> + tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - - getLIE ( - tcBindWithSigs top_lvl bind tc_ty_sigs - sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - - -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenM` \ prag_binds -> - - -- Now do whatever happens next, in the augmented envt - do_next `thenM` \ thing -> - - returnM (poly_ids, poly_binds, prag_binds, thing) - ) `thenM` \ ((poly_ids, poly_binds, prag_binds, thing), lie) -> - 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 + -- + -- Subtle (and ugly) point: furthermore at top level we + -- return the TcLclEnv, which contains the LIE var; we + -- don't want to return the wrong one! + -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> + returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) + thing) + + NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing + -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> - -- For the top level don't bother will all this bindInstsOfLocalFuns stuff - -- All the top level things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - TopLevel - -> extendLIEs lie `thenM_` - returnM (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing) - - NotTopLevel - -> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> -- Create specialisations of functions bound here + bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly if isRec is_rec then returnM ( - combiner Recursive ( + combiner (mkMonoBind Recursive ( poly_binds `andMonoBinds` lie_binds `andMonoBinds` - prag_binds) thing + prag_binds)) thing ) else returnM ( - combiner NonRecursive poly_binds $ - combiner NonRecursive prag_binds $ - combiner Recursive lie_binds $ + combiner (mkMonoBind NonRecursive poly_binds) $ + combiner (mkMonoBind NonRecursive prag_binds) $ + combiner (mkMonoBind Recursive lie_binds) $ -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns -- aren't guaranteed in dependency order (though we could change -- that); hence the Recursive marker. thing) + where + tc_body poly_ids -- Type check the pragmas and "thing inside" + = -- Extend the environment to bind the new polymorphic Ids + tcExtendLocalValEnv poly_ids $ + + -- Build bindings and IdInfos corresponding to user pragmas + tcSpecSigs sigs `thenM` \ prag_binds -> + + -- Now do whatever happens next, in the augmented envt + do_next `thenM` \ thing -> + + returnM (prag_binds, thing) \end{code} @@ -196,13 +224,18 @@ so all the clever stuff is in here. tcBindWithSigs :: TopLevelFlag -> RenamedMonoBinds - -> [TcSigInfo] -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs -> RecFlag -> TcM (TcMonoBinds, [TcId]) -tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec - = recoverM ( +tcBindWithSigs top_lvl mbind sigs is_rec + = -- TYPECHECK THE SIGNATURES + recoverM (returnM []) ( + mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] + ) `thenM` \ tc_ty_sigs -> + + -- SET UP THE MAIN RECOVERY; take advantage of any type sigs + recoverM ( -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise subsequent -- error messages @@ -215,12 +248,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec Just sig -> tcSigPolyId sig -- Signature Nothing -> mkLocalId name forall_a_a -- No signature in + traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_` returnM (EmptyMonoBinds, poly_ids) ) $ -- TYPECHECK THE BINDINGS - getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', binder_names, mono_ids), lie_req) -> + getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> let + (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids in @@ -256,10 +291,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec poly_ids = [poly_id | (_, poly_id, _) <- exports] dict_tys = map idType zonked_dict_ids - inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs] + inlines = mkNameSet [name | InlineSig True name _ loc <- sigs] -- Any INLINE sig (regardless of phase control) -- makes the RHS look small - inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, + inline_phases = listToFM [(name, phase) | InlineSig _ 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 @@ -584,91 +619,86 @@ The signatures have been dealt with already. \begin{code} tcMonoBinds :: RenamedMonoBinds - -> [TcSigInfo] - -> RecFlag + -> [TcSigInfo] -> RecFlag -> TcM (TcMonoBinds, - [Name], -- Bound names - [TcId]) -- Corresponding monomorphic bound things + Bag (Name, -- Bound names + TcId)) -- Corresponding monomorphic bound things tcMonoBinds mbinds tc_ty_sigs is_rec - = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) -> - let - id_list = bagToList ids - (names, mono_ids) = unzip id_list - - -- This last defn is the key one: - -- extend the val envt with bindings for the - -- things bound in this group, overriding the monomorphic - -- ids with the polymorphic ones from the pattern - extra_val_env = case is_rec of - Recursive -> map mk_bind id_list - NonRecursive -> [] - in - -- Don't know how to deal with pattern-bound existentials yet - checkTc (isEmptyBag tvs && null lie_avail) - (existentialExplode mbinds) `thenM_` - - -- *Before* checking the RHSs, but *after* checking *all* the patterns, - -- extend the envt with bindings for all the bound ids; - -- and *then* override with the polymorphic Ids from the signatures - -- That is the whole point of the "complete_it" stuff. - -- - -- There's a further wrinkle: we have to delay extending the environment - -- until after we've dealt with any pattern-bound signature type variables - -- Consider f (x::a) = ...f... - -- We're going to check that a isn't unified with anything in the envt, - -- so f itself had better not be! So we pass the envt binding f into - -- complete_it, which extends the actual envt in TcMatches.tcMatch, after - -- dealing with the signature tyvars - - complete_it extra_val_env `thenM` \ mbinds' -> - - returnM (mbinds', names, mono_ids) + -- Three stages: + -- 1. Check the patterns, building up an environment binding + -- the variables in this group (in the recursive case) + -- 2. Extend the environment + -- 3. Check the RHSs + = tc_mb_pats mbinds `thenM` \ (complete_it, xve) -> + tcExtendLocalValEnv2 (bagToList xve) complete_it where - - mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of - Nothing -> (name, mono_id) - Just sig -> (idName poly_id, poly_id) - where - poly_id = tcSigPolyId sig - - tc_mb_pats EmptyMonoBinds - = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, []) + tc_mb_pats EmptyMonoBinds + = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag) tc_mb_pats (AndMonoBinds mb1 mb2) - = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) -> - tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) -> + = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) -> + tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) -> let - complete_it xve = complete_it1 xve `thenM` \ mb1' -> - complete_it2 xve `thenM` \ mb2' -> - returnM (AndMonoBinds mb1' mb2') + complete_it = complete_it1 `thenM` \ (mb1', bs1) -> + complete_it2 `thenM` \ (mb2', bs2) -> + returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2) in - returnM (complete_it, - tvs1 `unionBags` tvs2, - ids1 `unionBags` ids2, - lie_avail1 ++ lie_avail2) + returnM (complete_it, xve1 `unionBags` xve2) tc_mb_pats (FunMonoBind name inf matches locn) - = (case maybeSig tc_ty_sigs name of - Just sig -> returnM (tcSigMonoId sig) - Nothing -> newLocalName name `thenM` \ bndr_name -> - newTyVarTy openTypeKind `thenM` \ bndr_ty -> - -- NB: not a 'hole' tyvar; since there is no type - -- signature, we revert to ordinary H-M typechecking - -- which means the variable gets an inferred tau-type - returnM (mkLocalId bndr_name bndr_ty) - ) `thenM` \ bndr_id -> + -- Three cases: + -- a) Type sig supplied + -- b) No type sig and recursive + -- c) No type sig and non-recursive + + | Just sig <- maybeSig tc_ty_sigs name + = let -- (a) There is a type signature + -- Use it for the environment extension, and check + -- the RHS has the appropriate type (with outer for-alls stripped off) + mono_id = tcSigMonoId sig + mono_ty = idType mono_id + complete_it = addSrcLoc locn $ + tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) + in + returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId sig) + else emptyBag) + + | isRec is_rec + = -- (b) No type signature, and recursive + -- So we must use an ordinary H-M type variable + -- which means the variable gets an inferred tau-type + newLocalName name `thenM` \ mono_name -> + newTyVarTy openTypeKind `thenM` \ mono_ty -> let - bndr_ty = idType bndr_id - complete_it xve = addSrcLoc locn $ - tcMatchesFun xve name bndr_ty matches `thenM` \ matches' -> - returnM (FunMonoBind bndr_id inf matches' locn) + mono_id = mkLocalId mono_name mono_ty + complete_it = addSrcLoc locn $ + tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) in - returnM (complete_it, emptyBag, unitBag (name, bndr_id), []) - + returnM (complete_it, unitBag (name, mono_id)) + + | otherwise -- (c) No type signature, and non-recursive + = let -- So we can use a 'hole' type to infer a higher-rank type + complete_it + = addSrcLoc locn $ + newHole `thenM` \ hole -> + tcMatchesFun name matches (Infer hole) `thenM` \ matches' -> + readMutVar hole `thenM` \ fun_ty -> + newLocalName name `thenM` \ mono_name -> + let + mono_id = mkLocalId mono_name fun_ty + in + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) + in + returnM (complete_it, emptyBag) + tc_mb_pats bind@(PatMonoBind pat grhss locn) = addSrcLoc locn $ - newHoleTyVarTy `thenM` \ pat_ty -> -- Now typecheck the pattern -- We do now support binding fresh (not-already-in-scope) scoped @@ -678,16 +708,21 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- The type variables are brought into scope in tc_binds_and_then, -- so we don't have to do anything here. - tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> - readHoleResult pat_ty `thenM` \ pat_ty' -> + newHole `thenM` \ hole -> + tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) -> + readMutVar hole `thenM` \ pat_ty -> + + -- Don't know how to deal with pattern-bound existentials yet + checkTc (isEmptyBag tvs && null lie_avail) + (existentialExplode bind) `thenM_` + let - complete_it xve = addSrcLoc locn $ - addErrCtxt (patMonoBindsCtxt bind) $ - tcExtendLocalValEnv2 xve $ - tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' -> - returnM (PatMonoBind pat' grhss' locn) + complete_it = addSrcLoc locn $ + addErrCtxt (patMonoBindsCtxt bind) $ + tcGRHSs PatBindRhs grhss (Check pat_ty) `thenM` \ grhss' -> + returnM (PatMonoBind pat' grhss' locn, ids) in - returnM (complete_it, tvs, ids, lie_avail) + returnM (complete_it, if isRec is_rec then ids else emptyBag) -- tc_pat_bndr is used when dealing with a LHS binder in a pattern. -- If there was a type sig for that Id, we want to make it much @@ -699,9 +734,8 @@ tcMonoBinds mbinds tc_ty_sigs is_rec tc_pat_bndr name pat_ty = case maybeSig tc_ty_sigs name of - Nothing - -> newLocalName name `thenM` \ bndr_name -> - tcMonoPatBndr bndr_name pat_ty + Nothing -> newLocalName name `thenM` \ bndr_name -> + tcMonoPatBndr bndr_name pat_ty Just sig -> addSrcLoc (getSrcLoc name) $ tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn -> @@ -764,7 +798,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time - getLIE (tcExpr (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> + getLIE (tcCheckSigma (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> -- Squeeze out any Methods (see comments with tcSimplifyToDicts) tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->