- = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Compute final Ids}
-%* *
-%************************************************************************
-
-A "final Id" has exactly the IdInfo for going into an interface file, or
-exporting to another module.
-
-\begin{code}
-bindsToIds :: IdSet -- These Ids are needed already
- -> IdSet -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBind] -- In dependency order, later depend on earlier
- -> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
- -- they need for exporting to another module
-
-bindsToIds needed_ids codegen_ids binds
- = go needed_ids (reverse binds) []
- -- Reverse so that later things will
- -- provoke earlier ones to be emitted
- where
- -- 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 [] emitted
- | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
- (sep (map ppr (varSetElems needed)))
- emitted
- | otherwise = emitted
-
- go needed (NonRec id rhs : binds) emitted
- | need_id needed id = go new_needed binds (new_id:emitted)
- | otherwise = go needed binds emitted
- where
- (new_id, extras) = mkFinalId codegen_ids False id rhs
- new_needed = (needed `unionVarSet` extras) `delVarSet` id
-
- -- 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. 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) emitted
- = go needed' binds emitted'
- where
- (new_emitted, extras) = go_rec needed pairs
- needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
- emitted' = new_emitted ++ emitted
-
- go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
- go_rec needed pairs
- | null needed_prs = ([], emptyVarSet)
- | otherwise = (emitted ++ more_emitted,
- extras `unionVarSet` more_extras)
- where
- (needed_prs,leftover_prs) = partition is_needed pairs
- (emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs
- | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
- extras = unionVarSets extras_s
- (more_emitted, more_extras) = go_rec extras leftover_prs
-
- is_needed (id,_) = need_id needed id
-\end{code}
-
-
-
-\begin{code}
-mkFinalId :: IdSet -- The Ids with arity info from the code generator
- -> Bool -- True <=> recursive, so don't include unfolding
- -> Id
- -> CoreExpr -- The Id's right hand side
- -> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
-
-mkFinalId codegen_ids is_rec id rhs
- | omitIfaceSigForId id
- = (id, emptyVarSet) -- An optimisation for top-level constructors and suchlike
- | otherwise
- = (id `setIdInfo` new_idinfo, new_needed_ids)
- where
- core_idinfo = idInfo id
- stg_idinfo = case lookupVarSet codegen_ids id of
- Just id' -> idInfo id'
- Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
- idInfo id
-
- new_idinfo | opt_OmitInterfacePragmas
- = vanillaIdInfo
- | otherwise
- = core_idinfo `setArityInfo` arity_info
- `setCafInfo` cafInfo stg_idinfo
- `setUnfoldingInfo` unfold_info
- `setWorkerInfo` worker_info
- `setSpecInfo` emptyCoreRules
- -- We zap the specialisations because they are
- -- passed on separately through the modules IdCoreRules
-
- ------------ Arity --------------
- arity_info = arityInfo stg_idinfo
- stg_arity = arityLowerBound arity_info
-
- ------------ Worker --------------
- -- 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".
- worker_info = case workerInfo core_idinfo of
- info@(HasWorker work_id wrap_arity)
- | wrap_arity == stg_arity -> info
- | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
- NoWorker
- NoWorker -> NoWorker
-
- has_worker = case worker_info of
- HasWorker _ _ -> True
- other -> False
-
- HasWorker work_id _ = worker_info
-
- ------------ Unfolding --------------
- inline_pragma = inlinePragInfo core_idinfo
- dont_inline = isNeverInlinePrag inline_pragma
- loop_breaker = isLoopBreaker (occInfo core_idinfo)
- bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo)
-
- unfolding = mkTopUnfolding rhs
- rhs_is_small = neverUnfold unfolding
-
- unfold_info | show_unfold = unfolding
- | otherwise = noUnfolding
-
- 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
-
-
- ------------ Extra free Ids --------------
- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
- | otherwise = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
- spec_ids
-
- spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
-
- worker_ids | has_worker && interestingId work_id = unitVarSet work_id
- -- Conceivably, the worker might come from
- -- another module
- | otherwise = emptyVarSet
-
- unfold_ids | show_unfold = find_fvs rhs
- | otherwise = emptyVarSet
-
- find_fvs expr = exprSomeFreeVars interestingId expr
-
-interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
-\end{code}
-
-
-\begin{code}
-getRules :: [IdCoreRule] -- Orphan rules
- -> [CoreBind] -- Bindings, with rules in the top-level Ids
- -> IdSet -- Ids that are exported, so we need their rules
- -> [IdCoreRule]
-getRules orphan_rules binds emitted
- = orphan_rules ++ local_rules
- where
- local_rules = [ (fn, rule)
- | fn <- bindersOfBinds binds,
- fn `elemVarSet` emitted,
- rule <- rulesRules (idSpecialisation fn),
- not (isBuiltinRule rule),
- -- We can't print builtin rules in interface files
- -- Since they are built in, an importing module
- -- will have access to them anyway
-
- -- 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 ????
- -- (put it back in for now)
- 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
- ]