[project @ 2000-10-16 08:24:18 by simonpj]
[ghc-hetmet.git] / ghc / compiler / main / MkIface.lhs
index 24e51c9..1d709ef 100644 (file)
 \section[MkIface]{Print an interface for a module}
 
 \begin{code}
-module MkIface (
-       startIface, endIface, ifaceDecls
-    ) where
+module MkIface ( writeIface  ) where
 
 #include "HsVersions.h"
 
-import IO              ( Handle, hPutStr, openFile, 
-                         hClose, hPutStrLn, IOMode(..) )
+import IO              ( openFile, hClose, IOMode(..) )
 
 import HsSyn
-import BasicTypes      ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import HsCore          ( HsIdInfo(..), toUfExpr )
+import RdrHsSyn                ( RdrNameRuleDecl, mkTyData )
+import HsPragmas       ( DataPragmas(..), ClassPragmas(..) )
+import HsTypes         ( toHsTyVars )
+import BasicTypes      ( Fixity(..), NewOrData(..),
+                         Version, bumpVersion, initialVersion, isLoopBreaker
+                       )
 import RnMonad
-import RnEnv           ( availName )
 
 import TcInstUtil      ( InstInfo(..) )
 
 import CmdLineOpts
-import Id              ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
-                         getIdSpecialisation
+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(..), inlinePragInfo,
-                         arityInfo, ppArityInfo, arityLowerBound,
-                         strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
-                         cafInfo, ppCafInfo, specInfo,
-                         cprInfo, ppCprInfo, pprInlinePragInfo,
-                         occInfo, OccInfo(..),
-                         workerExists, workerInfo, ppWorkerInfo
+import IdInfo          ( IdInfo, StrictnessInfo(..), ArityInfo(..), 
+                         CprInfo(..), CafInfo(..),
+                         inlinePragInfo, arityInfo, arityLowerBound,
+                         strictnessInfo, isBottomingStrictness,
+                         cafInfo, specInfo, cprInfo, 
+                         occInfo, isNeverInlinePrag,
+                         workerInfo, WorkerInfo(..)
                        )
-import CoreSyn         ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
+import CoreSyn         ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
 import CoreFVs         ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
-import CoreUnfold      ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline )
-import Module          ( moduleString, pprModule, pprModuleName )
-import Name            ( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
+import CoreUnfold      ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
+import Module          ( pprModuleName, moduleUserString )
+import Name            ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
                          Name, NamedThing(..)
                        )
 import OccName         ( OccName, pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
-                         tyConTheta, tyConTyVars, tyConDataCons
+                         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 PprCore         ( pprIfaceUnfolding, pprCoreRule )
-import FunDeps         ( pprFundeps )
-import Rules           ( pprProtoCoreRule, ProtoCoreRule(..) )
+import Rules           ( ProtoCoreRule(..) )
 
-import Bag             ( bagToList, isEmptyBag )
-import Maybes          ( catMaybes, maybeToBool )
-import FiniteMap       ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
+import Bag             ( bagToList )
 import UniqFM          ( lookupUFM, listToUFM )
-import UniqSet         ( uniqSetToList )
-import Util            ( sortLt, mapAccumL )
+import Util            ( sortLt )
+import SrcLoc          ( noSrcLoc )
 import Bag
 import Outputable
-\end{code}
+import ErrUtils                ( dumpIfSet )
 
-We have a function @startIface@ to open the output file and put
-(something like) ``interface Foo'' in it.  It gives back a handle
-for subsequent additions to the interface file.
+import Maybe           ( isNothing )
+import List            ( partition )
+import Monad           ( when )
+\end{code}
 
-We then have one-function-per-block-of-interface-stuff, e.g.,
-@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
+%************************************************************************
+%*                                                                     *
+\subsection{Write a new interface file}
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-startIface  :: Module -> InterfaceDetails
-           -> IO (Maybe Handle) -- Nothing <=> don't do an interface
+writeIface this_mod old_iface new_iface
+          local_tycons local_classes inst_info
+          final_ids tidy_binds tidy_orphan_rules
+  = 
+    if isNothing opt_HiDir && isNothing opt_HiFile
+       then return ()  -- not producing any .hi file
+       else 
+
+    let 
+       hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
+       filename = case opt_HiFile of {
+                       Just f  -> f;
+                       Nothing -> 
+                  case opt_HiDir of {
+                       Just dir -> dir ++ '/':moduleUserString this_mod 
+                                       ++ '.':hi_suf;
+                       Nothing  -> panic "writeIface"
+               }}
+    in
+
+    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 ->
+
+       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
+    }   
+  where
+    full_new_iface = completeIface new_iface local_tycons local_classes
+                                            inst_info final_ids tidy_binds
+                                            tidy_orphan_rules
+\end{code}
 
