\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds, tcPolyBinds,
- TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
+ TcPragFun, tcPrags, mkPragFun,
TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
import TcPat
import TcMType
import TcType
-import {- Kind parts of -} Type
import Coercion
import VarEnv
import TysPrim
import ErrUtils
import Digraph
import Maybes
-import List
import Util
import BasicTypes
import Outputable
import FastString
+import Data.List( partition )
import Control.Monad
\end{code}
-- 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) }
+ ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= do { -- Typecheck the signature
- ; let { prag_fn = mkPragFun sigs
- ; ty_sigs = filter isVanillaLSig sigs
+ ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
+ ; ty_sigs = filter isTypeLSig sigs
; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
-- 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
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
= let
bind_list = bagToList binds
- binder_names = collectHsBindBinders binds
+ binder_names = collectHsBindsBinders binds
loc = getLoc (head bind_list)
-- TODO: location a bit awkward, but the mbinds have been
-- dependency analysed and may no longer be adjacent
; 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 (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, [])
- -- ToDo: prags for unlifted bindings
-
- ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
+ mk_export (name, mb_sig, mono_id) mono_ty
+ = ([], the_id, mono_id, noSpecPrags)
+ -- ToDo: prags for unlifted bindings
+ where
+ the_id = case mb_sig of
+ Just sig -> sig_id sig
+ Nothing -> mkLocalId name mono_ty
+
+ ; 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 (length mono_bind_infos > 1)
+ 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
+ -> Bool -- More than one variable is bound, so we'll desugar to
+ -- a tuple, so INLINE pragmas won't work
+ -> TcPragFun -> [TyVar] -> [TcType]
-> MonoBindInfo
- -> TcM ([TyVar], Id, Id, [LPrag])
+ -> TcM ([TyVar], Id, Id, TcSpecPrags)
-- mkExport generates exports with
-- zonked type variables,
-- zonked poly_ids
-- 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 multi_bind 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)
+ ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys)
+ 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, SpecPrags spec_prags) }
where
poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
------------------------
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 [LPrag]
-tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
+mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun
+mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
where
- tc_prag prag = addErrCtxt (pragSigCtxt prag) $
- tcPrag poly_id prag
-
-pragSigCtxt :: Sig Name -> SDoc
-pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
-
-tcPrag :: TcId -> Sig Name -> TcM Prag
+ prs = mapCatMaybes get_sig sigs
+
+ get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
+ get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl))
+ get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl))
+ get_sig _ = Nothing
+
+ add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
+ | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+ | otherwise = inl_prag
+
+ prag_env :: NameEnv [LSig Name]
+ prag_env = foldl add emptyNameEnv prs
+ add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
+
+ -- ar_env maps a local to the arity of its definition
+ ar_env :: NameEnv Arity
+ ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+ = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env -- PatBind/VarBind
+
+tcPrags :: RecFlag
+ -> Bool -- True <=> AbsBinds binds more than one variable
+ -> Bool -- True <=> function is overloaded
+ -> Id -> [LSig Name]
+ -> TcM (Id, [Located TcSpecPrag])
+-- Add INLINE and SPECLIASE pragmas
+-- INLINE prags are added to the (polymorphic) Id directly
+-- SPECIALISE prags are passed to the desugarer via TcSpecPrags
-- 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"
+tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs
+ = do { poly_id' <- tc_inl inl_sigs
+ ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs
-tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
-tcSpecPrag poly_id hs_ty inl
- = do { let name = idName poly_id
+-- Commented out until bytestring library removes redundant pragmas
+-- for packWith and unpackWith
+-- ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec
+
+ ; unless (null bad_sigs) warn_discarded_sigs
+
+ ; return (poly_id', spec_prags) }
+ where
+ (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs
+ (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs
+
+-- warn_discarded_spec = warnPrags poly_id spec_sigs $
+-- ptext (sLit "SPECIALISE pragmas for non-overloaded function")
+ warn_dup_inline = warnPrags poly_id inl_sigs $
+ ptext (sLit "Duplicate INLINE pragmas for")
+ warn_discarded_sigs = warnPrags poly_id bad_sigs $
+ ptext (sLit "Discarding unexpected pragmas for")
+
+ -----------
+ tc_inl [] = return poly_id
+ tc_inl (L loc (InlineSig _ prag) : other_inls)
+ = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+ ; return (poly_id `setInlinePragma` prag) }
+ tc_inl _ = panic "tc_inl"
+
+{- Earlier we tried to warn about
+ (a) INLINE for recursive function
+ (b) INLINE for function that is part of a multi-binder group
+ Code fragments below. But we want to allow
+ {-# INLINE f #-}
+ f x = x : g y
+ g y = ....f...f....
+ even though they are mutually recursive.
+ So I'm just omitting the warnings for now
+
+ | multi_bind && isInlinePragma prag
+ = do { setSrcSpan loc $ addWarnTc multi_bind_warn
+ ; return poly_id }
+ | otherwise
+ ; when (isInlinePragma prag && isRec rec_group)
+ (setSrcSpan loc (addWarnTc rec_inline_warn))
+
+ rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder")
+ <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded")
+
+ multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id))
+ 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") )
+-}
+
+
+warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
+warnPrags id bad_sigs herald
+ = addWarnTc (hang (herald <+> quotes (ppr id))
+ 2 (ppr_sigs bad_sigs))
+ where
+ ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
+
+--------------
+tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag
+tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl)
+ = addErrCtxt (spec_ctxt prag) $
+ 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
-
+ ; return (SpecPrag co_fn inl) }
+ where
+ spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig)
+
+
--------------
-- 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])
+ -> 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
(strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted mbind)
+ -- This should be a checkTc, not a warnTc, but as of GHC 6.11
+ -- the versions of alex and happy available have non-conforming
+ -- templates, so the GHC build fails if it's an error:
+ ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
+ ; warnTc (warnUnlifted && not bang_pat)
+ (unliftedMustBeBang mbind)
; mapM_ check_sig infos
; return True }
| otherwise
(badStrictSig unlifted sig)
check_sig _ = return ()
+unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
+unliftedMustBeBang mbind
+ = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
+ 4 (pprLHsBinds mbind)
+ $$ text "*** This will be an error in GHC 6.14! Fix your code now!"
+
strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
-- The returned [TyVar] are all ready to quantify
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
- | isMonoGroup dflags bind_list
+ | isMonoGroup dflags top_lvl bind_list sigs
= do { extendLIEs lie_req
; return ([], [], emptyBag) }
-- Post-condition: the returned Insts are full zonked
unifyCtxts [] = panic "unifyCtxts []"
unifyCtxts (sig1 : sigs) -- Argument is always non-empty
- = do { mapM unify_ctxt sigs
+ = do { traceTc $ text "unifyCtxts" <+> ppr (sig1 : sigs)
+ ; mapM_ unify_ctxt sigs
; theta <- zonkTcThetaType (sig_theta sig1)
; newDictBndrs (sig_loc sig1) theta }
where
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoercion cois)
+ checkTc (all isIdentityCoI cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
checkDistinctTyVars sig_tvs
= do { zonked_tvs <- mapM zonkSigTyVar sig_tvs
- ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
+ ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
; return zonked_tvs }
where
check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
-- Precondition: no duplicates
mkTcSigFun sigs = lookupNameEnv env
where
- env = mkNameEnv [(name, hsExplicitTvs lhs_ty)
- | L _ (TypeSig (L _ name) lhs_ty) <- sigs]
+ env = mkNameEnv (mapCatMaybes mk_pair sigs)
+ mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty)
+ mk_pair (L _ (IdSig id)) = Just (idName id, [])
+ mk_pair _ = Nothing
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
-- of nested type synonyms. See Note [More instantiated than scoped].)
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkLocalId name sigma_ty) }
+tcTySig (L _ (IdSig id))
+ = return id
tcTySig s = pprPanic "tcTySig" (ppr s)
-------------------
sig_loc = loc }) }
-------------------
-isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
+ -> [TcSigInfo] -> Bool
-- No generalisation at all
-isMonoGroup dflags binds
- = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+isMonoGroup dflags top_lvl binds sigs
+ = (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
+ || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
where
is_pat_bind (L _ (PatBind {})) = True
is_pat_bind _ = False
projects / ghc-hetmet.git / blobdiff