X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=a5b15f3cdd0a6e6c8d2b9ea709adfd52e43a295a;hb=d95ce839533391e7118257537044f01cbb1d6694;hp=ddf066b3d7b99152ab2c60e2a363f78aa078b57a;hpb=f16dbbbe59cf3aa19c5fd384560a1b89076d7bc8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ddf066b..a5b15f3 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 @@ -345,7 +352,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- 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)) + ; exports <- mapM (mkExport top_lvl rec_group prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] @@ -355,12 +362,12 @@ 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 } } -------------- -mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] +mkExport :: TopLevelFlag -> RecFlag -> TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo -> TcM ([TyVar], Id, Id, [LPrag]) -- mkExport generates exports with @@ -374,13 +381,13 @@ mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] -- Pre-condition: the inferred_tvs are already zonked -mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) +mkExport top_lvl rec_group 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 - ; prags <- tcPrags poly_id (prag_fn poly_name) + ; prags <- tcPrags rec_group poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id ; return (tvs, poly_id, mono_id, prags) } @@ -406,24 +413,34 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] 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 +tcPrags :: RecFlag -> Id -> [LSig Name] -> TcM [LPrag] +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcPrags rec_group poly_id prags = mapM tc_lprag prags where - tc_prag prag = addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag + tc_lprag :: LSig Name -> TcM LPrag + tc_lprag (L loc prag) = setSrcSpan loc $ + addErrCtxt (pragSigCtxt prag) $ + do { prag' <- tc_prag prag + ; return (L loc prag') } + + tc_prag (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl + tc_prag (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec + tc_prag (InlineSig _ inl) = do { warnIfRecInline rec_group inl poly_id + ; return (InlinePrag inl) } + tc_prag (FixSig {}) = panic "tcPrag FixSig" + tc_prag (TypeSig {}) = panic "tcPrag TypeSig" 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 _ 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" - +warnIfRecInline :: RecFlag -> InlineSpec -> TcId -> TcM () +warnIfRecInline rec_group (Inline _ is_inline) poly_id + | is_inline && isRec rec_group = addWarnTc warn + | otherwise = return () + where + warn = ptext (sLit "INLINE pragma for recursive binder") <+> quotes (ppr poly_id) + <+> ptext (sLit "may be discarded") tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag tcSpecPrag poly_id hs_ty inl @@ -439,11 +456,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