import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
- getIdSpecialisation
+ idSpecialisation
)
import Var ( isId )
import VarSet
arityInfo, ppArityInfo, arityLowerBound,
strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
- cprInfo, ppCprInfo,
- workerExists, workerInfo, ppWorkerInfo
+ cprInfo, ppCprInfo, pprInlinePragInfo,
+ occInfo, OccInfo(..),
+ workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
-import CoreUnfold ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline )
+import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
import Module ( moduleString, pprModule, pprModuleName )
import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
Name, NamedThing(..)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons
)
-import Class ( Class, classBigSig )
+import Class ( Class, classExtraBigSig )
import FieldLabel ( fieldLabelName, fieldLabelType )
-import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
- Type, ThetaType
+import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
+ deNoteType, classesToPreds,
+ Type, ThetaType, PredType(..), ClassContext
)
import PprType
import PprCore ( pprIfaceUnfolding, pprCoreRule )
+import FunDeps ( pprFundeps )
import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
import Bag ( bagToList, isEmptyBag )
@ifaceExportList@ produces the @__exports__@ section; it appends
to the handle provided by @startIface@.
+NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file,
+so you have to keep it in synch with the code below. Otherwise you'll
+lose the happiest years of your life, believe me... -- SUP
+
\begin{code}
startIface :: Module -> InterfaceDetails
-> IO (Maybe Handle) -- Nothing <=> don't do an interface
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
-> [ProtoCoreRule] -- Rules
+ -> [Deprecation Name]
-> IO ()
endIface :: Maybe Handle -> IO ()
\end{code}
\begin{code}
-startIface mod (has_orphans, import_usages, ExportEnv avails fixities)
+startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _)
= case opt_ProduceHi of
Nothing -> return Nothing ; -- not producing any .hi file
\begin{code}
-ifaceDecls Nothing tycons classes inst_info final_ids simplified rules = return ()
+ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return ()
ifaceDecls (Just hdl)
tycons classes
inst_infos
- final_ids binds
+ final_ids
+ binds
orphan_rules -- Rules defined locally for an Id that is *not* defined locally
+ deprecations
| null_decls = return ()
-- You could have a module with just (re-)exports/instances in it
| otherwise
ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids)
final_ids binds >>= \ emitted_ids ->
ifaceRules hdl orphan_rules emitted_ids >>
- return ()
+ ifaceDeprecations hdl deprecations
where
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| ProtoCoreRule _ _ rule <- orphan_rules]
- null_decls = null binds &&
- null tycons &&
- null classes &&
- isEmptyBag inst_infos &&
- null orphan_rules
+ null_decls = null binds &&
+ null tycons &&
+ null classes &&
+ isEmptyBag inst_infos &&
+ null orphan_rules &&
+ null deprecations
\end{code}
\begin{code}
+ifaceImports :: Handle -> VersionInfo Name -> IO ()
ifaceImports if_hdl import_usages
= hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
where
- upp_uses (m, mv, has_orphans, whats_imported)
+ upp_uses (m, mv, has_orphans, is_boot, whats_imported)
= hsep [ptext SLIT("import"), pprModuleName m,
- int mv, pp_orphan,
+ int mv, pp_orphan, pp_boot,
upp_import_versions whats_imported
] <> semi
where
pp_orphan | has_orphans = ptext SLIT("!")
| otherwise = empty
+ pp_boot | is_boot = ptext SLIT("@")
+ | otherwise = empty
-- Importing the whole module is indicated by an empty list
upp_import_versions Everything = empty
upp_import_versions (Specifically nvs)
= dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]
+{- SUP: What's this??
ifaceModuleDeps if_hdl [] = return ()
ifaceModuleDeps if_hdl mod_deps
= let
in
printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
hPutStr if_hdl "\n"
+-}
+ifaceExports :: Handle -> Avails -> IO ()
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
= hPutCol if_hdl do_one_module (fmToList export_fm)
hsep (map upp_avail (sortLt lt_avail avails))
] <> semi
+ifaceFixities :: Handle -> Fixities -> IO ()
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities
= hPutCol if_hdl upp_fixity fixities
+ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO ()
ifaceRules if_hdl rules emitted
- | null orphan_rule_pretties && null local_id_pretties
+ | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing
+ -- interface pragmas
+ || (null orphan_rule_pretties && null local_id_pretties)
= return ()
| otherwise
- = do printForIface if_hdl (vcat [
+ = printForIface if_hdl (vcat [
ptext SLIT("{-## __R"),
-
vcat orphan_rule_pretties,
-
vcat local_id_pretties,
-
ptext SLIT("##-}")
- ])
-
- return ()
+ ])
where
- orphan_rule_pretties = [ pprCoreRule (Just fn) rule <+> semi
+ orphan_rule_pretties = [ pprCoreRule (Just fn) rule
| ProtoCoreRule _ fn rule <- rules
]
- local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi
+ local_id_pretties = [ pprCoreRule (Just fn) rule
| fn <- varSetElems emitted,
- rule <- rulesRules (getIdSpecialisation fn),
+ rule <- rulesRules (idSpecialisation fn),
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
- -- Spit out a rule only if all its lhs free vars are eemitted
+ -- Spit out a rule only if all its lhs free vars are emitted
+ -- This is a good reason not to do it when we emit the Id itself
]
+
+ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
+ifaceDeprecations if_hdl [] = return ()
+ifaceDeprecations if_hdl deprecations
+ = printForIface if_hdl (vcat [
+ ptext SLIT("{-## __D"),
+ vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ],
+ ptext SLIT("##-}")
+ ])
+ where
+ pprIE (IEVar n ) = ppr n
+ pprIE (IEThingAbs n ) = ppr n
+ pprIE (IEThingAll n ) = hcat [ppr n, text "(..)"]
+ pprIE (IEThingWith n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns)))
+ pprIE (IEModuleContents _ ) = empty
\end{code}
%************************************************************************
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
- forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
+ forall_ty = mkSigmaTy tvs (classesToPreds theta)
+ (deNoteType (mkDictTy clas tys))
renumbered_ty = tidyTopType forall_ty
in
hcat [ptext SLIT("instance "), pprType renumbered_ty,
work_info = workerInfo core_idinfo
has_worker = workerExists work_info
wrkr_pretty = ppWorkerInfo work_info
- Just work_id = work_info
+ HasWorker work_id wrap_arity = work_info
+
+ ------------ Occ info --------------
+ loop_breaker = case occInfo core_idinfo of
+ IAmALoopBreaker -> True
+ other -> False
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
dont_inline = case inline_pragma of
- IMustNotBeINLINEd -> True
- IAmALoopBreaker -> True
- other -> False
+ IMustNotBeINLINEd False Nothing -> True -- Unconditional NOINLINE
+ other -> False
+
- unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs
+ unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
| otherwise = empty
show_unfold = not has_worker && -- Not unnecessary
not bottoming_fn && -- Not necessary
not dont_inline &&
+ not loop_breaker &&
rhs_is_small && -- Small enough
okToUnfoldInHiFile rhs -- No casms etc
- rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
+ rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
------------ Specialisations --------------
spec_info = specInfo core_idinfo
------------ Sanity checking --------------
-- The arity of a wrapper function should match its strictness,
-- or else an importing module will get very confused indeed.
- arity_matches_strictness
- = not has_worker ||
- case strict_info of
- StrictnessInfo ds _ -> length ds == arityLowerBound arity_info
- other -> True
+ arity_matches_strictness = not has_worker ||
+ wrap_arity == arityLowerBound arity_info
interestingId id = isId id && isLocallyDefined id &&
not (omitIfaceSigForId id)
%************************************************************************
\begin{code}
-ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons ))
+ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons))
ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))
for_iface_name name = isLocallyDefined name &&
ifaceTyCon tycon
| isAlgTyCon tycon
= hsep [ ptext keyword,
- ppr_decl_context (tyConTheta tycon),
+ ppr_decl_class_context (tyConTheta tycon),
ppr (getName tycon),
pprTyVarBndrs (tyConTyVars tycon),
ptext SLIT("="),
ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
- <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>")
+ <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
ifaceClass clas
= hsep [ptext SLIT("class"),
- ppr_decl_context sc_theta,
+ ppr_decl_class_context sc_theta,
ppr clas, -- Print the name
pprTyVarBndrs clas_tyvars,
+ pprFundeps clas_fds,
pp_ops,
semi
]
where
- (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
+ (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- pp_ops | null sel_ids = empty
- | otherwise = hsep [ptext SLIT("where"),
- braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
- ]
+ pp_ops | null op_stuff = empty
+ | otherwise = hsep [ptext SLIT("where"),
+ braces (hsep (punctuate semi (map ppr_classop op_stuff)))
+ ]
- ppr_classop sel_id maybe_defm
+ ppr_classop (sel_id, dm_id, explicit_dm)
= ASSERT( sel_tyvars == clas_tyvars)
hsep [ppr (getOccName sel_id),
- if maybeToBool maybe_defm then equals else empty,
+ if explicit_dm then equals else empty,
dcolon,
ppr op_ty
]
ppr_decl_context [] = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
+ppr_decl_class_context :: ClassContext -> SDoc
+ppr_decl_class_context [] = empty
+ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
+
pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files
pprIfaceTheta [] = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
+pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
+
+-- ZZ - not sure who uses this - i.e. whether IParams really show up or not
+-- (it's not used to print normal value signatures)
+pprIfacePred :: PredType -> SDoc
+pprIfacePred (Class clas tys) = pprConstraint clas tys
+pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty
+
+pprIfaceClasses :: ClassContext -> SDoc
+pprIfaceClasses [] = empty
+pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
\end{code}
%************************************************************************
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
-lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
+lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2
sort_versions vs = sortLt lt_vers vs