From 901f574d7b472053cae3bece13c1e4dd31810667 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 10 Sep 2008 07:35:29 +0000 Subject: [PATCH] Simplify the type signature for tcPolyBinds --- compiler/typecheck/TcBinds.lhs | 53 +++++++++++++++++++++---------------- compiler/typecheck/TcClassDcl.lhs | 2 +- 2 files changed, 31 insertions(+), 24 deletions(-) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ddf066b..b4c0d1a 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -203,15 +203,19 @@ 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 + | 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. @@ -219,16 +223,16 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside -- 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) @@ -236,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 @@ -254,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 @@ -289,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 @@ -334,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 @@ -355,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 } } @@ -439,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 diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8fa2939..b36192c 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -271,7 +271,7 @@ tcMethodBind tyvars prags meth_id bind (unitBag bind) ; ASSERT( ids == [meth_id] ) -- Binding for ONE method - return (unionManyBags tc_binds) } + return tc_binds } \end{code} Note [Polymorphic methods] -- 1.7.10.4