#include "HsVersions.h"
import IfaceSyn
-import IfaceType
import LoadIface
import Id
import IdInfo
import RdrName
import NameEnv
import NameSet
-import OccName
import Module
import BinIface
import ErrUtils
import Binary
import Fingerprint
import Bag
-import Panic
import Control.Monad
import Data.List
data IfaceDeclExtras
= IfaceIdExtras Fixity [IfaceRule]
| IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
- | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
+ | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
+ | IfaceSynExtras Fixity
| IfaceOtherDeclExtras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
= unionManyNameSets (map freeNamesIfRule rules)
freeNamesDeclExtras (IfaceDataExtras _ _insts subs)
= unionManyNameSets (map freeNamesSub subs)
-freeNamesDeclExtras (IfaceClassExtras _insts subs)
+freeNamesDeclExtras (IfaceClassExtras _ _insts subs)
= unionManyNameSets (map freeNamesSub subs)
+freeNamesDeclExtras (IfaceSynExtras _)
+ = emptyNameSet
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
putByte bh 1; put_ bh fix; put_ bh rules
put_ bh (IfaceDataExtras fix insts cons) = do
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
- put_ bh (IfaceClassExtras insts methods) = do
- putByte bh 3; put_ bh insts; put_ bh methods
+ put_ bh (IfaceClassExtras fix insts methods) = do
+ putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
+ put_ bh (IfaceSynExtras fix) = do
+ putByte bh 4; put_ bh fix
put_ bh IfaceOtherDeclExtras = do
- putByte bh 4
+ putByte bh 5
declExtras :: (OccName -> Fixity)
-> OccEnv [IfaceRule]
(map IfaceInstABI $ lookupOccEnvL inst_env n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs} ->
- IfaceClassExtras
+ IfaceClassExtras (fix_fn n)
(map IfaceInstABI $ lookupOccEnvL inst_env n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
+ IfaceSyn{} -> IfaceSynExtras (fix_fn n)
_other -> IfaceOtherDeclExtras
where
n = ifName decl
-- Reason: Iface stuff uses OccNames, and the conversion here does
-- not do tidying on the way
tyThingToIfaceDecl (AnId id)
- = IfaceId { ifName = getOccName id,
- ifType = toIfaceType (idType id),
- ifIdInfo = info }
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType (idType id),
+ ifIdDetails = toIfaceIdDetails (idDetails id),
+ ifIdInfo = info }
where
info = case toIfaceIdInfo (idInfo id) of
[] -> NoInfo
ifaceConDecl data_con
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
+ ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
(tvs, fds) = classTvsFds cls
arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
orph | is_local cls_name = Just (nameOccName cls_name)
- | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns
+ | all isJust mb_ns = head mb_ns
| otherwise = Nothing
mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name
-- See Note [IdInfo on nested let-bindings] in IfaceSyn
id_info = idInfo id
inline_prag = inlinePragInfo id_info
- prag_info | isAlwaysActive inline_prag = NoInfo
- | otherwise = HasInfo [HsInline inline_prag]
+ prag_info | isDefaultInlinePragma inline_prag = NoInfo
+ | otherwise = HasInfo [HsInline inline_prag]
--------------------------
+toIfaceIdDetails :: IdDetails -> IfaceIdDetails
+toIfaceIdDetails VanillaId = IfVanillaId
+toIfaceIdDetails DFunId = IfVanillaId
+toIfaceIdDetails (RecSelId { sel_naughty = n
+ , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
+toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
+ IfVanillaId -- Unexpected
+
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
- inline_hsinfo, unfold_hsinfo]
+ inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
where
------------ Arity --------------
arity_info = arityInfo id_info
Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
_other -> Nothing
+ ------------ Worker --------------
+ work_info = workerInfo id_info
+ has_worker = workerExists work_info
+ wrkr_hsinfo = case work_info of
+ HasWorker work_id wrap_arity ->
+ Just (HsWorker ((idName work_id)) wrap_arity)
+ NoWorker -> Nothing
+
------------ Unfolding --------------
- unfold_hsinfo = fmap HsUnfold $ toIfUnfolding (unfoldingInfo id_info)
+ -- The unfolding is redundant if there is a worker
+ 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 rhs))
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
- inline_hsinfo | isAlwaysActive inline_prag = Nothing
- | isNothing unfold_hsinfo = Nothing
+ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
+ | no_unfolding && not has_worker
+ && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
+ = Nothing
-- If the iface file give no unfolding info, we
-- don't need to say when inlining is OK!
- | otherwise = Just (HsInline inline_prag)
-
---------------------------
-toIfUnfolding :: Unfolding -> Maybe IfaceUnfolding
-toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_guidance = guidance })
- = case guidance of
- UnfoldNever -> Nothing
- _ -> Just (IfCoreUnfold (toIfaceExpr rhs))
-toIfUnfolding (InlineRule { uf_worker = Just wkr, uf_arity = arity })
- = Just (IfWrapper arity (idName wkr))
-toIfUnfolding (InlineRule { uf_worker = Nothing, uf_tmpl = rhs, uf_arity = arity })
- = Just (IfInlineRule arity (toIfaceExpr rhs))
-toIfUnfolding _
- = Nothing
+ | otherwise = Just (HsInline inline_prag)
--------------------------
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
---------------------
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
+toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
projects / ghc-hetmet.git / blobdiff