-ifaceDecls :: Maybe Handle
-          -> [TyCon] -> [Class]
-          -> Bag InstInfo 
-          -> [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}
+%************************************************************************
+%*                                                                     *
+\subsection{Checking if the new interface is up to date
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _)
-  = case opt_ProduceHi of
-      Nothing -> return Nothing ; -- not producing any .hi file
-
-      Just fn -> do 
-       if_hdl <- openFile fn WriteMode
-       hPutStr         if_hdl ("__interface " ++ moduleString mod)
-       hPutStr         if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator)
-       hPutStrLn       if_hdl " where"
-       ifaceExports    if_hdl avails
-       ifaceImports    if_hdl import_usages
-       ifaceFixities   if_hdl fixities
-       return (Just if_hdl)
+checkIface :: Maybe ParsedIface                -- The old interface, read from M.hi
+          -> ParsedIface               -- The new interface; but with all version numbers = 1
+          -> 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 
+-- we can compare for equality
+
+checkIface Nothing new_iface
+-- No old interface, so definitely write a new one!
+  = return (Just new_iface)
+
+checkIface (Just iface) new_iface
+  | no_output_change && no_usage_change
+  = return Nothing
+
+  | otherwise          -- Add updated version numbers
+  = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
+        return (Just final_iface )}
+       
   where
-    orphan_indicator | has_orphans = " !"
-                    | otherwise   = ""
+    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_fixity_vers == fixity_vers && 
+                      new_rules_vers == rules_vers &&
+                      no_export_change
+
+    no_export_change = pi_exports iface == pi_exports new_iface
+
+    new_mod_vers | no_output_change = mod_vers
+                | otherwise        = bumpVersion mod_vers
+
+    mod_vers = pi_vers iface
+
+    (fixity_vers, fixities) = pi_fixity iface
+    (_,       new_fixities) = pi_fixity new_iface
+    new_fixity_vers | fixities == new_fixities = fixity_vers
+                   | otherwise                = bumpVersion fixity_vers
+
+    (rules_vers, rules) = pi_rules iface
+    (_,      new_rules) = pi_rules new_iface
+    new_rules_vers  | rules == new_rules = rules_vers
+                   | otherwise          = bumpVersion rules_vers
+
+    (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 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 (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
 
-endIface Nothing       = return ()
-endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
+    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}
 
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{Printing the interface}
+%*                                                                     *
+%************************************************************************
+
 \begin{code}
-ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return ()
-ifaceDecls (Just hdl)
-          tycons classes
-          inst_infos
-          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
-  = ifaceClasses hdl classes                   >>
-    ifaceInstances hdl inst_infos              >>= \ inst_ids ->
-    ifaceTyCons hdl tycons                     >>
-    ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids)
-              final_ids binds                  >>= \ emitted_ids ->
-    ifaceRules hdl orphan_rules emitted_ids    >>
-    ifaceDeprecations hdl deprecations
+pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
+                       pi_usages = usages, pi_exports = exports, 
+                       pi_fixity = (fix_vers, fixities),
+                       pi_insts = insts, pi_decls = decls, 
+                       pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
+ = vcat [ ptext SLIT("__interface")
+               <+> doubleQuotes (ptext opt_InPackage)
+               <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
+               <+> (if orphan then char '!' else empty)
+               <+> int opt_HiVersion
+               <+> ptext SLIT("where")
+       , vcat (map pprExport exports)
+       , vcat (map pprUsage usages)
+       , pprFixities fixities
+       , vcat [ppr i <+> semi | i <- insts]
+       , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
+       , pprRules rules
+       , pprDeprecs deprecs
+       ]
   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 deprecations
+    ppr_vers v | v == initialVersion = empty
+              | otherwise           = int v
+    pp_sub_vers 
+       | fix_vers == initialVersion && rule_vers == initialVersion = empty
+       | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
 \end{code}
 
