X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=2cfb1b2bcb63d589857c508472e81b4d204d3f4c;hb=9f592bb0ae0dc76bd3ec7729474057d2069bb4db;hp=9c176d0f94bd1f7bcb18151531acc5d48b0ad278;hpb=2423c249f5ca7785d0ec89eb33e72662da7561c1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9c176d0..2cfb1b2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,19 +6,16 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, - tcHsBootSigs, tcMonoBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, - TcSigInfo(..), TcSigFun, mkTcSigFun, - badBootDeclErr ) where - -#include "HsVersions.h" + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), TcSigFun, mkTcSigFun, + badBootDeclErr ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import DynFlags import HsSyn -import TcHsSyn import TcRnMonad import Inst @@ -30,11 +27,12 @@ import TcPat import TcMType import TcType import {- Kind parts of -} Type +import Coercion import VarEnv import TysPrim import Id import IdInfo -import Var ( TyVar ) +import Var hiding (mkLocalId) import Name import NameSet import NameEnv @@ -48,13 +46,16 @@ import List import Util import BasicTypes import Outputable +import FastString + +import Control.Monad \end{code} %************************************************************************ -%* * +%* * \subsection{Type-checking bindings} -%* * +%* * %************************************************************************ @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because @@ -84,153 +85,156 @@ 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 + -- 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 _, 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 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 isVanillaLSig 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 vanillaIdInfo) } + -- 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 { (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 - ; dict_binds <- tcSimplifyIPs avail_ips lie - ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } + -- 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) } 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')) + -- 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', ip_inst) <- newIPDict (IPBindOrigin ip) ip ty + expr' <- tcMonoExpr expr ty + return (ip_inst, (IPBind ip' expr')) ------------------------ 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 - ; gla_exts <- doptM Opt_GlasgowExts - ; (binds', thing) <- tcExtendIdEnv poly_ids $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn - binds thing_inside - - ; return (ValBindsOut binds' sigs, thing) } + = 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 + ; poly_rec <- doptM Opt_RelaxedPolyRec + ; (binds', thing) <- tcExtendIdEnv poly_ids $ + tc_val_binds poly_rec top_lvl sig_fn prag_fn + binds thing_inside + + ; return (ValBindsOut binds' sigs, thing) } ------------------------ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun - -> [(RecFlag, LHsBinds Name)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) + -> [(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 gla_exts top_lvl sig_fn prag_fn [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } +tc_val_binds _ _ _ _ [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } -tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { (group', (groups', thing)) - <- tc_group gla_exts top_lvl sig_fn prag_fn group $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside - ; return (group' ++ groups', thing) } +tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { (group', (groups', thing)) + <- tc_group poly_rec top_lvl sig_fn prag_fn group $ + tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } ------------------------ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun - -> (RecFlag, LHsBinds Name) -> TcM thing - -> TcM ([(RecFlag, LHsBinds TcId)], thing) + -> (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 gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside - -- A single non-recursive binding - -- We want to keep non-recursive things non-recursive +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) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside - ; return ([(NonRecursive, b) | b <- binds], thing) } - -tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside - | not gla_exts -- Recursive group, normal Haskell 98 route - = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside - ; return ([(Recursive, unionManyBags binds1)], thing) } - - | otherwise -- Recursive group, with gla-exts - = -- To maximise polymorphism (with -fglasgow-exts), we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- - -- Notice that the bindInsts thing covers *all* the bindings in the original - -- group at once; an earlier one may use a later one! - do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) - ; (binds1,thing) <- bindLocalInsts top_lvl $ - go (stronglyConnComp (mkEdges sig_fn binds)) - ; return ([(Recursive, unionManyBags binds1)], thing) } - -- Rec them all together + = do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside + ; return ([(NonRecursive, b) | b <- binds], thing) } + +tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + | not poly_rec -- Recursive group, normal Haskell 98 route + = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside + ; return ([(Recursive, unionManyBags binds1)], thing) } + + | otherwise -- Recursive group, with gla-exts + = -- To maximise polymorphism (with -fglasgow-exts), we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- + -- Notice that the bindInsts thing covers *all* the bindings in the original + -- group at once; an earlier one may use a later one! + do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) + ; (binds1,thing) <- bindLocalInsts top_lvl $ + go (stronglyConnComp (mkEdges sig_fn binds)) + ; return ([(Recursive, unionManyBags binds1)], thing) } + -- Rec them all together where -- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], [TcId], thing) - go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs - ; return (binds1 ++ binds2, ids1 ++ ids2, thing) } - go [] = do { thing <- thing_inside; return ([], [], thing) } + go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc + ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs + ; return (binds1 ++ binds2, ids1 ++ ids2, thing) } + go [] = do { thing <- thing_inside; return ([], [], thing) } tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind) tc_scc (CyclicSCC binds) = tc_sub_group Recursive (listToBag binds) tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive +tc_haskell98 :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag + -> LHsBinds Name -> TcM a -> TcM ([LHsBinds TcId], a) tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside = bindLocalInsts top_lvl $ do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds @@ -240,25 +244,25 @@ tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside ------------------------ bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a) bindLocalInsts top_lvl thing_inside - | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) } - -- 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 + | isTopLevel top_lvl = do { (binds, _, thing) <- thing_inside; return (binds, 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) <- getLIE thing_inside - ; lie_binds <- bindInstsOfLocalFuns lie ids - ; return (binds ++ [lie_binds], thing) } + | otherwise -- Nested case + = do { ((binds, ids, thing), lie) <- getLIE thing_inside + ; lie_binds <- bindInstsOfLocalFuns lie ids + ; return (binds ++ [lie_binds], thing) } ------------------------ mkEdges :: TcSigFun -> LHsBinds Name - -> [(LHsBind Name, BKey, [BKey])] + -> [(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,21 +271,23 @@ 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 -> TcSigFun -> TcPragFun - -> RecFlag -- Whether the group is really recursive - -> RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> LHsBinds Name - -> TcM ([LHsBinds TcId], [TcId]) + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> LHsBinds 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 @@ -295,68 +301,69 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds = let - bind_list = bagToList binds + bind_list = bagToList binds binder_names = collectHsBindBinders binds - loc = getLoc (head bind_list) - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent + 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 sig_fn) $ do + -- SET UP THE MAIN RECOVERY; take advantage of any type sigs + setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do - { traceTc (ptext SLIT("------------------------------------------------")) - ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + { traceTc (ptext (sLit "------------------------------------------------")) + ; traceTc (ptext (sLit "Bindings for") <+> ppr binder_names) - -- TYPECHECK THE BINDINGS + -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) - <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req)) - -- CHECK FOR UNLIFTED BINDINGS - -- These must be non-recursive etc, and are not generalised - -- They desugar to a case expression in the end + -- 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 + 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 + 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 (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, []) + -- ToDo: prags for unlifted bindings - ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], - [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked + ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked - else do -- The normal lifted case: GENERALISE + else do -- The normal lifted case: GENERALISE { dflags <- getDOpts ; (tyvars_to_gen, dicts, dict_binds) - <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req + <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ + generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req - -- BUILD THE POLYMORPHIC RESULT IDs - ; let dict_ids = map instToId dicts - ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids)) - mono_bind_infos + -- BUILD THE POLYMORPHIC RESULT IDs + ; let dict_vars = map instToVar dicts -- May include equality constraints + ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars)) + mono_bind_infos - ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids)) ; let abs_bind = L loc $ AbsBinds tyvars_to_gen - dict_ids exports - (dict_binds `unionBags` binds') + dict_vars exports + (dict_binds `unionBags` binds') - ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport + ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport } } -------------- -mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [Prag]) +mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] + -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [LPrag]) -- mkExport generates exports with --- zonked type variables, --- zonked poly_ids +-- 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. @@ -365,20 +372,24 @@ mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo -- Pre-condition: the inferred_tvs are already zonked -mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) - = do { (tvs, poly_id) <- mk_poly_id mb_sig +mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) + = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; let warn = isTopLevel top_lvl && warn_missing_sigs + ; (tvs, poly_id) <- mk_poly_id warn mb_sig + -- poly_id has a zonked type - ; poly_id' <- zonkId poly_id - ; prags <- tcPrags poly_id' (prag_fn poly_name) - -- tcPrags requires a zonked poly_id + ; prags <- tcPrags poly_id (prag_fn poly_name) + -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id', mono_id, prags) } + ; return (tvs, poly_id, mono_id, prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) - mk_poly_id Nothing = 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) } + mk_poly_id warn Nothing = do { poly_ty' <- zonkTcType poly_ty + ; missingSigWarn warn poly_name 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) } @@ -387,103 +398,108 @@ 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 + 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 [LPrag] +tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags where - tc_prag (L loc prag) = setSrcSpan loc $ - addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag + tc_prag prag = addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag -pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) +pragSigCtxt :: Sig Name -> SDoc +pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp -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) +tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl +tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec +tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) +tcPrag _ (FixSig {}) = panic "tcPrag FixSig" +tcPrag _ (TypeSig {}) = panic "tcPrag TypeSig" 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 (mkHsWrap 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 + = do { let name = idName poly_id + ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } + -- Most of the work of specialisation is done by + -- the desugarer, guided by the SpecPrag -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages +recoveryCode :: [Name] -> (Name -> Maybe [Name]) + -> TcM ([Bag (LHsBindLR Id Var)], [Id]) recoveryCode binder_names sig_fn - = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) - ; poly_ids <- mapM mk_dummy binder_names - ; return ([], poly_ids) } + = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return ([], poly_ids) } where mk_dummy name - | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up - | otherwise = return (mkLocalId name forall_a_a) -- No signature + | 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) -- 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)) +-- a) non-recursive, +-- b) not top level, +-- c) not a multiple-binding group (more or less implied by (a)) checkStrictBinds :: TopLevelFlag -> RecFlag - -> LHsBinds TcId -> [TcType] -> [MonoBindInfo] - -> TcM Bool + -> 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 } + = 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 () + (badStrictSig unlifted sig) + check_sig _ = return () +strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc strictBindErr flavour unlifted mbind - = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) - 4 (pprLHsBinds 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") + msg | unlifted = ptext (sLit "bindings for unlifted types") + | otherwise = ptext (sLit "bang-pattern bindings") +badStrictSig :: Bool -> TcSigInfo -> SDoc badStrictSig unlifted sig - = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) - 4 (ppr 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") + msg | unlifted = ptext (sLit "an unlifted binding") + | otherwise = ptext (sLit "a bang-pattern binding") \end{code} %************************************************************************ -%* * +%* * \subsection{tcMonoBind} -%* * +%* * %************************************************************************ @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. @@ -491,105 +507,108 @@ 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]) + -> 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, fun_tick = Nothing })), - [(name, Nothing, mono_id)]) } + 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 inf 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, fun_tick = Nothing })), + [(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, - fun_tick = Nothing } - ; 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) } + fun_matches = matches })] + sig_fn -- Single function binding + _ + | 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 + ; 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) <- scoped_tvs `zip` sig_tvs tc_sig ] + -- See Note [More instantiated than scoped] + -- Note that the scoped_tvs and the (sig_tvs sig) + -- may have different Names. That's quite ok. + + ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ + tcMatchesFun mono_name inf 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, + fun_tick = Nothing } + ; return (unitBag (L b_loc fun_bind'), + [(name, Just tc_sig, mono_id)]) } + +tcMonoBinds binds sig_fn _ + = 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 $ do + traceTc (text "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 +data TcMonoBind -- Half completed; LHS done, RHS not done = TcFunBind MonoBindInfo (Located TcId) 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 + -- Type signature (if any), and + -- the monomorphic bound things bndrNames :: [MonoBindInfo] -> [Name] bndrNames mbi = [n | (n,_,_) <- mbi] @@ -599,68 +618,72 @@ 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) } + = 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 =