import IfaceEnv
import BuildTyCl
import TcRnMonad
+import TcType
import Type
import TypeRep
import HscTypes
import VarEnv
import Name
import NameEnv
+import OccurAnal ( occurAnalyseExpr )
import Module
import LazyUniqFM
import UniqSupply
import DynFlags
import Util
import FastString
-import BasicTypes (Arity)
import Control.Monad
import Data.List
ifIdDetails = details, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
- ; details <- tcIdDetails details
+ ; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkGlobalId details name ty info)) }
; 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 :: IfaceIdDetails -> IfL IdDetails
-tcIdDetails IfVanillaId = return VanillaId
-tcIdDetails IfDFunId = return DFunId
-tcIdDetails (IfRecSelId tc naughty)
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _ IfVanillaId = return VanillaId
+tcIdDetails ty IfDFunId
+ = return (DFunId (isNewTyCon (classTyCon cls)))
+ where
+ (_, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
= do { tc' <- tcIfaceTyCon tc
; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
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 `setAllStrictnessInfo` 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 if_unf) = do { unf <- tcUnfolding name ty info if_unf
+ ; return (info `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 _ _ (IfCoreUnfold if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkTopUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity sat 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
- -- 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
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 -> DFunUnfolding data_con 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
projects / ghc-hetmet.git / blobdiff