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 )
import TysPrim ( alphaTyVars )
import BasicTypes ( Arity, Activation(..), StrictnessMark,
RecFlag(..), boolToRecFlag, Boxity(..),
- tupleParens )
+ isAlwaysActive, tupleParens )
import Outputable
import FastString
import Maybes ( catMaybes )
| 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 ...
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.
--------------------------------
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
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
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)
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")
(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
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
------------ 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 -- The CoreTidy phase retains unfolding info iff
- || has_worker = Nothing -- we want to expose the unfolding, taking into account
- -- unconditional NOINLINE, etc. See TidyPgm.addExternal
- | 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
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
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)
| 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}
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)
-----------------
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
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
\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
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
projects / ghc-hetmet.git / blobdiff