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