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 \end{code}
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Write a new interface file}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 writeIface this_mod old_iface new_iface
  82            local_tycons local_classes inst_info
  83            final_ids tidy_binds tidy_orphan_rules
  84   =
  85     if isNothing opt_HiDir && isNothing opt_HiFile
  86         then return ()  -- not producing any .hi file
  87         else
  88
  89     let
  90         hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
  91         filename = case opt_HiFile of {
  92                         Just f  -> f;
  93                         Nothing ->
  94                    case opt_HiDir of {
  95                         Just dir -> dir ++ '/':moduleUserString this_mod
  96                                         ++ '.':hi_suf;
  97                         Nothing  -> panic "writeIface"
  98                 }}
  99     in
 100
 101     case checkIface old_iface full_new_iface of {
 102         Nothing -> do { putStrLn "Interface file unchanged" ;
 103                         return () } ;   -- No need to update .hi file
 104
 105         Just final_iface ->
 106
 107     do  let mod_vers_unchanged = case old_iface of
 108                                    Just iface -> pi_vers iface == pi_vers final_iface
 109                                    Nothing -> False
 110         if mod_vers_unchanged
 111            then putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 112            else return ()
 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_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
 337    = dfun_id1 < dfun_id2
 338         -- The dfuns are assigned names df1, df2, etc,
 339         -- in order of original textual
 340         -- occurrence, and this makes as good a sort order as any
 341
 342 lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
 343 \end{code}
 344
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection{Completion stuff}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
 354 ifaceRules rules emitted
 355   = orphan_rules ++ local_rules
 356   where
 357     orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
 358     local_rules  = [ toHsRule fn rule
 359                    | fn <- varSetElems emitted,
 360                      rule <- rulesRules (idSpecialisation fn),
 361                      not (isBuiltinRule rule),
 362                                 -- We can't print builtin rules in interface files
 363                                 -- Since they are built in, an importing module
 364                                 -- will have access to them anyway
 365                      all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
 366                                 -- Spit out a rule only if all its lhs free vars are emitted
 367                                 -- This is a good reason not to do it when we emit the Id itself
 368                    ]
 369 \end{code}
 370
 371 \begin{code}
 372 ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
 373                    -- The IdSet is the needed dfuns
 374
 375 ifaceInstances inst_infos
 376   = (decls, needed_ids)
 377   where
 378     decls       = map to_decl togo_insts
 379     togo_insts  = filter is_togo_inst (bagToList inst_infos)
 380     needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
 381     is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
 382
 383     -------
 384     to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
 385       = let
 386                 -- The deNoteType is very important.   It removes all type
 387                 -- synonyms from the instance type in interface files.
 388                 -- That in turn makes sure that when reading in instance decls
 389                 -- from interface files that the 'gating' mechanism works properly.
 390                 -- Otherwise you could have
 391                 --      type Tibble = T Int
 392                 --      instance Foo Tibble where ...
 393                 -- and this instance decl wouldn't get imported into a module
 394                 -- that mentioned T but not Tibble.
 395             forall_ty     = mkSigmaTy tvs (classesToPreds theta)
 396                                       (deNoteType (mkDictTy clas tys))
 397             tidy_ty = tidyTopType forall_ty
 398         in
 399         InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc
 400 \end{code}
 401
 402 \begin{code}
 403 ifaceTyCon :: TyCon -> RdrNameHsDecl
 404 ifaceTyCon tycon
 405   | isSynTyCon tycon
 406   = TyClD (TySynonym (toRdrName tycon)
 407                      (toHsTyVars tyvars) (toHsType ty)
 408                      noSrcLoc)
 409   where
 410     (tyvars, ty) = getSynTyConDefn tycon
 411
 412 ifaceTyCon tycon
 413   | isAlgTyCon tycon
 414   = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
 415                   (toRdrName tycon)
 416                   (toHsTyVars tyvars)
 417                   (map ifaceConDecl (tyConDataCons tycon))
 418                   (tyConFamilySize tycon)
 419                   Nothing NoDataPragmas noSrcLoc)
 420   where
 421     tyvars = tyConTyVars tycon
 422     new_or_data | isNewTyCon tycon = NewType
 423                 | otherwise        = DataType
 424
 425     ifaceConDecl data_con
 426         = ConDecl (toRdrName data_con) (error "ifaceConDecl")
 427                   (toHsTyVars ex_tyvars)
 428                   (toHsContext ex_theta)
 429                   details noSrcLoc
 430         where
 431           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
 432           field_labels   = dataConFieldLabels data_con
 433           strict_marks   = dataConStrictMarks data_con
 434           details
 435             | null field_labels
 436             = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
 437               VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 438
 439             | otherwise
 440             = RecCon (zipWith mk_field strict_marks field_labels)
 441
 442     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
 443     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
 444     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 445
 446     mk_field strict_mark field_label
 447         = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 448
 449 ifaceTyCon tycon
 450   = pprPanic "pprIfaceTyDecl" (ppr tycon)
 451
 452 ifaceClass clas
 453   = TyClD (ClassDecl (toHsContext sc_theta)
 454                      (toRdrName clas)
 455                      (toHsTyVars clas_tyvars)
 456                      (toHsFDs clas_fds)
 457                      (map toClassOpSig op_stuff)
 458                      EmptyMonoBinds NoClassPragmas
 459                      bogus bogus bogus [] noSrcLoc
 460     )
 461   where
 462      bogus = error "ifaceClass"
 463      (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 464
 465      toClassOpSig (sel_id, dm_id, explicit_dm)
 466         = ASSERT( sel_tyvars == clas_tyvars)
 467           ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
 468         where
 469           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
 470 \end{code}
 471
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection{Value bindings}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 ifaceBinds :: IdSet             -- These Ids are needed already
 481            -> [Id]              -- Ids used at code-gen time; they have better pragma info!
 482            -> [CoreBind]        -- In dependency order, later depend on earlier
 483            -> (Bag RdrNameHsDecl, IdSet)                -- Set of Ids actually spat out
 484
 485 ifaceBinds needed_ids final_ids binds
 486   = go needed_ids (reverse binds) emptyBag emptyVarSet
 487                 -- Reverse so that later things will
 488                 -- provoke earlier ones to be emitted
 489   where
 490     final_id_map  = listToUFM [(id,id) | id <- final_ids]
 491     get_idinfo id = case lookupUFM final_id_map id of
 492                         Just id' -> idInfo id'
 493                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
 494                                     idInfo id
 495
 496     go needed [] decls emitted
 497         | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
 498                                           (sep (map ppr (varSetElems needed)))
 499                                        (decls, emitted)
 500         | otherwise                  = (decls, emitted)
 501
 502     go needed (NonRec id rhs : binds) decls emitted
 503         = case ifaceId get_idinfo needed False id rhs of
 504                 Nothing               -> go needed binds decls emitted
 505                 Just (decl, extras) -> let
 506                         needed' = (needed `unionVarSet` extras) `delVarSet` id
 507                         -- 'extras' can include the Id itself via a rule
 508                         emitted' = emitted `extendVarSet` id
 509                         in
 510                         go needed' binds (decl `consBag` decls) emitted'
 511
 512         -- Recursive groups are a bit more of a pain.  We may only need one to
 513         -- start with, but it may call out the next one, and so on.  So we
 514         -- have to look for a fixed point.
 515     go needed (Rec pairs : binds) decls emitted
 516         = go needed' binds decls' emitted'
 517         where
 518           (new_decls, new_emitted, extras) = go_rec needed pairs
 519           decls'   = new_decls `unionBags` decls
 520           needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
 521           emitted' = emitted `unionVarSet` new_emitted
 522
 523     go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
 524     go_rec needed pairs
 525         | null decls = (emptyBag, emptyVarSet, emptyVarSet)
 526         | otherwise     = (more_decls `unionBags`   listToBag decls,
 527                            more_emitted  `unionVarSet` mkVarSet emitted,
 528                            more_extras   `unionVarSet` extras)
 529         where
 530           maybes             = map do_one pairs
 531           emitted            = [id   | ((id,_), Just _)  <- pairs `zip` maybes]
 532           reduced_pairs      = [pair | (pair,   Nothing) <- pairs `zip` maybes]
 533           (decls, extras_s)  = unzip (catMaybes maybes)
 534           extras             = unionVarSets extras_s
 535           (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs
 536
 537           do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
 538 \end{code}
 539
 540
 541 \begin{code}
 542 ifaceId :: (Id -> IdInfo)       -- This function "knows" the extra info added
 543                                 -- by the STG passes.  Sigh
 544
 545         -> IdSet                -- Set of Ids that are needed by earlier interface
 546                                 -- file emissions.  If the Id isn't in this set, and isn't
 547                                 -- exported, there's no need to emit anything
 548         -> Bool                 -- True <=> recursive, so don't print unfolding
 549         -> Id
 550         -> CoreExpr             -- The Id's right hand side
 551         -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
 552
 553 ifaceId get_idinfo needed_ids is_rec id rhs
 554   | not (id `elemVarSet` needed_ids ||          -- Needed [no id in needed_ids has omitIfaceSigForId]
 555         (isUserExportedId id && not (omitIfaceSigForId id)))    -- or exported and not to be omitted
 556   = Nothing             -- Well, that was easy!
 557
 558 ifaceId get_idinfo needed_ids is_rec id rhs
 559   = ASSERT2( arity_matches_strictness, ppr id )
 560     Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),
 561           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     arity_hsinfo = case arityInfo stg_idinfo of
 574                         a@(ArityExactly n) -> [HsArity a]
 575                         other              -> []
 576
 577     ------------ Caf Info --------------
 578     caf_hsinfo = case cafInfo stg_idinfo of
 579                    NoCafRefs -> [HsNoCafRefs]
 580                    otherwise -> []
 581
 582     ------------ CPR Info --------------
 583     cpr_hsinfo = case cprInfo core_idinfo of
 584                    ReturnsCPR -> [HsCprInfo]
 585                    NoCPRInfo  -> []
 586
 587     ------------  Strictness  --------------
 588     strict_info   = strictnessInfo core_idinfo
 589     bottoming_fn  = isBottomingStrictness strict_info
 590     strict_hsinfo = case strict_info of
 591                         NoStrictnessInfo -> []
 592                         info             -> [HsStrictness info]
 593
 594
 595     ------------  Worker  --------------
 596     work_info     = workerInfo core_idinfo
 597     has_worker    = workerExists work_info
 598     wrkr_hsinfo   = case work_info of
 599                         HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
 600                         other               -> []
 601
 602     ------------  Unfolding  --------------
 603     inline_pragma  = inlinePragInfo core_idinfo
 604     dont_inline    = isNeverInlinePrag inline_pragma
 605
 606     unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
 607                   | otherwise   = []
 608
 609     show_unfold = not has_worker         &&     -- Not unnecessary
 610                   not bottoming_fn       &&     -- Not necessary
 611                   not dont_inline        &&
 612                   not loop_breaker       &&
 613                   rhs_is_small           &&     -- Small enough
 614                   okToUnfoldInHiFile rhs        -- No casms etc
 615
 616     rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
 617
 618     ------------  Specialisations --------------
 619     spec_info   = specInfo core_idinfo
 620
 621     ------------  Occ info  --------------
 622     loop_breaker  = isLoopBreaker (occInfo core_idinfo)
 623
 624     ------------  Extra free Ids  --------------
 625     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 626                    | otherwise                = worker_ids      `unionVarSet`
 627                                                 unfold_ids      `unionVarSet`
 628                                                 spec_ids
 629
 630     worker_ids = case work_info of
 631                    HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
 632                         -- Conceivably, the worker might come from
 633                         -- another module
 634                    other -> emptyVarSet
 635
 636     spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
 637
 638     unfold_ids | show_unfold = find_fvs rhs
 639                | otherwise   = emptyVarSet
 640
 641     find_fvs expr = exprSomeFreeVars interestingId expr
 642
 643     ------------ Sanity checking --------------
 644         -- The arity of a wrapper function should match its strictness,
 645         -- or else an importing module will get very confused indeed.
 646     arity_matches_strictness
 647        = case work_info of
 648              HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
 649              other                  -> True
 650
 651 interestingId id = isId id && isLocallyDefined id &&
 652                    not (omitIfaceSigForId id)
 653 \end{code}
 654