import TysWiredIn
import TysPrim ( anyTyConOfKind )
import Var ( TyVar )
+import BasicTypes ( nonRuleLoopBreaker )
import qualified Var
import VarEnv
import Name
import NameEnv
import OccurAnal ( occurAnalyseExpr )
+import Demand ( isBottomingSig )
import Module
-import LazyUniqFM
+import UniqFM
import UniqSupply
import Outputable
import ErrUtils
tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing
-
-tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
- ifIdDetails = details, ifIdInfo = info})
+tcIfaceDecl = tc_iface_decl NoParentTyCon
+
+tc_iface_decl :: TyConParent -- For nested declarations
+ -> Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
+ ifIdDetails = details, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkGlobalId details name ty info)) }
-tcIfaceDecl _ (IfaceData {ifName = occ_name,
+tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; 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 mb_fam_inst
+ ; mb_fam_inst <- tcFamInst mb_family
+ ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+ want_generic gadt_syn parent mb_fam_inst
})
; 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})
+tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
- { tc_name <- lookupIfaceTop occ_name
+ { 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 <- tcFamInst mb_family
- ; return (rhs, fam) }
- ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
- ; return $ ATyCon tycon
+ ; rhs <- forkM (mk_doc tc_name) $
+ tc_syn_rhs mb_rhs_ty
+ ; fam_info <- tcFamInst mb_family
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
+ ; return (ATyCon tycon)
}
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
- 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_rhs Nothing = return SynFamilyTyCon
+ tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
-tcIfaceDecl ignore_prags
+tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
- ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
- ; let ats = map (setAssocFamilyPermutation tyvars) ats'
- ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
+ ; cls <- fixM $ \ cls -> do
+ { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
+ ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
- IfOpenDataTyCon -> return mkOpenDataTyConRhs
+ IfOpenDataTyCon -> return DataFamilyTyCon
IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
- = ASSERT( isTupleTyCon tycon )
+ = ASSERT2( isTupleTyCon tycon, ppr tycon )
do { let [data_con] = tyConDataCons tycon
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
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 (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 (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf
- ; return (info `setUnfoldingInfoLazily` unf) }
+ 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}
tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ _ (IfCoreUnfold if_expr)
+tcUnfolding name _ info (IfCoreUnfold stable if_expr)
= do { mb_expr <- tcPragExpr name if_expr
+ ; let unf_src = if stable then InlineStable else InlineRhs
; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkTopUnfolding expr) }
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding unf_src
+ True {- Top level -}
+ is_bottoming expr) }
+ where
+ -- Strictness should occur before unfolding!
+ is_bottoming = case strictnessInfo info of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
-tcUnfolding name _ _ (IfInlineRule arity sat if_expr)
+tcUnfolding name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
- Just expr -> mkInlineRule inl_info expr arity) }
- where
- inl_info | sat = InlSat
- | otherwise = InlUnSat
+ 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 InlineStable expr arity
+ (UnfWhen unsat_ok boring_ok))
+ }
tcUnfolding name ty info (IfWrapper arity wkr)
= do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
(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)
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
- Just ops1 -> DFunUnfolding data_con ops1) }
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
- (_, cls, _) = tcSplitDFunTy dfun_ty
- data_con = classDataCon cls
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
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)
projects / ghc-hetmet.git / blobdiff