import IfaceEnv
import BuildTyCl
import TcRnMonad
-import TcType ( tcSplitSigmaTy )
+import TcType
import Type
import TypeRep
import HscTypes
import TyCon
import DataCon
import TysWiredIn
+import TysPrim ( anyTyConOfKind )
import Var ( TyVar )
+import BasicTypes ( nonRuleLoopBreaker )
import qualified Var
import VarEnv
import Name
import NameEnv
-import OccName
+import OccurAnal ( occurAnalyseExpr )
+import Demand ( isBottomingSig )
import Module
-import LazyUniqFM
+import UniqFM
import UniqSupply
import Outputable
import ErrUtils
import DynFlags
import Util
import FastString
-import BasicTypes (Arity)
import Control.Monad
import Data.List
-import Data.Maybe
\end{code}
This module takes
ifRec = is_rec,
ifGeneric = want_generic,
ifFamInst = mb_family })
- = do { tc_name <- lookupIfaceTop occ_name
- ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
-
- { tycon <- fixM ( \ tycon -> do
+ = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+ { tc_name <- lookupIfaceTop occ_name
+ ; tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; famInst <-
- case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
- do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
- }
+ ; mb_fam_inst <- tcFamInst mb_family
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn famInst
+ cons is_rec want_generic gadt_syn mb_fam_inst
})
- ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
- ; return (ATyCon tycon)
- }}
+ ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+ ; return (ATyCon tycon) }
tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = mb_rhs_ty,
ifSynKind = kind, ifFamInst = mb_family})
- = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+ = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
; ~(rhs, fam) <- forkM (mk_doc tc_name) $
do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
- ; fam <- tc_syn_fam mb_family
+ ; fam <- tcFamInst mb_family
; return (rhs, fam) }
; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
; return $ ATyCon tycon
tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing)
tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
- tc_syn_fam Nothing
- = return Nothing
- tc_syn_fam (Just (fam, tys))
- = do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys) }
tcIfaceDecl ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
+tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type]))
+tcFamInst Nothing = return Nothing
+tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
+
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
; let mb_tcs = map ifTopFreeName args
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
- ru_rhs = rhs',
+ ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_local = False }) } -- An imported RULE is never for a local Id
-- or, even if it is (module loop, perhaps)
tcIfaceExpr (IfaceNote note expr) = do
expr' <- tcIfaceExpr expr
case note of
- IfaceInlineMe -> return (Note InlineMe expr')
IfaceSCC cc -> return (Note (SCC cc) expr')
IfaceCoreNote n -> return (Note (CoreNote n) expr')
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
-tcIdDetails _ IfDFunId = return DFunId
-tcIdDetails ty (IfRecSelId naughty)
- = return (RecSelId { sel_tycon = tc, sel_naughty = naughty })
+tcIdDetails ty IfDFunId
+ = return (DFunId (isNewTyCon (classTyCon cls)))
where
- (_, _, tau) = tcSplitSigmaTy ty
- tc = tyConAppTyCon (funArgTy tau)
- -- A bit fragile. Relies on the selector type looking like
- -- forall abc. (stupid-context) => T a b c -> blah
+ (_, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
+ = do { tc' <- tcIfaceTyCon tc
+ ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info
init_info = vanillaIdInfo
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
- tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
- tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
- tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str)
+ tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
+ tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
-- The next two are lazy, so they don't transitively suck stuff in
- tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
- tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
- tcPrag info (HsUnfold expr) = do
- maybe_expr' <- tcPragExpr name expr
- let
- -- maybe_expr' doesn't get looked at if the unfolding
- -- is never inspected; so the typecheck doesn't even happen
- unfold_info = case maybe_expr' of
- Nothing -> noUnfolding
- Just expr' -> mkTopUnfolding expr'
- return (info `setUnfoldingInfoLazily` unfold_info)
+ tcPrag info (HsUnfold lb if_unf)
+ = do { unf <- tcUnfolding name ty info if_unf
+ ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker
+ | otherwise = info
+ ; return (info1 `setUnfoldingInfoLazily` unf) }
\end{code}
\begin{code}
-tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo
-tcWorkerInfo ty info wkr arity
- = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding name _ info (IfCoreUnfold if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkTopUnfolding is_bottoming expr) }
+ where
+ -- Strictness should occur before unfolding!
+ is_bottoming = case strictnessInfo info of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
+
+tcUnfolding name _ _ (IfCompulsory if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCoreUnfolding True InlineRule expr arity
+ (UnfWhen unsat_ok boring_ok))
+ }
- -- We return without testing maybe_wkr_id, but as soon as info is
- -- looked at we will test it. That's ok, because its outside the
- -- knot; and there seems no big reason to further defer the
- -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
- -- over the unfolding until it's actually used does seem worth while.)
+tcUnfolding name ty info (IfWrapper arity wkr)
+ = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
; us <- newUniqueSupply
-
; return (case mb_wkr_id of
- Nothing -> info
- Just wkr_id -> add_wkr_info us wkr_id info) }
+ Nothing -> noUnfolding
+ Just wkr_id -> make_inline_rule wkr_id us) }
where
- doc = text "Worker for" <+> ppr wkr
- add_wkr_info us wkr_id info
- = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
- `setWorkerInfo` HasWorker wkr_id arity
+ doc = text "Worker for" <+> ppr name
- mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ make_inline_rule wkr_id us
+ = mkWwInlineRule wkr_id
+ (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ arity
- -- We are relying here on strictness info always appearing
- -- before worker info, fingers crossed ....
- strict_sig = case newStrictnessInfo info of
+ -- Again we rely here on strictness info always appearing
+ -- before unfolding
+ strict_sig = case strictnessInfo info of
Just sig -> sig
Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
+
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+ = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+ ; return (case mb_ops1 of
+ Nothing -> noUnfolding
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
+ where
+ doc = text "Class ops for dfun" <+> ppr name
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind
+ ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
bindIfaceBndrs bs $ \ bs' ->
thing_inside (b':bs')
+
-----------------------
tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
tcIfaceLetBndr (IfLetBndr fs ty info)
tc_info [] = vanillaIdInfo
tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p
tc_info (HsArity a : i) = tc_info i `setArityInfo` a
- tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s
+ tc_info (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s
tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo"
(ppr other) (tc_info i)
return (Var.mkCoVar name kind)
else
return (Var.mkTyVar name kind) }
-\end{code}
+
+bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+-- class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyVars_AT [] thing_inside
+ = thing_inside []
+bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
+ = bindIfaceTyVars_AT bs $ \ bs' ->
+ do { mb_tv <- lookupIfaceTyVar tv_occ
+ ; case mb_tv of
+ Just b' -> thing_inside (b':bs')
+ Nothing -> bindIfaceTyVar b $ \ b' ->
+ thing_inside (b':bs') }
+\end{code}