X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=2ec9de97a0068681314ab900c7ddfe297787e82b;hp=7db955162fb2122ecd2161db8a036eb492163266;hb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7db9551..2ec9de9 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,6 +19,7 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType import Type import TypeRep import HscTypes @@ -37,11 +38,14 @@ import Class 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 OccurAnal ( occurAnalyseExpr ) import Module import LazyUniqFM import UniqSupply @@ -52,7 +56,6 @@ import SrcLoc import DynFlags import Util import FastString -import BasicTypes (Arity) import Control.Monad import Data.List @@ -415,7 +418,7 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 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)) } @@ -630,7 +633,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; 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) @@ -884,7 +887,6 @@ tcIfaceExpr (IfaceCast expr co) = do 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') @@ -963,10 +965,14 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \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 }) } @@ -982,52 +988,62 @@ 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 +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 unsat_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkInlineRule unsat_ok expr arity) } + +tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) - - -- 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.) ; 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 + 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 -> 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 @@ -1122,6 +1138,8 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon 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 @@ -1198,7 +1216,7 @@ 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)