ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[MkIface]{Print an interface for a module}
   5
   6 \begin{code}
   7 module MkIface ( writeIface  ) where
   8
   9 #include "HsVersions.h"
  10
  11 import IO               ( Handle, hPutStr, openFile,
  12                           hClose, hPutStrLn, IOMode(..) )
  13
  14 import HsSyn
  15 import HsCore           ( HsIdInfo(..), toUfExpr )
  16 import RdrHsSyn         ( RdrNameRuleDecl )
  17 import HsPragmas        ( DataPragmas(..), ClassPragmas(..) )
  18 import HsTypes          ( toHsTyVars )
  19 import BasicTypes       ( Fixity(..), FixityDirection(..), NewOrData(..),
  20                           Version, bumpVersion, initialVersion, isLoopBreaker
  21                         )
  22 import RnMonad
  23
  24 import TcInstUtil       ( InstInfo(..) )
  25
  26 import CmdLineOpts
  27 import Id               ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
  28                           idSpecialisation
  29                         )
  30 import Var              ( isId )
  31 import VarSet
  32 import DataCon          ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
  33 import IdInfo           ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..),
  34                           CprInfo(..), CafInfo(..),
  35                           inlinePragInfo, arityInfo, arityLowerBound,
  36                           strictnessInfo, isBottomingStrictness,
  37                           cafInfo, specInfo, cprInfo,
  38                           occInfo, isNeverInlinePrag,
  39                           workerExists, workerInfo, WorkerInfo(..)
  40                         )
  41 import CoreSyn          ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
  42 import CoreFVs          ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
  43 import CoreUnfold       ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
  44 import Module           ( moduleString, pprModule, pprModuleName, moduleUserString )
  45 import Name             ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
  46                           Name, NamedThing(..)
  47                         )
  48 import OccName          ( OccName, pprOccName )
  49 import TyCon            ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
  50                           tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
  51                         )
  52 import Class            ( Class, classExtraBigSig )
  53 import FieldLabel       ( fieldLabelName, fieldLabelType )
  54 import Type             ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
  55                           deNoteType, classesToPreds,
  56                           Type, ThetaType, PredType(..), ClassContext
  57                         )
  58
  59 import PprType
  60 import Rules            ( pprProtoCoreRule, ProtoCoreRule(..) )
  61
  62 import Bag              ( bagToList, isEmptyBag )
  63 import Maybes           ( catMaybes, maybeToBool )
  64 import UniqFM           ( lookupUFM, listToUFM )
  65 import Util             ( sortLt, mapAccumL )
  66 import SrcLoc           ( noSrcLoc )
  67 import Bag
  68 import Outputable
  69 import ErrUtils         ( dumpIfSet )
  70
  71 import Maybe            ( isNothing )
  72 import List             ( partition )
  73 import Monad            ( when )
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Write a new interface file}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 writeIface this_mod old_iface new_iface
  85            local_tycons local_classes inst_info
  86            final_ids tidy_binds tidy_orphan_rules
  87   =
  88     if isNothing opt_HiDir && isNothing opt_HiFile
  89         then return ()  -- not producing any .hi file
  90         else
  91
  92     let
  93         hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
  94         filename = case opt_HiFile of {
  95                         Just f  -> f;
  96                         Nothing ->
  97                    case opt_HiDir of {
  98                         Just dir -> dir ++ '/':moduleUserString this_mod
  99                                         ++ '.':hi_suf;
 100                         Nothing  -> panic "writeIface"
 101                 }}
 102     in
 103
 104     do maybe_final_iface <- checkIface old_iface full_new_iface
 105        case maybe_final_iface of {
 106           Nothing -> when opt_D_dump_rn_trace $
 107                      putStrLn "Interface file unchanged" ;  -- No need to update .hi file
 108
 109           Just final_iface ->
 110
 111        do  let mod_vers_unchanged = case old_iface of
 112                                    Just iface -> pi_vers iface == pi_vers final_iface
 113                                    Nothing -> False
 114            when (mod_vers_unchanged && opt_D_dump_rn_trace) $
 115                 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 116
 117            if_hdl <- openFile filename WriteMode
 118            printForIface if_hdl (pprIface final_iface)
 119            hClose if_hdl
 120     }
 121   where
 122     full_new_iface = completeIface new_iface local_tycons local_classes
 123                                              inst_info final_ids tidy_binds
 124                                              tidy_orphan_rules
 125 \end{code}
 126
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection{Checking if the new interface is up to date
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 checkIface :: Maybe ParsedIface         -- The old interface, read from M.hi
 136            -> ParsedIface               -- The new interface; but with all version numbers = 1
 137            -> IO (Maybe ParsedIface)    -- Nothing => no change; no need to write new Iface
 138                                         -- Just pi => Here is the new interface to write
 139                                         --            with correct version numbers
 140                 -- The I/O part is just so it can print differences
 141
 142 -- NB: the fixities, declarations, rules are all assumed
 143 -- to be sorted by increasing order of hsDeclName, so that
 144 -- we can compare for equality
 145
 146 checkIface Nothing new_iface
 147 -- No old interface, so definitely write a new one!
 148   = return (Just new_iface)
 149
 150 checkIface (Just iface) new_iface
 151   | no_output_change && no_usage_change
 152   = return Nothing
 153
 154   | otherwise           -- Add updated version numbers
 155   = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
 156          return (Just new_iface )}
 157
 158   where
 159     final_iface = new_iface { pi_vers = new_mod_vers,
 160                               pi_fixity = (new_fixity_vers, new_fixities),
 161                               pi_rules  = (new_rules_vers,  new_rules),
 162                               pi_decls  = final_decls }
 163
 164     no_usage_change = pi_usages iface == pi_usages new_iface
 165
 166     no_output_change = no_decl_changed &&
 167                        new_fixity_vers == fixity_vers &&
 168                        new_rules_vers == rules_vers &&
 169                        no_export_change
 170
 171     no_export_change = pi_exports iface == pi_exports new_iface
 172
 173     new_mod_vers | no_output_change = mod_vers
 174                  | otherwise        = bumpVersion mod_vers
 175
 176     mod_vers = pi_vers iface
 177
 178     (fixity_vers, fixities) = pi_fixity iface
 179     (_,       new_fixities) = pi_fixity new_iface
 180     new_fixity_vers | fixities == new_fixities = fixity_vers
 181                     | otherwise                = bumpVersion fixity_vers
 182
 183     (rules_vers, rules) = pi_rules iface
 184     (_,      new_rules) = pi_rules new_iface
 185     new_rules_vers  | rules == new_rules = rules_vers
 186                     | otherwise          = bumpVersion rules_vers
 187
 188     (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
 189
 190         -- Fill in the version number on the new declarations
 191         -- by looking at the old declarations.
 192         -- Set the flag if anything changes.
 193         -- Assumes that the decls are sorted by hsDeclName
 194     merge_decls ok_so_far pp acc []  []        = (ok_so_far, pp, reverse acc)
 195     merge_decls ok_so_far pp acc old []        = (False,     pp, reverse acc)
 196     merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
 197     merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
 198         = case d_name `compare` nd_name of
 199                 LT -> merge_decls False (pp $$ only_old vd)  acc       vds      (nvd:nvds)
 200                 GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
 201                 EQ | d == nd   -> merge_decls ok_so_far pp                   (vd:acc)                  vds nvds
 202                    | otherwise -> merge_decls False     (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
 203         where
 204           d_name  = hsDeclName d
 205           nd_name = hsDeclName nd
 206
 207     only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
 208     only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
 209     changed d nd   = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
 210                                                            (ptext SLIT("New:") <+> ppr nd))
 211 \end{code}
 212
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 \subsection{Printing the interface}
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
 223                         pi_usages = usages, pi_exports = exports,
 224                         pi_fixity = (fix_vers, fixities),
 225                         pi_insts = insts, pi_decls = decls,
 226                         pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
 227  = vcat [ ptext SLIT("__interface")
 228                 <+> doubleQuotes (ptext opt_InPackage)
 229                 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
 230                 <+> (if orphan then char '!' else empty)
 231                 <+> int opt_HiVersion
 232                 <+> ptext SLIT("where")
 233         , vcat (map pprExport exports)
 234         , vcat (map pprUsage usages)
 235         , pprFixities fixities
 236         , vcat [ppr i <+> semi | i <- insts]
 237         , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
 238         , pprRules rules
 239         , pprDeprecs deprecs
 240         ]
 241   where
 242     ppr_vers v | v == initialVersion = empty
 243                | otherwise           = int v
 244     pp_sub_vers
 245         | fix_vers == initialVersion && rule_vers == initialVersion = empty
 246         | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
 247 \end{code}
 248
 249 When printing export lists, we print like this:
 250         Avail   f               f
 251         AvailTC C [C, x, y]     C(x,y)
 252         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 253
 254 \begin{code}
 255 pprExport :: ExportItem -> SDoc
 256 pprExport (mod, items)
 257  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
 258   where
 259     upp_avail :: RdrAvailInfo -> SDoc
 260     upp_avail (Avail name)      = pprOccName name
 261     upp_avail (AvailTC name []) = empty
 262     upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
 263                                 where
 264                                   bang | name `elem` ns = empty
 265                                        | otherwise      = char '|'
 266                                   ns' = filter (/= name) ns
 267
 268     upp_export []    = empty
 269     upp_export names = braces (hsep (map pprOccName names))
 270 \end{code}
 271
 272
 273 \begin{code}
 274 pprUsage :: ImportVersion OccName -> SDoc
 275 pprUsage (m, has_orphans, is_boot, whats_imported)
 276   = hsep [ptext SLIT("import"), pprModuleName m,
 277           pp_orphan, pp_boot,
 278           upp_import_versions whats_imported
 279     ] <> semi
 280   where
 281     pp_orphan | has_orphans = char '!'
 282               | otherwise   = empty
 283     pp_boot   | is_boot     = char '@'
 284               | otherwise   = empty
 285
 286         -- Importing the whole module is indicated by an empty list
 287     upp_import_versions NothingAtAll   = empty
 288     upp_import_versions (Everything v) = dcolon <+> int v
 289     upp_import_versions (Specifically vm vf vr nvs)
 290       = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
 291 \end{code}
 292
 293
 294 \begin{code}
 295 pprFixities []    = empty
 296 pprFixities fixes = hsep (map ppr fixes) <> semi
 297
 298 pprRules []    = empty
 299 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
 300
 301 pprDeprecs []   = empty
 302 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
 303                 where
 304                   guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
 305                               | Deprecation ie txt _ <- deps ]
 306 \end{code}
 307
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection{Completing the new interface}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 \begin{code}
 316 completeIface new_iface local_tycons local_classes
 317                         inst_info final_ids tidy_binds
 318                         tidy_orphan_rules
 319   = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
 320                 pi_insts = sortLt lt_inst_decl inst_dcls,
 321                 pi_rules = (initialVersion, rule_dcls)
 322     }
 323   where
 324      all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
 325      (inst_dcls, inst_ids) = ifaceInstances inst_info
 326      cls_dcls = map ifaceClass local_classes
 327
 328      ty_dcls  = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
 329
 330      (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
 331                                           final_ids tidy_binds
 332
 333      rule_dcls | opt_OmitInterfacePragmas = []
 334                | otherwise                = ifaceRules tidy_orphan_rules emitted_ids
 335
 336      orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
 337                                     | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
 338
 339 lt_decl      d1 d2 = hsDeclName   d1 < hsDeclName d2
 340 lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
 341         -- Even instance decls have names, namely the dfun name
 342 \end{code}
 343
 344
 345 %************************************************************************
 346 %*                                                                      *
 347 \subsection{Completion stuff}
 348 %*                                                                      *
 349 %************************************************************************
 350
 351 \begin{code}
 352 ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
 353 ifaceRules rules emitted
 354   = orphan_rules ++ local_rules
 355   where
 356     orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
 357     local_rules  = [ toHsRule fn rule
 358                    | fn <- varSetElems emitted,
 359                      rule <- rulesRules (idSpecialisation fn),
 360                      not (isBuiltinRule rule),
 361                                 -- We can't print builtin rules in interface files
 362                                 -- Since they are built in, an importing module
 363                                 -- will have access to them anyway
 364
 365                         -- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
 366                         -- from coming out, and to make it work properly we need to add
 367                              all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
 368                                 -- Spit out a rule only if all its lhs free vars are emitted
 369                                 -- This is a good reason not to do it when we emit the Id itself
 370                    ]
 371 \end{code}
 372
 373 \begin{code}
 374 ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
 375                    -- The IdSet is the needed dfuns
 376
 377 ifaceInstances inst_infos
 378   = (decls, needed_ids)
 379   where
 380     decls       = map to_decl togo_insts
 381     togo_insts  = filter is_togo_inst (bagToList inst_infos)
 382     needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
 383     is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
 384
 385     -------
 386     to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
 387       = let
 388                 -- The deNoteType is very important.   It removes all type
 389                 -- synonyms from the instance type in interface files.
 390                 -- That in turn makes sure that when reading in instance decls
 391                 -- from interface files that the 'gating' mechanism works properly.
 392                 -- Otherwise you could have
 393                 --      type Tibble = T Int
 394                 --      instance Foo Tibble where ...
 395                 -- and this instance decl wouldn't get imported into a module
 396                 -- that mentioned T but not Tibble.
 397             forall_ty     = mkSigmaTy tvs (classesToPreds theta)
 398                                       (deNoteType (mkDictTy clas tys))
 399             tidy_ty = tidyTopType forall_ty
 400         in
 401         InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
 402 \end{code}
 403
 404 \begin{code}
 405 ifaceTyCon :: TyCon -> RdrNameHsDecl
 406 ifaceTyCon tycon
 407   | isSynTyCon tycon
 408   = TyClD (TySynonym (toRdrName tycon)
 409                      (toHsTyVars tyvars) (toHsType ty)
 410                      noSrcLoc)
 411   where
 412     (tyvars, ty) = getSynTyConDefn tycon
 413
 414 ifaceTyCon tycon
 415   | isAlgTyCon tycon
 416   = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
 417                   (toRdrName tycon)
 418                   (toHsTyVars tyvars)
 419                   (map ifaceConDecl (tyConDataCons tycon))
 420                   (tyConFamilySize tycon)
 421                   Nothing NoDataPragmas noSrcLoc)
 422   where
 423     tyvars = tyConTyVars tycon
 424     new_or_data | isNewTyCon tycon = NewType
 425                 | otherwise        = DataType
 426
 427     ifaceConDecl data_con
 428         = ConDecl (toRdrName data_con) (error "ifaceConDecl")
 429                   (toHsTyVars ex_tyvars)
 430                   (toHsContext ex_theta)
 431                   details noSrcLoc
 432         where
 433           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
 434           field_labels   = dataConFieldLabels data_con
 435           strict_marks   = dataConStrictMarks data_con
 436           details
 437             | null field_labels
 438             = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
 439               VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 440
 441             | otherwise
 442             = RecCon (zipWith mk_field strict_marks field_labels)
 443
 444     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
 445     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
 446     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 447
 448     mk_field strict_mark field_label
 449         = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 450
 451 ifaceTyCon tycon
 452   = pprPanic "pprIfaceTyDecl" (ppr tycon)
 453
 454 ifaceClass clas
 455   = TyClD (ClassDecl (toHsContext sc_theta)
 456                      (toRdrName clas)
 457                      (toHsTyVars clas_tyvars)
 458                      (toHsFDs clas_fds)
 459                      (map toClassOpSig op_stuff)
 460                      EmptyMonoBinds NoClassPragmas
 461                      bogus bogus bogus [] noSrcLoc
 462     )
 463   where
 464      bogus = error "ifaceClass"
 465      (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 466
 467      toClassOpSig (sel_id, dm_id, explicit_dm)
 468         = ASSERT( sel_tyvars == clas_tyvars)
 469           ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
 470         where
 471           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
 472 \end{code}
 473
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Value bindings}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 ifaceBinds :: IdSet             -- These Ids are needed already
 483            -> [Id]              -- Ids used at code-gen time; they have better pragma info!
 484            -> [CoreBind]        -- In dependency order, later depend on earlier
 485            -> (Bag RdrNameHsDecl, IdSet)                -- Set of Ids actually spat out
 486
 487 ifaceBinds needed_ids final_ids binds
 488   = go needed_ids (reverse binds) emptyBag emptyVarSet
 489                 -- Reverse so that later things will
 490                 -- provoke earlier ones to be emitted
 491   where
 492     final_id_map  = listToUFM [(id,id) | id <- final_ids]
 493     get_idinfo id = case lookupUFM final_id_map id of
 494                         Just id' -> idInfo id'
 495                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
 496                                     idInfo id
 497
 498         -- The 'needed' set contains the Ids that are needed by earlier
 499         -- interface file emissions.  If the Id isn't in this set, and isn't
 500         -- exported, there's no need to emit anything
 501     need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
 502
 503     go needed [] decls emitted
 504         | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
 505                                           (sep (map ppr (varSetElems needed)))
 506                                        (decls, emitted)
 507         | otherwise                  = (decls, emitted)
 508
 509     go needed (NonRec id rhs : binds) decls emitted
 510         | need_id needed id
 511         = if omitIfaceSigForId id then
 512             go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
 513           else
 514             go ((needed `unionVarSet` extras) `delVarSet` id)
 515                binds
 516                (decl `consBag` decls)
 517                (emitted `extendVarSet` id)
 518         | otherwise
 519         = go needed binds decls emitted
 520         where
 521           (decl, extras) = ifaceId get_idinfo False id rhs
 522
 523         -- Recursive groups are a bit more of a pain.  We may only need one to
 524         -- start with, but it may call out the next one, and so on.  So we
 525         -- have to look for a fixed point.  We don't want necessarily them all,
 526         -- because without -O we may only need the first one (if we don't emit
 527         -- its unfolding)
 528     go needed (Rec pairs : binds) decls emitted
 529         = go needed' binds decls' emitted'
 530         where
 531           (new_decls, new_emitted, extras) = go_rec needed pairs
 532           decls'   = new_decls `unionBags` decls
 533           needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
 534           emitted' = emitted `unionVarSet` new_emitted
 535
 536     go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
 537     go_rec needed pairs
 538         | null decls = (emptyBag, emptyVarSet, emptyVarSet)
 539         | otherwise  = (more_decls   `unionBags`   listToBag decls,
 540                         more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
 541                         more_extras  `unionVarSet` extras)
 542         where
 543           (needed_prs,leftover_prs) = partition is_needed pairs
 544           (decls, extras_s)         = unzip [ifaceId get_idinfo True id rhs
 545                                             | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
 546           extras                    = unionVarSets extras_s
 547           (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
 548           is_needed (id,_) = need_id needed id
 549 \end{code}
 550
 551
 552 \begin{code}
 553 ifaceId :: (Id -> IdInfo)       -- This function "knows" the extra info added
 554                                 -- by the STG passes.  Sigh
 555         -> Bool                 -- True <=> recursive, so don't print unfolding
 556         -> Id
 557         -> CoreExpr             -- The Id's right hand side
 558         -> (RdrNameHsDecl, IdSet)       -- The emitted stuff, plus any *extra* needed Ids
 559
 560 ifaceId get_idinfo is_rec id rhs
 561   = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),  new_needed_ids)
 562   where
 563     id_type     = idType id
 564     core_idinfo = idInfo id
 565     stg_idinfo  = get_idinfo id
 566
 567     hs_idinfo | opt_OmitInterfacePragmas = []
 568               | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++
 569                                            strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 570
 571     ------------  Arity  --------------
 572     arity_info   = arityInfo stg_idinfo
 573     stg_arity    = arityLowerBound arity_info
 574     arity_hsinfo = case arityInfo stg_idinfo of
 575                         a@(ArityExactly n) -> [HsArity a]
 576                         other              -> []
 577
 578     ------------ Caf Info --------------
 579     caf_hsinfo = case cafInfo stg_idinfo of
 580                    NoCafRefs -> [HsNoCafRefs]
 581                    otherwise -> []
 582
 583     ------------ CPR Info --------------
 584     cpr_hsinfo = case cprInfo core_idinfo of
 585                    ReturnsCPR -> [HsCprInfo]
 586                    NoCPRInfo  -> []
 587
 588     ------------  Strictness  --------------
 589     strict_info   = strictnessInfo core_idinfo
 590     bottoming_fn  = isBottomingStrictness strict_info
 591     strict_hsinfo = case strict_info of
 592                         NoStrictnessInfo -> []
 593                         info             -> [HsStrictness info]
 594
 595
 596     ------------  Worker  --------------
 597         -- We only treat a function as having a worker if
 598         -- the exported arity (which is now the number of visible lambdas)
 599         -- is the same as the arity at the moment of the w/w split
 600         -- If so, we can safely omit the unfolding inside the wrapper, and
 601         -- instead re-generate it from the type/arity/strictness info
 602         -- But if the arity has changed, we just take the simple path and
 603         -- put the unfolding into the interface file, forgetting the fact
 604         -- that it's a wrapper.
 605         --
 606         -- How can this happen?  Sometimes we get
 607         --      f = coerce t (\x y -> $wf x y)
 608         -- at the moment of w/w split; but the eta reducer turns it into
 609         --      f = coerce t $wf
 610         -- which is perfectly fine except that the exposed arity so far as
 611         -- the code generator is concerned (zero) differs from the arity
 612         -- when we did the split (2).
 613         --
 614         -- All this arises because we use 'arity' to mean "exactly how many
 615         -- top level lambdas are there" in interface files; but during the
 616         -- compilation of this module it means "how many things can I apply
 617         -- this to".
 618     work_info           = workerInfo core_idinfo
 619     HasWorker work_id _ = work_info
 620
 621     has_worker = case work_info of
 622                   HasWorker work_id wrap_arity
 623                    | wrap_arity == stg_arity -> True
 624                    | otherwise               -> pprTrace "ifaceId: arity change:" (ppr id)
 625                                                 False
 626
 627                   other                      -> False
 628
 629     wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
 630                 | otherwise  = []
 631
 632     ------------  Unfolding  --------------
 633     inline_pragma  = inlinePragInfo core_idinfo
 634     dont_inline    = isNeverInlinePrag inline_pragma
 635
 636     unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
 637                   | otherwise   = []
 638
 639     show_unfold = not has_worker         &&     -- Not unnecessary
 640                   not bottoming_fn       &&     -- Not necessary
 641                   not dont_inline        &&
 642                   not loop_breaker       &&
 643                   rhs_is_small           &&     -- Small enough
 644                   okToUnfoldInHiFile rhs        -- No casms etc
 645
 646     rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
 647
 648     ------------  Specialisations --------------
 649     spec_info   = specInfo core_idinfo
 650
 651     ------------  Occ info  --------------
 652     loop_breaker  = isLoopBreaker (occInfo core_idinfo)
 653
 654     ------------  Extra free Ids  --------------
 655     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 656                    | otherwise                = worker_ids      `unionVarSet`
 657                                                 unfold_ids      `unionVarSet`
 658                                                 spec_ids
 659
 660     worker_ids | has_worker && interestingId work_id = unitVarSet work_id
 661                         -- Conceivably, the worker might come from
 662                         -- another module
 663                | otherwise = emptyVarSet
 664
 665     spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
 666
 667     unfold_ids | show_unfold = find_fvs rhs
 668                | otherwise   = emptyVarSet
 669
 670     find_fvs expr = exprSomeFreeVars interestingId expr
 671
 672     ------------ Sanity checking --------------
 673         -- The arity of a wrapper function should match its strictness,
 674         -- or else an importing module will get very confused indeed.
 675     arity_matches_strictness
 676        = case work_info of
 677              HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
 678              other                  -> True
 679
 680 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
 681 \end{code}
 682