+When printing export lists, we print like this:
+       Avail   f               f
+       AvailTC C [C, x, y]     C(x,y)
+       AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
+
 \begin{code}
-ifaceImports :: Handle -> VersionInfo Name -> IO ()
-ifaceImports if_hdl import_usages
-  = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
+pprExport :: ExportItem -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
   where
-    upp_uses (m, mv, has_orphans, whats_imported)
-      = hsep [ptext SLIT("import"), pprModuleName m, 
-             int mv, pp_orphan,
-             upp_import_versions whats_imported
-       ] <> semi
-      where
-       pp_orphan | has_orphans = ptext SLIT("!")
-                 | otherwise   = empty
+    upp_avail :: RdrAvailInfo -> SDoc
+    upp_avail (Avail name)      = pprOccName name
+    upp_avail (AvailTC name []) = empty
+    upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+                               where
+                                 bang | name `elem` ns = empty
+                                      | otherwise      = char '|'
+                                 ns' = filter (/= name) ns
+    
+    upp_export []    = empty
+    upp_export names = braces (hsep (map pprOccName names))
+\end{code}
 
-       -- Importing the whole module is indicated by an empty list
-    upp_import_versions Everything = empty
-
-       -- For imported versions we do print the version number
-    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 
-       lines = map ppr_mod_dep mod_deps
-       ppr_mod_dep (mod, contains_orphans) 
-          | contains_orphans = pprModuleName mod <+> ptext SLIT("!")
-          | otherwise        = pprModuleName mod
-    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)
-  where
-       -- Sort them into groups by module
-    export_fm :: FiniteMap Module [AvailInfo]
-    export_fm = foldr insert emptyFM avails
-
-    insert avail efm = addToFM_C (++) efm mod [avail] 
-                    where
-                      mod = nameModule (availName avail)
-
-       -- Print one module's worth of stuff
-    do_one_module :: (Module, [AvailInfo]) -> SDoc
-    do_one_module (mod_name, avails@(avail1:_))
-       = ptext SLIT("__export ") <>
-         hsep [pprModule mod_name,
-               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
-  = return ()
-  | otherwise
-  = printForIface if_hdl (vcat [
-               ptext SLIT("{-## __R"),
-               vcat orphan_rule_pretties,
-               vcat local_id_pretties,
-               ptext SLIT("##-}")
-       ])
+
+\begin{code}
+pprUsage :: ImportVersion OccName -> SDoc
+pprUsage (m, has_orphans, is_boot, whats_imported)
+  = hsep [ptext SLIT("import"), pprModuleName m, 
+         pp_orphan, pp_boot,
+         upp_import_versions whats_imported
+    ] <> semi
   where
-    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule
-                           | ProtoCoreRule _ fn rule <- rules
-                           ]
-    local_id_pretties = [ pprCoreRule (Just fn) rule
-                       | fn <- varSetElems emitted, 
-                         rule <- rulesRules (getIdSpecialisation fn),
-                         all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-                               -- Spit out a rule only if all its lhs free vars are emitted
-                       ]
-
-ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
-ifaceDeprecations if_hdl [] = return ()
-ifaceDeprecations if_hdl deprecations
-  = printForIface if_hdl (vcat [
-               ptext SLIT("{-## __D"),
-               vcat [ pprIfaceDeprec d <> semi | d <- deprecations ],
-               ptext SLIT("##-}")
-       ])
+    pp_orphan | has_orphans = char '!'
+             | otherwise   = empty
+    pp_boot   | is_boot     = char '@'
+              | otherwise   = empty
+
+       -- Importing the whole module is indicated by an empty list
+    upp_import_versions NothingAtAll   = empty
+    upp_import_versions (Everything v) = dcolon <+> int v
+    upp_import_versions (Specifically vm vf vr nvs)
+      = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
+\end{code}
+
+
+\begin{code}
+pprFixities []    = empty
+pprFixities fixes = hsep (map ppr fixes) <> semi
+
+pprRules []    = empty
+pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
+
+pprDeprecs []   = empty
+pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
+               where
+                 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi 
+                             | Deprecation ie txt _ <- deps ]
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Completing the new interface}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+completeIface new_iface local_tycons local_classes
+                       inst_info final_ids tidy_binds
+                       tidy_orphan_rules
+  = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
+               pi_insts = sortLt lt_inst_decl inst_dcls,
+               pi_rules = (initialVersion, rule_dcls)
+    }
   where
