import RnEnv ( availName )
import TcInstUtil ( InstInfo(..) )
-import WorkWrap ( getWorkerId )
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
import Var ( isId )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
- arityInfo, ppArityInfo,
- strictnessInfo, ppStrictnessInfo,
+import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo,
+ arityInfo, ppArityInfo, arityLowerBound,
+ strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
- cprInfo, ppCprInfo,
- workerExists, workerInfo, isBottomingStrictness
+ cprInfo, ppCprInfo, pprInlinePragInfo,
+ occInfo, OccInfo(..),
+ workerExists, workerInfo, ppWorkerInfo
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
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 )
\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
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),
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- 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,
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
- = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
+ = ASSERT2( arity_matches_strictness, ppr id )
+ Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
where
- idinfo = get_idinfo id
+ core_idinfo = idInfo id
+ stg_idinfo = get_idinfo id
ty_pretty = pprType (idType id)
sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
arity_pretty,
caf_pretty,
cpr_pretty,
- strict_pretty,
+ strict_pretty,
+ wrkr_pretty,
unfold_pretty,
ptext SLIT("##-}")]
------------ Arity --------------
- arity_pretty = ppArityInfo (arityInfo idinfo)
+ arity_info = arityInfo stg_idinfo
+ arity_pretty = ppArityInfo arity_info
------------ Caf Info --------------
- caf_pretty = ppCafInfo (cafInfo idinfo)
+ caf_pretty = ppCafInfo (cafInfo stg_idinfo)
------------ CPR Info --------------
- cpr_pretty = ppCprInfo (cprInfo idinfo)
+ cpr_pretty = ppCprInfo (cprInfo core_idinfo)
- ------------ Strictness and Worker --------------
- strict_info = strictnessInfo idinfo
- work_info = workerInfo idinfo
- has_worker = workerExists work_info
+ ------------ Strictness --------------
+ strict_info = strictnessInfo core_idinfo
bottoming_fn = isBottomingStrictness strict_info
- strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
+ strict_pretty = ppStrictnessInfo strict_info
+
+ ------------ Worker --------------
+ work_info = workerInfo core_idinfo
+ has_worker = workerExists work_info
+ wrkr_pretty = ppWorkerInfo work_info
+ Just work_id = work_info
- wrkr_pretty | not has_worker = empty
- | otherwise = ppr work_id
--- (Just work_id) = work_info
--- Temporary fix. We can't use the worker id saved by the w/w
--- pass because later optimisations may have changed it. So try
--- to snaffle from the wrapper code again ...
- work_id = getWorkerId id rhs
+ ------------ Occ info --------------
+ loop_breaker = case occInfo core_idinfo of
+ IAmALoopBreaker -> True
+ other -> False
------------ Unfolding --------------
- inline_pragma = inlinePragInfo idinfo
+ 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)
------------ Specialisations --------------
- spec_info = specInfo idinfo
+ spec_info = specInfo core_idinfo
------------ Extra free Ids --------------
new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
find_fvs expr = exprSomeFreeVars interestingId expr
+ ------------ Sanity checking --------------
+ -- The arity of a wrapper function should match its strictness,
+ -- or else an importing module will get very confused indeed.
+ -- [later: actually all that is necessary is for strictness to exceed arity]
+ arity_matches_strictness
+ = not has_worker ||
+ case strict_info of
+ StrictnessInfo ds _ -> length ds >= arityLowerBound arity_info
+ other -> True
+
interestingId id = isId id && isLocallyDefined id &&
not (omitIfaceSigForId id)
\end{code}
= case ifaceId get_idinfo needed False id rhs of
Nothing -> go needed binds pretties emitted
Just (pretty, extras) -> let
- needed' = (needed `unionVarSet` extras) `delVarSet` id
- -- 'extras' can include the Id itself via a rule
- emitted' = emitted `extendVarSet` id
- in
- go needed' binds (pretty `consBag` pretties) emitted'
+ needed' = (needed `unionVarSet` extras) `delVarSet` id
+ -- 'extras' can include the Id itself via a rule
+ emitted' = emitted `extendVarSet` id
+ in
+ go needed' binds (pretty `consBag` pretties) emitted'
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
%************************************************************************
\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}
%************************************************************************
%************************************************************************
%* *
-\subsection{Comparisons
+\subsection{Comparisons}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff