X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=7d5b01c00641dbf587d13f5b03cb883f198ec808;hb=12899612693163154531da3285ec99c1c8ca2226;hp=9ecbe7f330956cd047cf295f1c131f29c9a0608b;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 9ecbe7f..7d5b01c 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -8,41 +8,42 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where -import Ubiq +IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), - HsExpr, Match, PolyType, InPat, OutPat, + HsExpr, Match, PolyType, InPat, OutPat(..), GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, collectBinders ) -import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), - RenamedMonoBinds(..) ) -import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..), - TcIdOcc(..), TcIdBndr(..) ) +import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..), + SYN_IE(RenamedMonoBinds), RnName(..) + ) +import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds), + TcIdOcc(..), SYN_IE(TcIdBndr) ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) ) -import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) ) +import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) ) import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds ) -import TcLoop ( tcGRHSsAndBinds ) +import SpecEnv ( SpecEnv ) +IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcMatches ( tcMatchesFun ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTcTyVar, tcInstType ) +import TcType ( newTcTyVar, tcInstSigType ) import Unify ( unifyTauTy ) import Kind ( mkBoxedTypeKind, mkTypeKind ) import Id ( GenId, idType, mkUserId ) import IdInfo ( noIdInfo ) -import Name ( Name ) -- instances -import Maybes ( assocMaybe, catMaybes, Maybe(..) ) -import Outputable ( pprNonOp ) +import Maybes ( assocMaybe, catMaybes ) +import Name ( pprNonSym, Name ) import PragmaInfo ( PragmaInfo(..) ) import Pretty import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, mkSigmaTy, splitSigmaTy, splitRhoTy, mkForAllTy, splitForAllTy ) -import Util ( panic ) +import Util ( isIn, zipEqual, panic ) \end{code} %************************************************************************ @@ -177,12 +178,16 @@ tcBindAndThen combiner bind sigs do_next binder_names = collectBinders bind -tcBindAndSigs binder_names bind sigs prag_info_fn - = recoverTc ( +tcBindAndSigs binder_rn_names bind sigs prag_info_fn + = let + binder_names = map de_rn binder_rn_names + de_rn (RnName n) = n + in + recoverTc ( -- If typechecking the binds fails, then return with each -- binder given type (forall a.a), to minimise subsequent -- error messages - newTcTyVar Nothing mkBoxedTypeKind `thenNF_Tc` \ alpha_tv -> + newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv -> let forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) poly_ids = [ mkUserId name forall_a_a (prag_info_fn name) @@ -193,7 +198,7 @@ tcBindAndSigs binder_names bind sigs prag_info_fn -- Create a new identifier for each binder, with each being given -- a type-variable type. - newMonoIds binder_names kind (\ mono_ids -> + newMonoIds binder_rn_names kind (\ mono_ids -> tcTySigs sigs `thenTc` \ sig_info -> tc_bind bind `thenTc` \ (bind', lie) -> returnTc (mono_ids, bind', lie, sig_info) @@ -204,10 +209,185 @@ tcBindAndSigs binder_names bind sigs prag_info_fn genBinds binder_names mono_ids bind' lie sig_info prag_info_fn where kind = case bind of - NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types - RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types + NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types + RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types +\end{code} + + +=========== +\begin{code} +{- + +data SigInfo + = SigInfo RnName + (TcIdBndr s) -- Polymorpic version + (TcIdBndr s) -- Monomorphic verstion + [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version + + + + -- Deal with type signatures + tcTySigs sigs `thenTc` \ sig_infos -> + let + sig_binders = [binder | SigInfo binder _ _ _ _ <- sig_infos] + poly_sigs = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos] + mono_sigs = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos] + nosig_binders = binders `minusList` sig_binders + in + + + -- Typecheck the binding group + tcExtendLocalEnv poly_sigs ( + newMonoIds nosig_binders kind (\ nosig_local_ids -> + tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies -> + returnTc (nosig_local_ids, binds_w_lies) + )) `thenTc` \ (nosig_local_ids, binds_w_lies) -> + + + -- Decide what to generalise over + getImplicitStuffToGen sig_ids binds_w_lies + `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) -> + + + *** CHECK FOR UNBOXED TYVARS HERE! *** + + + + -- Make poly_ids for all the binders that don't have type signatures + let + tys_to_gen = mkTyVarTys tyvars_to_gen + dicts_to_gen = map instToId (bagToList lie_to_gen) + dict_tys = map tcIdType dicts_to_gen + + mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo + where + ty = mkForAllTys tyvars_to_gen $ + mkFunTys dict_tys $ + tcIdType local_id + + more_sig_infos = [ SigInfo binder (mk_poly binder local_id) + local_id tys_to_gen dicts_to_gen lie_to_gen + | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids + ] + + all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder + in + + + -- Now generalise the bindings + let + -- local_binds is a bunch of bindings of the form + -- f_mono = f_poly tyvars dicts + -- one for each binder, f, that lacks a type signature. + -- This bunch of bindings is put at the top of the RHS of every + -- binding in the group, so as to bind all the f_monos. + + local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen) + | local_id <- nosig_local_ids + ] + + find_sig lid = head [ (pid, tvs, ds, lie) + | SigInfo _ pid lid' tvs ds lie, + lid==lid' + ] + + gen_bind (bind, lie) + = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie + `thenTc` \ (lie_free, dict_binds) -> + returnTc (AbsBind tyvars_to_gen_here + dicts + (zipEqual "gen_bind" local_ids poly_ids) + (dict_binds ++ local_binds) + bind, + lie_free) + where + local_ids = bindersOf bind + local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos, + local_id `elem` local_ids + ] + + (tyvars_to_gen_here, dicts, avail) + = case (local_ids, sigs) of + + ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie]) + -> (tyvars_to_gen, dicts, lie) + + other -> (tyvars_to_gen, dicts, avail) \end{code} +@getImplicitStuffToGen@ decides what type variables +and LIE to generalise over. + +For a "restricted group" -- see the monomorphism restriction +for a definition -- we bind no dictionaries, and +remove from tyvars_to_gen any constrained type variables + +*Don't* simplify dicts at this point, because we aren't going +to generalise over these dicts. By the time we do simplify them +we may well know more. For example (this actually came up) + f :: Array Int Int + f x = array ... xs where xs = [1,2,3,4,5] +We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) +stuff. If we simplify only at the f-binding (not the xs-binding) +we'll know that the literals are all Ints, and we can just produce +Int literals! + +Find all the type variables involved in overloading, the "constrained_tyvars" +These are the ones we *aren't* going to generalise. +We must be careful about doing this: + (a) If we fail to generalise a tyvar which is not actually + constrained, then it will never, ever get bound, and lands + up printed out in interface files! Notorious example: + instance Eq a => Eq (Foo a b) where .. + Here, b is not constrained, even though it looks as if it is. + Another, more common, example is when there's a Method inst in + the LIE, whose type might very well involve non-overloaded + type variables. + (b) On the other hand, we mustn't generalise tyvars which are constrained, + because we are going to pass on out the unmodified LIE, with those + tyvars in it. They won't be in scope if we've generalised them. + +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} +getImplicitStuffToGen is_restricted sig_ids binds_w_lies + | isUnRestrictedGroup tysig_vars bind + = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, dicts_to_gen) -> + returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen) + + | otherwise + = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> + let + -- ASSERT: dicts_sig is already zonked! + constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts + reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars + in + returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE) + + where + sig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] + + (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2, + lie1 `plusLIE` lie2)) + get + (emptyTyVarSet, emptyLIE) + binds_w_lies + get (bind, lie) + = case bindersOf bind of + [local_id] | local_id `in` sig_ids -> -- A simple binding with + -- a type signature + (emptyTyVarSet, emptyLIE) + + local_ids -> -- Complex binding or no type sig + (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids, + lie) +-} +\end{code} + + + \begin{code} tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s) @@ -247,11 +427,11 @@ tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn) returnTc (PatMonoBind pat2 grhss_and_binds2 locn, plusLIE lie_pat lie) -tcMonoBinds (FunMonoBind name matches locn) +tcMonoBinds (FunMonoBind name inf matches locn) = tcAddSrcLoc locn $ tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id -> tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) -> - returnTc (FunMonoBind (TcId id) matches' locn, lie) + returnTc (FunMonoBind (TcId id) inf matches' locn, lie) \end{code} %************************************************************************ @@ -271,13 +451,15 @@ tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s] tcTySigs (Sig v ty _ src_loc : other_sigs) = tcAddSrcLoc src_loc ( tcPolyType ty `thenTc` \ sigma_ty -> - tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty -> + tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> let - (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty + (tyvars', theta', tau') = splitSigmaTy sigma_ty' in + tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val -> - unifyTauTy (idType val) tau_ty `thenTc_` - returnTc (TySigInfo val tyvars theta tau_ty src_loc) + unifyTauTy (idType val) tau' `thenTc_` + + returnTc (TySigInfo val tyvars' theta' tau' src_loc) ) `thenTc` \ sig_info1 -> tcTySigs other_sigs `thenTc` \ sig_infos -> @@ -386,7 +568,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Get and instantiate its alleged specialised type tcPolyType poly_ty `thenTc` \ sig_sigma -> - tcInstType [] (idType sig_sigma) `thenNF_Tc` \ sig_ty -> + tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty -> let (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty origin = ValSpecOrigin name @@ -398,7 +580,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Get and instantiate the type of the id mentioned tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id -> - tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty -> + tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty -> let (main_tyvars, main_rho) = splitForAllTy main_ty (main_theta,main_tau) = splitRhoTy main_rho @@ -407,8 +589,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Check that the specialised type is indeed an instance of -- the type of the main function. - unifyTauTy sig_tau main_tau `thenTc_` - checkSigTyVars sig_tyvars sig_tau main_tau `thenTc_` + unifyTauTy sig_tau main_tau `thenTc_` + checkSigTyVars sig_tyvars sig_tau `thenTc_` -- Check that the type variables of the polymorphic function are -- either left polymorphic, or instantiate to ground type. @@ -447,8 +629,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Check that it has the correct type, and doesn't constrain the -- signature variables at all - unifyTauTy sig_tau spec_tau `thenTc_` - checkSigTyVars sig_tyvars sig_tau spec_tau `thenTc_` + unifyTauTy sig_tau spec_tau `thenTc_` + checkSigTyVars sig_tyvars sig_tau `thenTc_` -- Make a local SpecId to bind to applied spec_id newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id -> @@ -465,8 +647,42 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) \end{code} -Error contexts and messages -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection[TcBinds-monomorphism]{The monomorphism restriction} +%* * +%************************************************************************ + +Not exported: + +\begin{code} +isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these + -> TcBind s + -> Bool + +isUnRestrictedGroup sigs EmptyBind = True +isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds +isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds + +is_elem v vs = isIn "isUnResMono" v vs + +isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs +isUnResMono sigs (PatMonoBind other _ _) = False +isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs +isUnResMono sigs (FunMonoBind _ _ _ _) = True +isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && + isUnResMono sigs mb2 +isUnResMono sigs EmptyMonoBinds = True +\end{code} + + +%************************************************************************ +%* * +\subsection[TcBinds-errors]{Error contexts and messages} +%* * +%************************************************************************ + + \begin{code} patMonoBindsCtxt bind sty = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind) @@ -499,7 +715,7 @@ specGroundnessCtxt valSpecSigCtxt v ty sty = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:")) - 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")), + 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")), ppr sty ty]) \end{code}