X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=b4c0d1afa81aa8e0f85fed8b59649dd26cb4c0ca;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hp=aa179b2842675bd6e8b6a0ad109a7fe9beb418eb;hpb=ba16e1bfde86cc6d8fafa9be8a33b3b6172f262f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index aa179b2..b4c0d1a 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,7 +6,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, - tcHsBootSigs, tcMonoBinds, + tcHsBootSigs, tcMonoBinds, tcPolyBinds, TcPragFun, tcSpecPrag, tcPrags, mkPragFun, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where @@ -165,26 +165,29 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- 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 + tcBindGroups poly_rec top_lvl sig_fn prag_fn binds thing_inside ; return (ValBindsOut binds' sigs, thing) } ------------------------ -tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun +tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -> [(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 _ _ _ _ [] thing_inside +tcBindGroups _ _ _ _ [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside +tcBindGroups 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 + tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ @@ -200,32 +203,36 @@ 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) } + = do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn + NonRecursive binds thing_inside + ; return ( [(NonRecursive, unitBag b) | b <- bagToList binds1] + ++ [(Recursive, lie_binds)] -- TcDictBinds have scrambled dependency order + , 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) } + = do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn + Recursive binds thing_inside + ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) } - | otherwise -- Recursive group, with gla-exts - = -- To maximise polymorphism (with -fglasgow-exts), we do a new + | otherwise -- Recursive group, with -XRelaxedPolyRec + = -- To maximise polymorphism (with -XRelaxedPolyRec), 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! + -- 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 $ + ; (binds1,lie_binds,thing) <- bindLocalInsts top_lvl $ go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)) - ; return ([(Recursive, unionManyBags binds1)], thing) } + ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) } -- Rec them all together where --- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], [TcId], thing) +-- 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 ++ binds2, ids1 ++ ids2, thing) } - go [] = do { thing <- thing_inside; return ([], [], thing) } + ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, [], thing) } tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind) tc_scc (CyclicSCC binds) = tc_sub_group Recursive (listToBag binds) @@ -233,17 +240,20 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside 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) + -> LHsBinds Name -> TcM a -> TcM (LHsBinds TcId, TcDictBinds, 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 - ; thing <- tcExtendIdEnv ids thing_inside - ; return (binds1, ids, thing) } + = bindLocalInsts top_lvl $ + do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds + ; thing <- tcExtendIdEnv ids thing_inside + ; return (binds1, ids, thing) } ------------------------ -bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a) +bindLocalInsts :: TopLevelFlag + -> TcM (LHsBinds TcId, [TcId], a) + -> TcM (LHsBinds TcId, TcDictBinds, a) bindLocalInsts top_lvl thing_inside - | isTopLevel top_lvl = do { (binds, _, thing) <- thing_inside; return (binds, thing) } + | 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 @@ -251,7 +261,7 @@ bindLocalInsts top_lvl thing_inside | otherwise -- Nested case = do { ((binds, ids, thing), lie) <- getLIE thing_inside ; lie_binds <- bindInstsOfLocalFuns lie ids - ; return (binds ++ [lie_binds], thing) } + ; return (binds, lie_binds, thing) } ------------------------ mkEdges :: TcSigFun -> LHsBinds Name @@ -286,7 +296,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> LHsBinds Name - -> TcM ([LHsBinds TcId], [TcId]) + -> TcM (LHsBinds TcId, [TcId]) -- Typechecks a single bunch of bindings all together, -- and generalises them. The bunch may be only part of a recursive @@ -331,7 +341,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds mk_export (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, []) -- ToDo: prags for unlifted bindings - ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds', [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked else do -- The normal lifted case: GENERALISE @@ -352,7 +362,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc 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 } } @@ -436,11 +446,11 @@ tcSpecPrag poly_id hs_ty inl -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages recoveryCode :: [Name] -> (Name -> Maybe [Name]) - -> TcM ([Bag (LHsBindLR Id Var)], [Id]) + -> TcM (LHsBinds TcId, [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) } + ; return (emptyBag, poly_ids) } where mk_dummy name | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up @@ -560,8 +570,14 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- Note that the scoped_tvs and the (sig_tvs sig) -- may have different Names. That's quite ok. + ; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig) ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ tcMatchesFun mono_name inf matches mono_ty + -- Note that "mono_ty" might actually be a polymorphic type, + -- if the original function had a signature like + -- forall a. Eq a => forall b. Ord b => .... + -- But that's ok: tcMatchesFun can deal with that + -- It happens, too! See Note [Polymorphic methods] in TcClassDcl. ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', @@ -1120,9 +1136,8 @@ tcInstSig :: Bool -> Name -> TcM TcSigInfo tcInstSig use_skols name = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into -- scope when starting the binding group - ; let skol_info = SigSkol (FunSigCtxt name) - inst_tyvars = tcInstSigTyVars use_skols skol_info - ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) + ; let skol_info = SigSkol (FunSigCtxt name) + ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau,