#include "HsVersions.h"
-import IO ( Handle, hPutStr, openFile,
- hClose, hPutStrLn, IOMode(..) )
+import IO ( openFile, hClose, IOMode(..) )
import HsSyn
import HsCore ( HsIdInfo(..), toUfExpr )
-import RdrHsSyn ( RdrNameRuleDecl )
+import RdrHsSyn ( RdrNameRuleDecl, mkTyData )
import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
import HsTypes ( toHsTyVars )
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
+import BasicTypes ( Fixity(..), NewOrData(..),
Version, bumpVersion, initialVersion, isLoopBreaker
)
import RnMonad
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 Var ( isId, varName )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..),
+import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
CprInfo(..), CafInfo(..),
inlinePragInfo, arityInfo, arityLowerBound,
strictnessInfo, isBottomingStrictness,
cafInfo, specInfo, cprInfo,
occInfo, isNeverInlinePrag,
- workerExists, workerInfo, WorkerInfo(..)
+ workerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
-import Module ( moduleString, pprModule, pprModuleName, moduleUserString )
+import Module ( pprModuleName, moduleUserString )
import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
Name, NamedThing(..)
)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
)
-import Class ( Class, classExtraBigSig )
-import FieldLabel ( fieldLabelName, fieldLabelType )
+import Class ( classExtraBigSig, DefMeth(..) )
+import FieldLabel ( fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
- deNoteType, classesToPreds,
- Type, ThetaType, PredType(..), ClassContext
+ deNoteType, classesToPreds
)
-import PprType
-import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
+import Rules ( ProtoCoreRule(..) )
-import Bag ( bagToList, isEmptyBag )
-import Maybes ( catMaybes, maybeToBool )
+import Bag ( bagToList )
import UniqFM ( lookupUFM, listToUFM )
-import Util ( sortLt, mapAccumL )
+import Util ( sortLt )
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 -> do { putStrLn "Interface file unchanged" ;
- return () } ; -- 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
- Just iface -> pi_vers iface == pi_vers final_iface
- Nothing -> False
- if mod_vers_unchanged
- then putStrLn "Module version unchanged, but usages differ; hence need new hi file"
- else return ()
+ 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"
- 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 final_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
]
-- 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 (classesToPreds theta)
- (deNoteType (mkDictTy clas tys))
+ forall_ty = mkSigmaTy tvs theta (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}
ifaceTyCon tycon
| isAlgTyCon tycon
- = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
+ = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
(toRdrName tycon)
(toHsTyVars tyvars)
(map ifaceConDecl (tyConDataCons tycon))
(toHsFDs clas_fds)
(map toClassOpSig op_stuff)
EmptyMonoBinds NoClassPragmas
- bogus bogus bogus [] noSrcLoc
+ [] noSrcLoc
)
where
bogus = error "ifaceClass"
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- toClassOpSig (sel_id, dm_id, explicit_dm)
- = ASSERT( sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
+ toClassOpSig (sel_id, def_meth) =
+ ASSERT(sel_tyvars == clas_tyvars)
+ ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
where
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+ def_meth' = case def_meth of
+ NoDefMeth -> NoDefMeth
+ GenDefMeth -> GenDefMeth
+ DefMeth id -> DefMeth (toRdrName id)
\end{code}
%************************************************************************
%* *
\subsection{Value bindings}
-%* *
+%* *
%************************************************************************
\begin{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
+ -> (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!
-
-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)
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.
- arity_matches_strictness
- = case work_info of
- 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}