import TcInstUtil ( InstInfo(..) )
import CmdLineOpts
-import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
+import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
idSpecialisation
)
import Var ( isId )
import SrcLoc ( noSrcLoc )
import Bag
import Outputable
+import ErrUtils ( dumpIfSet )
import Maybe ( isNothing )
+import List ( partition )
import Monad ( when )
\end{code}
}}
in
- case checkIface old_iface full_new_iface of {
- Nothing -> when opt_D_dump_rn_trace $
- putStrLn "Interface file unchanged" ; -- No need to update .hi file
+ do maybe_final_iface <- checkIface old_iface full_new_iface
+ case maybe_final_iface of {
+ Nothing -> when opt_D_dump_rn_trace $
+ putStrLn "Interface file unchanged" ; -- No need to update .hi file
- Just final_iface ->
+ Just final_iface ->
- do let mod_vers_unchanged = case old_iface of
+ do let mod_vers_unchanged = case old_iface of
Just iface -> pi_vers iface == pi_vers final_iface
Nothing -> False
- when (mod_vers_unchanged && opt_D_dump_rn_trace) $
- putStrLn "Module version unchanged, but usages differ; hence need new hi file"
+ when (mod_vers_unchanged && opt_D_dump_rn_trace) $
+ putStrLn "Module version unchanged, but usages differ; hence need new hi file"
- if_hdl <- openFile filename WriteMode
- printForIface if_hdl (pprIface final_iface)
- hClose if_hdl
+ if_hdl <- openFile filename WriteMode
+ printForIface if_hdl (pprIface final_iface)
+ hClose if_hdl
}
where
full_new_iface = completeIface new_iface local_tycons local_classes
\begin{code}
checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
-> ParsedIface -- The new interface; but with all version numbers = 1
- -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface
+ -> IO (Maybe ParsedIface) -- Nothing => no change; no need to write new Iface
-- Just pi => Here is the new interface to write
-- with correct version numbers
+ -- The I/O part is just so it can print differences
-- NB: the fixities, declarations, rules are all assumed
-- to be sorted by increasing order of hsDeclName, so that
checkIface Nothing new_iface
-- No old interface, so definitely write a new one!
- = Just new_iface
+ = return (Just new_iface)
checkIface (Just iface) new_iface
| no_output_change && no_usage_change
- = Nothing
+ = return Nothing
| otherwise -- Add updated version numbers
- =
-{- pprTrace "checkIface" (
- vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
- text "--------",
- vcat (map ppr (pi_decls iface)),
- text "--------",
- vcat (map ppr (pi_decls new_iface))
- ]) $
--}
- Just (new_iface { pi_vers = new_mod_vers,
- pi_fixity = (new_fixity_vers, new_fixities),
- pi_rules = (new_rules_vers, new_rules),
- pi_decls = final_decls
- })
+ = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
+ return (Just new_iface )}
where
+ final_iface = new_iface { pi_vers = new_mod_vers,
+ pi_fixity = (new_fixity_vers, new_fixities),
+ pi_rules = (new_rules_vers, new_rules),
+ pi_decls = final_decls }
+
no_usage_change = pi_usages iface == pi_usages new_iface
no_output_change = no_decl_changed &&
new_rules_vers | rules == new_rules = rules_vers
| otherwise = bumpVersion rules_vers
- (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)
+ (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
-- Fill in the version number on the new declarations
-- by looking at the old declarations.
-- Set the flag if anything changes.
-- Assumes that the decls are sorted by hsDeclName
- merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc)
- merge_decls ok_so_far acc old [] = (False, reverse acc)
- merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
- merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
+ merge_decls ok_so_far pp acc [] [] = (ok_so_far, pp, reverse acc)
+ merge_decls ok_so_far pp acc old [] = (False, pp, reverse acc)
+ merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
+ merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
= case d_name `compare` nd_name of
- LT -> merge_decls False acc vds (nvd:nvds)
- GT -> merge_decls False (nvd:acc) (vd:vds) nvds
- EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds
- | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds
+ LT -> merge_decls False (pp $$ only_old vd) acc vds (nvd:nvds)
+ GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
+ EQ | d == nd -> merge_decls ok_so_far pp (vd:acc) vds nvds
+ | otherwise -> merge_decls False (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
where
d_name = hsDeclName d
nd_name = hsDeclName nd
+
+ only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
+ only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
+ changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
+ (ptext SLIT("New:") <+> ppr nd))
\end{code}
all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
(inst_dcls, inst_ids) = ifaceInstances inst_info
cls_dcls = map ifaceClass local_classes
+
ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
(val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| ProtoCoreRule _ _ rule <- tidy_orphan_rules]
-lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
- = dfun_id1 < dfun_id2
- -- The dfuns are assigned names df1, df2, etc,
- -- in order of original textual
- -- occurrence, and this makes as good a sort order as any
-
-lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
+ -- Even instance decls have names, namely the dfun name
\end{code}
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
- all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+
+ -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
+ -- from coming out, and to make it work properly we need to add
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- 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
]
(deNoteType (mkDictTy clas tys))
tidy_ty = tidyTopType forall_ty
in
- InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc
+ InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
\end{code}
\begin{code}
toClassOpSig (sel_id, dm_id, explicit_dm)
= ASSERT( sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
+ ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
where
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
\end{code}
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
+ -- The 'needed' set contains the Ids that are needed by earlier
+ -- interface file emissions. If the Id isn't in this set, and isn't
+ -- exported, there's no need to emit anything
+ need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
+
go needed [] decls emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
| otherwise = (decls, emitted)
go needed (NonRec id rhs : binds) decls emitted
- = case ifaceId get_idinfo needed False id rhs of
- Nothing -> go needed binds decls emitted
- Just (decl, 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 (decl `consBag` decls) emitted'
+ | need_id needed id
+ = if omitIfaceSigForId id then
+ go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
+ else
+ go ((needed `unionVarSet` extras) `delVarSet` id)
+ binds
+ (decl `consBag` decls)
+ (emitted `extendVarSet` id)
+ | otherwise
+ = go needed binds decls emitted
+ where
+ (decl, extras) = ifaceId get_idinfo False id rhs
-- 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
- -- have to look for a fixed point.
+ -- have to look for a fixed point. We don't want necessarily them all,
+ -- because without -O we may only need the first one (if we don't emit
+ -- its unfolding)
go needed (Rec pairs : binds) decls emitted
= go needed' binds decls' emitted'
where
go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
go_rec needed pairs
| null decls = (emptyBag, emptyVarSet, emptyVarSet)
- | otherwise = (more_decls `unionBags` listToBag decls,
- more_emitted `unionVarSet` mkVarSet emitted,
- more_extras `unionVarSet` extras)
+ | otherwise = (more_decls `unionBags` listToBag decls,
+ more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
+ more_extras `unionVarSet` extras)
where
- maybes = map do_one pairs
- emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
- reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
- (decls, extras_s) = unzip (catMaybes maybes)
- extras = unionVarSets extras_s
- (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs
-
- do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
+ (needed_prs,leftover_prs) = partition is_needed pairs
+ (decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
+ | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
+ extras = unionVarSets extras_s
+ (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
+ is_needed (id,_) = need_id needed id
\end{code}
\begin{code}
ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
-- by the STG passes. Sigh
-
- -> IdSet -- Set of Ids that are needed by earlier interface
- -- file emissions. If the Id isn't in this set, and isn't
- -- exported, there's no need to emit anything
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
- -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
-
-ifaceId get_idinfo needed_ids is_rec id rhs
- | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
- (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
- = Nothing -- Well, that was easy!
+ -> (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
-ifaceId get_idinfo needed_ids is_rec id rhs
- = ASSERT2( arity_matches_strictness, ppr id )
- Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),
- new_needed_ids)
+ifaceId get_idinfo is_rec id rhs
+ = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), new_needed_ids)
where
id_type = idType id
core_idinfo = idInfo id
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
- arity_info = arityInfo stg_idinfo
+ arity_info = arityInfo stg_idinfo
+ stg_arity = arityLowerBound arity_info
arity_hsinfo = case arityInfo stg_idinfo of
a@(ArityExactly n) -> [HsArity a]
other -> []
------------ Worker --------------
- work_info = workerInfo core_idinfo
- has_worker = workerExists work_info
- wrkr_hsinfo = case work_info of
- HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
- other -> []
+ -- We only treat a function as having a worker if
+ -- the exported arity (which is now the number of visible lambdas)
+ -- is the same as the arity at the moment of the w/w split
+ -- If so, we can safely omit the unfolding inside the wrapper, and
+ -- instead re-generate it from the type/arity/strictness info
+ -- But if the arity has changed, we just take the simple path and
+ -- put the unfolding into the interface file, forgetting the fact
+ -- that it's a wrapper.
+ --
+ -- How can this happen? Sometimes we get
+ -- f = coerce t (\x y -> $wf x y)
+ -- at the moment of w/w split; but the eta reducer turns it into
+ -- f = coerce t $wf
+ -- which is perfectly fine except that the exposed arity so far as
+ -- the code generator is concerned (zero) differs from the arity
+ -- when we did the split (2).
+ --
+ -- All this arises because we use 'arity' to mean "exactly how many
+ -- top level lambdas are there" in interface files; but during the
+ -- compilation of this module it means "how many things can I apply
+ -- this to".
+ work_info = workerInfo core_idinfo
+ HasWorker work_id _ = work_info
+
+ has_worker = case work_info of
+ HasWorker work_id wrap_arity
+ | wrap_arity == stg_arity -> True
+ | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
+ False
+
+ other -> False
+
+ wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
+ | otherwise = []
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
unfold_ids `unionVarSet`
spec_ids
- worker_ids = case work_info of
- HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
+ worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
- other -> emptyVarSet
+ | otherwise = emptyVarSet
spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
other -> True
-interestingId id = isId id && isLocallyDefined id &&
- not (omitIfaceSigForId id)
+interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
\end{code}
projects / ghc-hetmet.git / blobdiff