ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[MkIface]{Print an interface for a module}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module MkIface (
  10         startIface, endIface,
  11         ifaceMain, ifaceInstances,
  12         ifaceDecls
  13     ) where
  14
  15 IMP_Ubiq(){-uitous-}
  16 IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
  17
  18 import HsSyn
  19 import RdrHsSyn         ( RdrName(..) )
  20 import RnHsSyn          ( SYN_IE(RenamedHsModule) )
  21 import RnMonad
  22
  23 import TcInstUtil       ( InstInfo(..) )
  24
  25 import CmdLineOpts
  26 import Id               ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
  27                           getIdInfo, idWantsToBeINLINEd, wantIdSigInIface,
  28                           dataConStrictMarks, StrictnessMark(..),
  29                           SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet,
  30                           isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
  31                           GenId{-instance NamedThing/Outputable-}
  32                         )
  33 import IdInfo           ( StrictnessInfo, ArityInfo, Unfolding,
  34                           arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
  35                           getWorkerId_maybe, bottomIsGuaranteed
  36                         )
  37 import CoreSyn          ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
  38 import CoreUnfold       ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
  39 import FreeVars         ( addExprFVs )
  40 import Name             ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName,
  41                           OccName, occNameString, nameOccName, nameString, isExported, pprNonSym,
  42                           Name {-instance NamedThing-}, Provenance
  43                         )
  44 import TyCon            ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
  45 import Class            ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType )
  46 import FieldLabel       ( FieldLabel{-instance NamedThing-} )
  47 import Type             ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
  48 import TyVar            ( GenTyVar {- instance Eq -} )
  49 import Unique           ( Unique {- instance Eq -} )
  50
  51 import PprEnv           -- not sure how much...
  52 import PprStyle         ( PprStyle(..) )
  53 import PprType
  54 import PprCore          ( pprIfaceUnfolding )
  55 import Pretty
  56 import Unpretty         -- ditto
  57
  58
  59 import Bag              ( bagToList )
  60 import Maybes           ( catMaybes, maybeToBool )
  61 import FiniteMap        ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
  62 import UniqFM           ( UniqFM, lookupUFM, listToUFM )
  63 import Util             ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
  64                           assertPanic, panic{-ToDo:rm-}, pprTrace )
  65
  66 \end{code}
  67
  68 We have a function @startIface@ to open the output file and put
  69 (something like) ``interface Foo'' in it.  It gives back a handle
  70 for subsequent additions to the interface file.
  71
  72 We then have one-function-per-block-of-interface-stuff, e.g.,
  73 @ifaceExportList@ produces the @__exports__@ section; it appends
  74 to the handle provided by @startIface@.
  75
  76 \begin{code}
  77 startIface  :: Module
  78             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  79
  80 ifaceMain   :: Maybe Handle
  81             -> InterfaceDetails
  82             -> IO ()
  83
  84 ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO ()
  85
  86 ifaceDecls :: Maybe Handle
  87            -> RenamedHsModule
  88            -> [Id]              -- Ids used at code-gen time; they have better pragma info!
  89            -> [CoreBinding]     -- In dependency order, later depend on earlier
  90            -> IO ()
  91
  92 endIface    :: Maybe Handle -> IO ()
  93 \end{code}
  94
  95 \begin{code}
  96 startIface mod
  97   = case opt_ProduceHi of
  98       Nothing -> return Nothing -- not producing any .hi file
  99       Just fn ->
 100         openFile fn WriteMode   >>= \ if_hdl ->
 101         hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
 102         return (Just if_hdl)
 103
 104 endIface Nothing        = return ()
 105 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
 106 \end{code}
 107
 108
 109 \begin{code}
 110 ifaceMain Nothing iface_stuff = return ()
 111 ifaceMain (Just if_hdl)
 112           (import_usages, ExportEnv avails fixities, instance_modules)
 113   =
 114     ifaceInstanceModules        if_hdl instance_modules         >>
 115     ifaceUsages                 if_hdl import_usages            >>
 116     ifaceExports                if_hdl avails                   >>
 117     ifaceFixities               if_hdl fixities                 >>
 118     return ()
 119
 120 ifaceDecls Nothing rn_mod final_ids simplified = return ()
 121 ifaceDecls (Just hdl)
 122            (HsModule _ _ _ _ _ decls _)
 123            final_ids binds
 124   | null decls = return ()
 125         --  You could have a module with just (re-)exports/instances in it
 126   | otherwise
 127   = hPutStr hdl "_declarations_\n"      >>
 128     ifaceTCDecls hdl decls              >>
 129     ifaceBinds hdl final_ids binds      >>
 130     return ()
 131 \end{code}
 132
 133 \begin{code}
 134 ifaceUsages if_hdl import_usages
 135   = hPutStr if_hdl "_usages_\n"   >>
 136     hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
 137   where
 138     upp_uses (m, mv, versions)
 139       = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
 140                     upp_import_versions (sort_versions versions), uppSemi]
 141
 142         -- For imported versions we do print the version number
 143     upp_import_versions nvs
 144       = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
 145
 146
 147 ifaceInstanceModules if_hdl [] = return ()
 148 ifaceInstanceModules if_hdl imods
 149   = hPutStr if_hdl "_instance_modules_\n" >>
 150     hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
 151     hPutStr if_hdl "\n"
 152
 153 ifaceExports if_hdl [] = return ()
 154 ifaceExports if_hdl avails
 155   = hPutStr if_hdl "_exports_\n"                        >>
 156     hPutCol if_hdl upp_avail (sortLt lt_avail avails)
 157
 158 ifaceFixities if_hdl [] = return ()
 159 ifaceFixities if_hdl fixities
 160   = hPutStr if_hdl "_fixities_\n"               >>
 161     hPutCol if_hdl upp_fixity fixities
 162
 163 ifaceTCDecls if_hdl decls
 164   =  hPutCol if_hdl ppr_decl tc_decls_for_iface
 165   where
 166     tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
 167     for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
 168     for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
 169     for_iface other_decl   = False
 170
 171     for_iface_name name = isLocallyDefined name &&
 172                           not (isWiredInName name)
 173
 174     lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
 175 \end{code}
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection{Instance declarations}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183
 184 \begin{code}
 185 ifaceInstances Nothing{-no iface handle-} _ = return ()
 186
 187 ifaceInstances (Just if_hdl) inst_infos
 188   | null togo_insts = return ()
 189   | otherwise       = hPutStr if_hdl "_instances_\n" >>
 190                       hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts)
 191   where
 192     togo_insts  = filter is_togo_inst (bagToList inst_infos)
 193     is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
 194
 195     -------
 196     lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
 197             (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
 198       = getOccName dfun_id1 < getOccName dfun_id2
 199         -- The dfuns are assigned names df1, df2, etc, in order of original textual
 200         -- occurrence, and this makes as good a sort order as any
 201
 202     -------
 203     pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _)
 204       = let
 205             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 206             renumbered_ty = renumber_ty forall_ty
 207         in
 208         uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty,
 209                     uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
 210 \end{code}
 211
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection{Printing values}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 ifaceId :: (Id -> IdInfo)               -- This function "knows" the extra info added
 221                                         -- by the STG passes.  Sigh
 222
 223             -> IdSet                    -- Set of Ids that are needed by earlier interface
 224                                         -- file emissions.  If the Id isn't in this set, and isn't
 225                                         -- exported, there's no need to emit anything
 226             -> Id
 227             -> CoreExpr                 -- The Id's right hand side
 228             -> Maybe (Pretty, IdSet)    -- The emitted stuff, plus a possibly-augmented set of needed Ids
 229
 230 ifaceId get_idinfo needed_ids id rhs
 231   | not (wantIdSigInIface (id `elementOfIdSet` needed_ids)
 232                           opt_OmitInterfacePragmas
 233                           id)
 234   = Nothing             -- Well, that was easy!
 235
 236 ifaceId get_idinfo needed_ids id rhs
 237   = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids)
 238   where
 239     idinfo     = get_idinfo id
 240     ty_pretty  = pprType PprInterface (initNmbr (nmbrType (idType id)))
 241     sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty]
 242
 243     prag_pretty | opt_OmitInterfacePragmas = ppNil
 244                 | otherwise                = ppCat [arity_pretty, strict_pretty, unfold_pretty]
 245
 246     ------------  Arity  --------------
 247     arity_pretty  = ppArityInfo PprInterface (arityInfo idinfo)
 248
 249     ------------  Strictness  --------------
 250     strict_info   = strictnessInfo idinfo
 251     maybe_worker  = getWorkerId_maybe strict_info
 252     strict_pretty = ppStrictnessInfo PprInterface strict_info
 253
 254     ------------  Unfolding  --------------
 255     unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs]
 256                   | otherwise   = ppNil
 257
 258     show_unfold = not (maybeToBool maybe_worker) &&             -- Unfolding is implicit
 259                   not (bottomIsGuaranteed strict_info) &&       -- Ditto
 260                   case guidance of                              -- Small enough to show
 261                         UnfoldNever -> False
 262                         other       -> True
 263
 264     guidance    = calcUnfoldingGuidance (idWantsToBeINLINEd id)
 265                                         opt_InterfaceUnfoldThreshold
 266                                         rhs
 267
 268
 269     ------------  Extra free Ids  --------------
 270     new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)     `unionIdSets`
 271                      extra_ids
 272
 273     extra_ids | opt_OmitInterfacePragmas = emptyIdSet
 274               | otherwise                = worker_ids   `unionIdSets`
 275                                            unfold_ids
 276
 277     worker_ids = case maybe_worker of
 278                         Just wkr -> unitIdSet wkr
 279                         Nothing  -> emptyIdSet
 280
 281     unfold_ids | show_unfold = free_vars
 282                | otherwise   = emptyIdSet
 283                              where
 284                                (_,free_vars) = addExprFVs interesting emptyIdSet rhs
 285                                interesting bound id = not (id `elementOfIdSet` bound) &&
 286                                                       not (isDataCon id) &&
 287                                                       not (isWiredInName (getName id)) &&
 288                                                       isLocallyDefined id
 289 \end{code}
 290
 291 \begin{code}
 292 ifaceBinds :: Handle
 293            -> [Id]              -- Ids used at code-gen time; they have better pragma info!
 294            -> [CoreBinding]     -- In dependency order, later depend on earlier
 295            -> IO ()
 296
 297 ifaceBinds hdl final_ids binds
 298   = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties)))    >>
 299     hPutStr hdl "\n"
 300   where
 301     final_id_map  = listToUFM [(id,id) | id <- final_ids]
 302     get_idinfo id = case lookupUFM final_id_map id of
 303                         Just id' -> getIdInfo id'
 304                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
 305                                     getIdInfo id
 306
 307     pretties = go emptyIdSet (reverse binds)    -- Reverse so that later things will
 308                                                 -- provoke earlier ones to be emitted
 309     go needed [] = if not (isEmptyIdSet needed) then
 310                         pprTrace "ifaceBinds: free vars:"
 311                                   (ppSep (map (ppr PprDebug) (idSetToList needed))) $
 312                         []
 313                    else
 314                         []
 315
 316     go needed (NonRec id rhs : binds)
 317         = case ifaceId get_idinfo needed id rhs of
 318                 Nothing                -> go needed binds
 319                 Just (pretty, needed') -> pretty : go needed' binds
 320
 321         -- Recursive groups are a bit more of a pain.  We may only need one to
 322         -- start with, but it may call out the next one, and so on.  So we
 323         -- have to look for a fixed point.
 324     go needed (Rec pairs : binds)
 325         = pretties ++ go needed'' binds
 326         where
 327           (needed', pretties) = go_rec needed pairs
 328           needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
 329                 -- Later ones may spuriously cause earlier ones to be "needed" again
 330
 331     go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty])
 332     go_rec needed pairs
 333         | null pretties = (needed, [])
 334         | otherwise     = (final_needed, more_pretties ++ pretties)
 335         where
 336           reduced_pairs                 = [pair | (pair,Nothing) <- pairs `zip` maybes]
 337           pretties                      = catMaybes maybes
 338           (needed', maybes)             = mapAccumL do_one needed pairs
 339           (final_needed, more_pretties) = go_rec needed' reduced_pairs
 340
 341           do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of
 342                                         Nothing                -> (needed,  Nothing)
 343                                         Just (pretty, needed') -> (needed', Just pretty)
 344 \end{code}
 345
 346
 347 %************************************************************************
 348 %*                                                                      *
 349 \subsection{Random small things}
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 \begin{code}
 354 upp_avail NotAvailable    = uppNil
 355 upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP,
 356                                         upp_occname occ, uppSP,
 357                                         upp_export ns]
 358                              where
 359                                 (mod,occ) = modAndOcc name
 360
 361 upp_export []    = uppNil
 362 upp_export names = uppBesides [uppStr "(",
 363                                uppIntersperse uppSP (map (upp_occname . getOccName) names),
 364                                uppStr ")"]
 365
 366 upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP,
 367                                                       uppInt prec, uppSP,
 368                                                       upp_occname occ, uppSemi]
 369 upp_dir InfixR = uppStr "infixr"
 370 upp_dir InfixL = uppStr "infixl"
 371 upp_dir InfixN = uppStr "infix"
 372
 373 ppr_unqual_name :: NamedThing a => a -> Unpretty                -- Just its occurrence name
 374 ppr_unqual_name name = upp_occname (getOccName name)
 375
 376 ppr_name :: NamedThing a => a -> Unpretty               -- Its full name
 377 ppr_name   n = uppPStr (nameString (getName n))
 378
 379 upp_occname :: OccName -> Unpretty
 380 upp_occname occ = uppPStr (occNameString occ)
 381
 382 upp_module :: Module -> Unpretty
 383 upp_module mod = uppPStr mod
 384
 385 uppSemid   x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
 386
 387 ppr_ty    ty = prettyToUn (pprType PprInterface ty)
 388 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
 389 ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
 390
 391 ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
 392
 393 renumber_ty ty = initNmbr (nmbrType ty)
 394 \end{code}
 395
 396
 397 %************************************************************************
 398 %*                                                                      *
 399 \subsection{Comparisons
 400 %*                                                                      *
 401 %************************************************************************
 402
 403
 404 The various sorts above simply prevent unnecessary "wobbling" when
 405 things change that don't have to.  We therefore compare lexically, not
 406 by unique
 407
 408 \begin{code}
 409 lt_avail :: AvailInfo -> AvailInfo -> Bool
 410
 411 NotAvailable `lt_avail` (Avail _ _)  = True
 412 (Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2
 413 any          `lt_avail` NotAvailable = False
 414
 415 lt_name :: Name -> Name -> Bool
 416 n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
 417
 418 lt_lexical :: NamedThing a => a -> a -> Bool
 419 lt_lexical a1 a2 = getName a1 `lt_name` getName a2
 420
 421 lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
 422 lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
 423
 424 sort_versions vs = sortLt lt_vers vs
 425
 426 lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
 427 lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
 428 \end{code}
 429
 430
 431 \begin{code}
 432 hPutCol :: Handle
 433         -> (a -> Unpretty)
 434         -> [a]
 435         -> IO ()
 436 hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>
 437                      hPutStr hdl "\n"
 438 \end{code}