import CmdLineOpts
import Id ( idType, dataConRawArgTys, dataConFieldLabels,
- getIdInfo, getInlinePragma, omitIfaceSigForId,
+ idInfo, omitIfaceSigForId,
dataConStrictMarks, StrictnessMark(..),
IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet,
isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
- pprId,
+ pprId, getIdSpecialisation,
Id
-
)
-import IdInfo ( IdInfo, StrictnessInfo, ArityInfo,
+import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
bottomIsGuaranteed, workerExists,
)
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
-import FreeVars ( addExprFVs )
+import FreeVars ( exprFreeVars )
import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
OccName, occNameString, nameOccName, nameString, isExported,
Name {-instance NamedThing-}, Provenance, NamedThing(..)
tyConTheta, tyConTyVars, tyConDataCons
)
import Class ( Class, classBigSig )
+import SpecEnv ( specEnvToList )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy,
mkTyVarTys, Type, ThetaType
where
pp_double_semi = ptext SLIT(";;")
idinfo = get_idinfo id
- inline_pragma = getInlinePragma id
+ inline_pragma = inlinePragInfo idinfo
ty_pretty = pprType (nmbrGlobalType (idType id))
sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
prag_pretty
| opt_OmitInterfacePragmas = empty
- | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
+ | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty,
+ spec_pretty, pp_double_semi]
------------ Arity --------------
arity_pretty = ppArityInfo (arityInfo idinfo)
con_list = idSetToList wrapper_cons
------------ Unfolding --------------
- unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs]
+ unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
| otherwise = empty
- show_unfold = not implicit_unfolding && -- Not unnecessary
- not dodgy_unfolding -- Not dangerous
+ unfold_herald = case inline_pragma of
+ IMustBeINLINEd -> SLIT("_U_")
+ IWantToBeINLINEd -> SLIT("_U_")
+ other -> SLIT("_u_")
+
+ show_unfold = not implicit_unfolding && -- Not unnecessary
+ unfolding_is_ok -- Not dangerous
implicit_unfolding = has_worker ||
bottomIsGuaranteed strict_info
- dodgy_unfolding = case guidance of -- True <=> too big to show, or the Inline pragma
- UnfoldNever -> True -- says it shouldn't be inlined
- other -> False
-
- guidance = calcUnfoldingGuidance inline_pragma
- opt_InterfaceUnfoldThreshold
- rhs
-
+ unfolding_is_ok
+ = case inline_pragma of
+ IMustBeINLINEd -> True
+ IWantToBeINLINEd -> True
+ IDontWantToBeINLINEd -> False
+ IMustNotBeINLINEd -> False
+ NoPragmaInfo -> case guidance of
+ UnfoldNever -> False -- Too big
+ other -> True
+
+ guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
+
+ ------------ Specialisations --------------
+ spec_list = specEnvToList (getIdSpecialisation id)
+ spec_pretty = hsep (map pp_spec spec_list)
+ pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
+ if null tyvars then ptext SLIT("[ ]")
+ else brackets (interppSP tyvars),
+ -- The lexer interprets "[]" as a CONID. Sigh.
+ hsep (map pprParendType tys),
+ ptext SLIT("="),
+ pprIfaceUnfolding rhs
+ ]
------------ Extra free Ids --------------
new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
extra_ids | opt_OmitInterfacePragmas = emptyIdSet
| otherwise = worker_ids `unionIdSets`
- unfold_ids
+ unfold_ids `unionIdSets`
+ spec_ids
worker_ids | has_worker = unitIdSet work_id
| otherwise = emptyIdSet
- unfold_ids | show_unfold = free_vars
+ spec_ids = foldr add emptyIdSet spec_list
+ where
+ add (_, _, rhs) = unionIdSets (find_fvs rhs)
+
+ unfold_ids | show_unfold = find_fvs rhs
| otherwise = emptyIdSet
- where
- (_,free_vars) = addExprFVs interesting emptyIdSet rhs
- interesting bound id = isLocallyDefined id &&
- not (id `elementOfIdSet` bound) &&
- not (omitIfaceSigForId id)
+
+ find_fvs expr = free_vars
+ where
+ free_vars = exprFreeVars interesting expr
+ interesting id = isLocallyDefined id &&
+ not (omitIfaceSigForId id)
\end{code}
\begin{code}
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
get_idinfo id = case lookupUFM final_id_map id of
- Just id' -> getIdInfo id'
+ Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
- getIdInfo id
+ idInfo id
pretties = go needed_ids (reverse binds) -- Reverse so that later things will
-- provoke earlier ones to be emitted