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