X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=8e92adce3b8b11b322ce9a84d6886bc9322aa216;hp=99501a5b68f0f385de6c4f930908f8f0dfe52c7c;hb=dfcf88523ec5988fbcaa2cbf812cc5862ad621cf;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 99501a5..8e92adc 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -27,7 +27,7 @@ module IfaceSyn ( -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfRule, + eqIfDecl, eqIfInst, eqIfRule, checkBootDecl, -- Pretty printing pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead @@ -56,9 +56,9 @@ import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCo import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, dataConTyCon, dataConIsInfix, isVanillaDataCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) -import OccName ( OccName, OccEnv, emptyOccEnv, - lookupOccEnv, extendOccEnv, parenSymOcc, +import OccName ( OccName, parenSymOcc, occNameFS, OccSet, unionOccSets, unitOccSet ) +import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) import Name ( Name, NamedThing(..), nameOccName, isExternalName ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) @@ -66,7 +66,7 @@ import ForeignCall ( ForeignCall ) import TysPrim ( alphaTyVars ) import BasicTypes ( Arity, Activation(..), StrictnessMark, RecFlag(..), boolToRecFlag, Boxity(..), - tupleParens ) + isAlwaysActive, tupleParens ) import Outputable import FastString import Maybes ( catMaybes ) @@ -109,7 +109,7 @@ data IfaceDecl | IfaceClass { ifCtxt :: IfaceContext, -- Context... ifName :: OccName, -- Name of the class ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep OccName], -- Functional dependencies + ifFDs :: [FunDep FastString], -- Functional dependencies ifSigs :: [IfaceClassOp], -- Method signatures ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? ifVrcs :: ArgVrcs -- ... and what are its argument variances ... @@ -189,7 +189,8 @@ data IfaceIdInfo data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig - | HsUnfold Activation IfaceExpr + | HsInline Activation + | HsUnfold IfaceExpr | HsNoCafRefs | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo -- for why we want arity here. @@ -200,13 +201,13 @@ data IfaceInfoItem -------------------------------- data IfaceExpr - = IfaceLcl OccName + = IfaceLcl FastString | IfaceExt IfaceExtName | IfaceType IfaceType | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] + | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceLit Literal @@ -214,11 +215,10 @@ data IfaceExpr data IfaceNote = IfaceSCC CostCentre | IfaceCoerce IfaceType - | IfaceInlineCall | IfaceInlineMe | IfaceCoreNote String -type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr) +type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) -- Note: OccName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context -- thus saving bulk in interface files @@ -410,7 +410,6 @@ pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args) instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty - ppr IfaceInlineCall = ptext SLIT("__inline_call") ppr IfaceInlineMe = ptext SLIT("__inline_me") ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) @@ -426,8 +425,9 @@ instance Outputable IfaceIdInfo where ppr NoInfo = empty ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") -ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag, - parens (pprIfaceExpr noParens unf)] +ppr_hs_info (HsUnfold unf) = ptext SLIT("Unfolding:") <+> + parens (pprIfaceExpr noParens unf) +ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs") @@ -481,7 +481,7 @@ tyThingToIfaceDecl ext (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) + toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2) tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon @@ -567,7 +567,7 @@ instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] toIfaceIdInfo ext id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] where ------------ Arity -------------- arity_info = arityInfo id_info @@ -596,12 +596,23 @@ toIfaceIdInfo ext id_info ------------ Unfolding -------------- -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) -------------------------- coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names @@ -641,15 +652,13 @@ toIfaceExpr ext (Lit l) = IfaceLit l toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) toIfaceExpr ext (App f a) = toIfaceApp ext f [a] --- gaw 2004 -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as) toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) --------------------- toIfaceNote ext (SCC cc) = IfaceSCC cc toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) -toIfaceNote ext InlineCall = IfaceInlineCall toIfaceNote ext InlineMe = IfaceInlineMe toIfaceNote ext (CoreNote s) = IfaceCoreNote s @@ -658,7 +667,7 @@ toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ex toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] --------------------- -toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) +toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r) --------------------- toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) @@ -694,7 +703,7 @@ toIfaceVar ext v | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) -- Foreign calls have special syntax | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (nameOccName name) + | otherwise = IfaceLcl (occNameFS (nameOccName name)) where name = idName v \end{code} @@ -723,6 +732,11 @@ bool :: Bool -> IfaceEq bool True = Equal bool False = NotEqual +toBool :: IfaceEq -> Bool +toBool Equal = True +toBool (EqBut _) = True +toBool NotEqual = False + zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information zapEq (EqBut _) = Equal zapEq other = other @@ -748,6 +762,43 @@ eqIfExt n1 n2 = NotEqual \begin{code} --------------------- +checkBootDecl :: IfaceDecl -- The boot decl + -> IfaceDecl -- The real decl + -> Bool -- True <=> compatible +checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _) + = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2) + +checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) + = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2 + +checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eq_ifType env (ifSynRhs d1) (ifSynRhs d2) + +checkBootDecl d1@(IfaceData {}) d2@(IfaceData {}) +-- We don't check the recursion flags because the boot-one is +-- recursive, to be conservative, but the real one may not be. +-- I'm not happy with the way recursive flags are dealt with. + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + case ifCons d1 of + IfAbstractTyCon -> Equal + cons1 -> eq_hsCD env cons1 (ifCons d2) + +checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {}) + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& + case (ifCtxt d1, ifSigs d1) of + ([], []) -> Equal + (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&& + eqListBy (eq_cls_sig env) sigs1 (ifSigs d2) + +checkBootDecl _ _ = False -- default case + +--------------------- eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2) = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2) @@ -791,7 +842,7 @@ eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq eqWith = eq_ifTvBndrs emptyEqEnv ----------------------- -eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) +eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2) -- All other changes are handled via the version info on the dfun eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) @@ -839,11 +890,12 @@ eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) ----------------- eqIfIdInfo NoInfo NoInfo = Equal eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2 -eqIfIdInfo i1 i2 = NotEqual +eqIfIdInfo i1 i2 = NotEqual +eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2) eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2) eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2) -eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2 +eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2 eq_item HsNoCafRefs HsNoCafRefs = Equal eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2) eq_item _ _ = NotEqual @@ -893,7 +945,6 @@ eq_ifaceConAlt _ _ = False eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2) eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2 -eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2) eq_ifaceNote env _ _ = NotEqual @@ -940,24 +991,24 @@ eqIfTc _ _ = NotEqual \begin{code} ------------------------------------ -type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables +type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables -eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq -eqIfOcc env n1 n2 = case lookupOccEnv env n1 of +eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq +eqIfOcc env n1 n2 = case lookupUFM env n1 of Just n1 -> bool (n1 == n2) Nothing -> bool (n1 == n2) -extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv +extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv extendEqEnv env n1 n2 | n1 == n2 = env - | otherwise = extendOccEnv env n1 n2 + | otherwise = addToUFM env n1 n2 emptyEqEnv :: EqEnv -emptyEqEnv = emptyOccEnv +emptyEqEnv = emptyUFM ------------------------------------ type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq -eq_ifNakedBndr :: ExtEnv OccName +eq_ifNakedBndr :: ExtEnv FastString eq_ifBndr :: ExtEnv IfaceBndr eq_ifTvBndr :: ExtEnv IfaceTvBndr eq_ifIdBndr :: ExtEnv IfaceIdBndr @@ -974,7 +1025,7 @@ eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env eq_ifBndrs :: ExtEnv [IfaceBndr] eq_ifIdBndrs :: ExtEnv [IfaceIdBndr] eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] -eq_ifNakedBndrs :: ExtEnv [OccName] +eq_ifNakedBndrs :: ExtEnv [FastString] eq_ifBndrs = eq_bndrs_with eq_ifBndr eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr