-- 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.
-- 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)
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
| 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
-> 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
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
-- 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]
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
-- 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) }
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
-- 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
projects / ghc-hetmet.git / blobdiff