-    -- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
-    pprIfaceDeprec (Deprecation (IEModuleContents _) txt) =           doubleQuotes (ppr txt)
-    pprIfaceDeprec (Deprecation (IEVar            n) txt) = ppr n <+> doubleQuotes (ppr txt)
+     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)
+                                         final_ids tidy_binds
+
+     rule_dcls | opt_OmitInterfacePragmas = []
+              | otherwise                = ifaceRules tidy_orphan_rules emitted_ids
+
+     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
+                                   | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
+
+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}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Instance declarations}
+\subsection{Completion stuff}
 %*                                                                     *
 %************************************************************************
 
+\begin{code}
+ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
+ifaceRules rules emitted
+  = orphan_rules ++ local_rules
+  where
+    orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
+    local_rules  = [ toHsRule fn rule
+                  | fn <- varSetElems 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 
+                            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
+                  ]
+\end{code}
 
 \begin{code}                    
-ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet           -- The IdSet is the needed dfuns
-ifaceInstances if_hdl inst_infos
-  | null togo_insts = return emptyVarSet                
-  | otherwise      = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
-                     return needed_ids
-  where                                 
+ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
+                  -- The IdSet is the needed dfuns
+
+ifaceInstances inst_infos
+  = (decls, needed_ids)
+  where                        
+    decls       = map to_decl togo_insts
     togo_insts = filter is_togo_inst (bagToList inst_infos)
     needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
     is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
                                 
     -------                     
-    lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
-           (InstInfo _ _ _ _ dfun_id2 _ _ _)
-      = getOccName dfun_id1 < getOccName 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
-
-    -------                     
-    pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
+    to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
       = let                     
                -- The deNoteType is very important.   It removes all type
                -- synonyms from the instance type in interface files.
@@ -283,151 +390,103 @@ ifaceInstances if_hdl inst_infos
                --      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))
-           renumbered_ty = tidyTopType forall_ty
+           forall_ty     = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
+           tidy_ty = tidyTopType forall_ty
        in                       
-       hcat [ptext SLIT("instance "), pprType renumbered_ty, 
-                   ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
+       InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc 
 \end{code}
 
-
-%************************************************************************
-%*                                                                     *
-\subsection{Printing values}
-%*                                                                     *
-%************************************************************************
-
 \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 (SDoc, 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 (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
+ifaceTyCon :: TyCon -> RdrNameHsDecl
+ifaceTyCon tycon
+  | isSynTyCon tycon
+  = TyClD (TySynonym (toRdrName tycon)
+                    (toHsTyVars tyvars) (toHsType ty)
+                    noSrcLoc)
   where
-    core_idinfo = idInfo id
-    stg_idinfo  = get_idinfo id
-
-    ty_pretty  = pprType (idType id)
-    sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
-
-    prag_pretty 
-     | opt_OmitInterfacePragmas = empty
-     | otherwise               = hsep [ptext SLIT("{-##"),
-                                       arity_pretty, 
-                                       caf_pretty,
-                                       cpr_pretty,
-                                       strict_pretty,
-                                       wrkr_pretty,
-                                       unfold_pretty, 
-                                       ptext SLIT("##-}")]
-
-    ------------  Arity  --------------
-    arity_info    = arityInfo stg_idinfo
-    arity_pretty  = ppArityInfo arity_info
-
-    ------------ Caf Info --------------
-    caf_pretty = ppCafInfo (cafInfo stg_idinfo)
-
-    ------------ CPR Info --------------
-    cpr_pretty = ppCprInfo (cprInfo core_idinfo)
-
-    ------------  Strictness  --------------
-    strict_info   = strictnessInfo core_idinfo
-    bottoming_fn  = isBottomingStrictness strict_info
-    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
-
-
-    ------------  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 False Nothing -> True -- Unconditional NOINLINE
-                       other                           -> False
+    (tyvars, ty) = getSynTyConDefn tycon
 
+ifaceTyCon tycon
+  | isAlgTyCon tycon
+  = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
+                 (toRdrName tycon)
+                 (toHsTyVars tyvars)
+                 (map ifaceConDecl (tyConDataCons tycon))
+                 (tyConFamilySize tycon)
+                 Nothing NoDataPragmas noSrcLoc)
+  where
+    tyvars = tyConTyVars tycon
+    new_or_data | isNewTyCon tycon = NewType
+               | otherwise        = DataType
+
+    ifaceConDecl data_con 
+       = ConDecl (toRdrName data_con) (error "ifaceConDecl")
+                 (toHsTyVars ex_tyvars)
+                 (toHsContext ex_theta)
+                 details noSrcLoc
+       where
+         (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
+          field_labels   = dataConFieldLabels data_con
+          strict_marks   = dataConStrictMarks data_con
+         details
+           | null field_labels
+           = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
+             VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 
-    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
-                 | otherwise   = empty
+           | otherwise
+           = RecCon (zipWith mk_field strict_marks field_labels)
 
-    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
+    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
+    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
+    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 
-    rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
+    mk_field strict_mark field_label
+       = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 
-    ------------  Specialisations --------------
-    spec_info   = specInfo core_idinfo
-    
-    ------------  Extra free Ids  --------------
-    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
-                  | otherwise                = worker_ids      `unionVarSet`
-                                               unfold_ids      `unionVarSet`
-                                               spec_ids
-
-    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-                       -- Conceivably, the worker might come from
-                       -- another module
-              | otherwise                         = emptyVarSet
+ifaceTyCon tycon
+  = pprPanic "pprIfaceTyDecl" (ppr tycon)
 
-    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
+ifaceClass clas
+  = TyClD (ClassDecl (toHsContext sc_theta)
+                    (toRdrName clas)
+                    (toHsTyVars clas_tyvars)
+                    (toHsFDs clas_fds)
+                    (map toClassOpSig op_stuff)
+                    EmptyMonoBinds NoClassPragmas
+                    [] noSrcLoc
+    )
+  where
+     bogus = error "ifaceClass"
+     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 
-    unfold_ids | show_unfold = find_fvs rhs
-              | otherwise   = emptyVarSet
+     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}
 
-    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}
+%************************************************************************
+%*                                                                     *
+\subsection{Value bindings}
+%*                                                                     * 
+%************************************************************************
 
 \begin{code}
-ifaceBinds :: Handle
-          -> IdSet             -- These Ids are needed already
+ifaceBinds :: IdSet            -- These Ids are needed already
           -> [Id]              -- Ids used at code-gen time; they have better pragma info!
           -> [CoreBind]        -- In dependency order, later depend on earlier
-          -> IO IdSet          -- Set of Ids actually spat out
+          -> (Bag RdrNameHsDecl, IdSet)                -- Set of Ids actually spat out
 
-ifaceBinds hdl needed_ids final_ids binds
-  = mapIO (printForIface hdl) (bagToList pretties)     >>
-    hPutStr hdl "\n"                                   >>
-    return emitted
+ifaceBinds needed_ids final_ids binds
+  = go needed_ids (reverse binds) emptyBag emptyVarSet 
+               -- Reverse so that later things will 
+               -- provoke earlier ones to be emitted
   where
     final_id_map  = listToUFM [(id,id) | id <- final_ids]
     get_idinfo id = case lookupUFM final_id_map id of
@@ -435,264 +494,180 @@ ifaceBinds hdl needed_ids final_ids binds
                        Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
                                    idInfo id
 
-    (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet 
-                       -- Reverse so that later things will 
-                       -- provoke earlier ones to be emitted
-    go needed [] pretties emitted
+       -- 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)))
-                                      (pretties, emitted)
-       | otherwise                  = (pretties, emitted)
-
-    go needed (NonRec id rhs : binds) pretties emitted
-       = 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'
+                                      (decls, emitted)
+       | otherwise                  = (decls, emitted)
+
+    go needed (NonRec id rhs : binds) 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.
-    go needed (Rec pairs : binds) pretties emitted
-       = go needed' binds pretties' emitted' 
+       -- 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
-         (new_pretties, new_emitted, extras) = go_rec needed pairs
-         pretties' = new_pretties `unionBags` pretties
-         needed'   = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
-         emitted'  = emitted `unionVarSet` new_emitted
+         (new_decls, new_emitted, extras) = go_rec needed pairs
+         decls'   = new_decls `unionBags` decls
+         needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
+         emitted' = emitted `unionVarSet` new_emitted
 
-    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
+    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
     go_rec needed pairs
-       | null pretties = (emptyBag, emptyVarSet, emptyVarSet)
-       | otherwise     = (more_pretties `unionBags`   listToBag pretties, 
-                          more_emitted  `unionVarSet` mkVarSet emitted,
-                          more_extras   `unionVarSet` extras)
+       | null decls = (emptyBag, emptyVarSet, emptyVarSet)
+       | 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]
-         (pretties, extras_s) = unzip (catMaybes maybes)
-         extras               = unionVarSets extras_s
-         (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs
-
-         do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Random small things}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-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 && 
-                     not (isWiredInName name)
-
-upp_tycon tycon = ifaceTyCon tycon
-upp_class clas  = ifaceClass clas
+         (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}
-ifaceTyCon :: TyCon -> SDoc
-ifaceTyCon tycon
-  | isSynTyCon tycon
-  = hsep [ ptext SLIT("type"),
-          ppr (getName tycon),
-          pprTyVarBndrs tyvars,
-          ptext SLIT("="),
-          ppr ty,
-          semi
-    ]
-  where
-    (tyvars, ty) = getSynTyConDefn tycon
-
-ifaceTyCon tycon
-  | isAlgTyCon tycon
-  = hsep [ ptext keyword,
-          ppr_decl_class_context (tyConTheta tycon),
-          ppr (getName tycon),
-          pprTyVarBndrs (tyConTyVars tycon),
-          ptext SLIT("="),
-          hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))),
-          semi
-    ]
+ifaceId :: (Id -> IdInfo)      -- This function "knows" the extra info added
+                               -- by the STG passes.  Sigh
+       -> Bool                 -- True <=> recursive, so don't print unfolding
+       -> Id
+       -> CoreExpr             -- The Id's right hand side
+       -> (RdrNameHsDecl, IdSet)       -- The emitted stuff, plus any *extra* needed Ids
+
+ifaceId get_idinfo is_rec id rhs
+  = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),  new_needed_ids)
   where
