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