X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=e6f78b3eedc21ee63c414019888bf7777bda929d;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=16e80698b43fdb00dd6f5bfbff23561d7395bf4d;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 16e8069..e6f78b3 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -8,10 +8,10 @@ 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(..), @@ -20,30 +20,30 @@ import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..), TcIdOcc(..), TcIdBndr(..) ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) ) import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) ) import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds ) -import TcLoop ( tcGRHSsAndBinds ) +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 Maybes ( assocMaybe, catMaybes, Maybe(..) ) -import Outputable ( pprNonOp ) +import Name ( pprNonSym ) import PragmaInfo ( PragmaInfo(..) ) import Pretty import RnHsSyn ( RnName ) -- instances import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, mkSigmaTy, splitSigmaTy, splitRhoTy, mkForAllTy, splitForAllTy ) -import Util ( panic ) +import Util ( isIn, zipEqual, panic ) \end{code} %************************************************************************ @@ -209,10 +209,185 @@ tcBindAndSigs binder_rn_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) @@ -252,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} %************************************************************************ @@ -276,7 +451,7 @@ 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` \ sigma_ty' -> + tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> let (tyvars', theta', tau') = splitSigmaTy sigma_ty' in @@ -393,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 [] 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 @@ -405,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 @@ -472,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) @@ -506,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}