-    keyword | isNewTyCon tycon = SLIT("newtype")
-           | otherwise        = SLIT("data")
-
-    tyvars = tyConTyVars tycon
-
-    ppr_con data_con 
-       | null field_labels
-       = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
-         hsep [  ppr_ex ex_tyvars ex_theta,
-                 ppr name,
-                 hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
-               ]
-
-       | otherwise
-       = hsep [  ppr_ex ex_tyvars ex_theta,
-                 ppr name,
-                 braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
-               ]
-          where
-          (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
-           field_labels   = dataConFieldLabels data_con
-           strict_marks   = dataConStrictMarks data_con
-          name           = getName            data_con
-
-    ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
-    ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
-                            <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
-
-    ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
-
-    ppr_strict_mark NotMarkedStrict        = empty
-    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
-    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
-
-    ppr_field (strict_mark, field_label)
-       = hsep [ ppr (fieldLabelName field_label),
-                 dcolon,
-                 ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
-               ]
-
-ifaceTyCon tycon
-  = pprPanic "pprIfaceTyDecl" (ppr tycon)
-
-ifaceClass clas
-  = hsep [ptext SLIT("class"),
-          ppr_decl_class_context sc_theta,
-          ppr clas,                    -- Print the name
-          pprTyVarBndrs clas_tyvars,
-          pprFundeps clas_fds,
-          pp_ops,
-          semi
-         ]
-   where
-     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
-
-     pp_ops | null op_stuff  = empty
-           | otherwise      = hsep [ptext SLIT("where"),
-                                    braces (hsep (punctuate semi (map ppr_classop op_stuff)))
-                              ]
-
-     ppr_classop (sel_id, dm_id, explicit_dm)
-       = ASSERT( sel_tyvars == clas_tyvars)
-         hsep [ppr (getOccName sel_id),
-               if explicit_dm then equals else empty,
-               dcolon,
-               ppr op_ty
-         ]
-       where
-         (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+    id_type     = idType id
+    core_idinfo = idInfo id
+    stg_idinfo  = get_idinfo id
 
-ppr_decl_context :: ThetaType -> SDoc
-ppr_decl_context []    = empty
-ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
+    hs_idinfo | opt_OmitInterfacePragmas = []
+             | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
+                                          strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 
-ppr_decl_class_context :: ClassContext -> SDoc
-ppr_decl_class_context []    = empty
-ppr_decl_class_context ctxt  = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
+    ------------  Arity  --------------
+    arity_info   = arityInfo stg_idinfo
+    stg_arity   = arityLowerBound arity_info
+    arity_hsinfo = case arityInfo stg_idinfo of
+                       a@(ArityExactly n) -> [HsArity a]
+                       other              -> []
 
-pprIfaceTheta :: ThetaType -> SDoc     -- Use braces rather than parens in interface files
-pprIfaceTheta []    = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
+    ------------ Caf Info --------------
+    caf_hsinfo = case cafInfo stg_idinfo of
+                  NoCafRefs -> [HsNoCafRefs]
+                  otherwise -> []
 
--- 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
+    ------------ CPR Info --------------
+    cpr_hsinfo = case cprInfo core_idinfo of
+                  ReturnsCPR -> [HsCprInfo]
+                  NoCPRInfo  -> []
 
-pprIfaceClasses :: ClassContext -> SDoc
-pprIfaceClasses []    = empty
-pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
-\end{code}
+    ------------  Strictness  --------------
+    strict_info   = strictnessInfo core_idinfo
+    bottoming_fn  = isBottomingStrictness strict_info
+    strict_hsinfo = case strict_info of
+                       NoStrictnessInfo -> []
+                       info             -> [HsStrictness info]
 
-%************************************************************************
-%*                                                                     *
-\subsection{Random small things}
-%*                                                                     *
-%************************************************************************
 
-When printing export lists, we print like this:
-       Avail   f               f
-       AvailTC C [C, x, y]     C(x,y)
-       AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
+    ------------  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".
+    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  = []
 
-\begin{code}
-upp_avail :: AvailInfo -> SDoc
-upp_avail (Avail name)      = pprOccName (getOccName name)
-upp_avail (AvailTC name []) = empty
-upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
-                           where
-                             bang | name `elem` ns = empty
-                                  | otherwise      = char '|'
-                             ns' = filter (/= name) ns
-
-upp_export :: [Name] -> SDoc
-upp_export []    = empty
-upp_export names = braces (hsep (map (pprOccName . getOccName) names)) 
-
-upp_fixity :: (Name, Fixity) -> SDoc
-upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
-       -- Dummy version number!
-
-ppr_unqual_name :: NamedThing a => a -> SDoc           -- Just its occurrence name
-ppr_unqual_name name = pprOccName (getOccName name)
-\end{code}
+    ------------  Unfolding  --------------
+    inline_pragma  = inlinePragInfo core_idinfo
+    dont_inline           = isNeverInlinePrag inline_pragma
 
+    unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
+                 | otherwise   = []
 
-%************************************************************************
-%*                                                                     *
-\subsection{Comparisons}
-%*                                                                     *
-%************************************************************************
-                                
+    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
 
-The various sorts above simply prevent unnecessary "wobbling" when
-things change that don't have to.  We therefore compare lexically, not
-by unique
+    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
 
-\begin{code}
-lt_avail :: AvailInfo -> AvailInfo -> Bool
+    ------------  Specialisations --------------
+    spec_info   = specInfo core_idinfo
+    
+    ------------  Occ info  --------------
+    loop_breaker  = isLoopBreaker (occInfo core_idinfo)
 
-a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
+    ------------  Extra free Ids  --------------
+    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
+                  | otherwise                = worker_ids      `unionVarSet`
+                                               unfold_ids      `unionVarSet`
+                                               spec_ids
 
-lt_name :: Name -> Name -> Bool
-n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
+    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
+                       -- Conceivably, the worker might come from
+                       -- another module
+              | otherwise = emptyVarSet
 
-lt_lexical :: NamedThing a => a -> a -> Bool
-lt_lexical a1 a2 = getName a1 `lt_name` getName a2
+    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
 
-lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
-lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
+    unfold_ids | show_unfold = find_fvs rhs
+              | otherwise   = emptyVarSet
 
-sort_versions vs = sortLt lt_vers vs
+    find_fvs expr = exprSomeFreeVars interestingId expr
 
-lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
-lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
+interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
 \end{code}
 
-
-\begin{code}
-hPutCol :: Handle 
-       -> (a -> SDoc)
-       -> [a]
-       -> IO ()
-hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
-
-mapIO :: (a -> IO b) -> [a] -> IO ()
-mapIO f []     = return ()
-mapIO f (x:xs) = f x >> mapIO f xs
-\end{code}