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,
  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, omitIfaceSigForId,
  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, addToFM_C, 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
  85 ifaceDecls :: Maybe Handle
  86            -> RenamedHsModule
  87            -> Bag InstInfo
  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 inst_info final_ids simplified = return ()
 121 ifaceDecls (Just hdl)
 122            (HsModule _ _ _ _ _ decls _)
 123            inst_infos
 124            final_ids binds
 125   | null decls = return ()
 126         --  You could have a module with just (re-)exports/instances in it
 127   | otherwise
 128   = ifaceInstances hdl inst_infos               >>= \ needed_ids ->
 129     hPutStr hdl "_declarations_\n"              >>
 130     ifaceTCDecls hdl decls                      >>
 131     ifaceBinds hdl needed_ids final_ids binds   >>
 132     return ()
 133 \end{code}
 134
 135 \begin{code}
 136 ifaceUsages if_hdl import_usages
 137   = hPutStr if_hdl "_usages_\n"   >>
 138     hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
 139   where
 140     upp_uses (m, mv, versions)
 141       = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
 142                     upp_import_versions (sort_versions versions), uppSemi]
 143
 144         -- For imported versions we do print the version number
 145     upp_import_versions nvs
 146       = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
 147
 148
 149 ifaceInstanceModules if_hdl [] = return ()
 150 ifaceInstanceModules if_hdl imods
 151   = hPutStr if_hdl "_instance_modules_\n" >>
 152     hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
 153     hPutStr if_hdl "\n"
 154
 155 ifaceExports if_hdl [] = return ()
 156 ifaceExports if_hdl avails
 157   = hPutStr if_hdl "_exports_\n"                        >>
 158     hPutCol if_hdl do_one_module (fmToList export_fm)
 159   where
 160         -- Sort them into groups by module
 161     export_fm :: FiniteMap Module [AvailInfo]
 162     export_fm = foldr insert emptyFM avails
 163     insert avail@(Avail name _) efm = addToFM_C (++) efm mod [avail]
 164                               where
 165                                     (mod,_) = modAndOcc name
 166     insert NotAvailable efm = efm
 167
 168         -- Print one module's worth of stuff
 169     do_one_module (mod_name, avails)
 170         = uppBesides [upp_module mod_name, uppSP,
 171                       uppCat (map upp_avail (sortLt lt_avail avails)),
 172                       uppSemi]
 173
 174 ifaceFixities if_hdl [] = return ()
 175 ifaceFixities if_hdl fixities
 176   = hPutStr if_hdl "_fixities_\n"               >>
 177     hPutCol if_hdl upp_fixity fixities
 178
 179 ifaceTCDecls if_hdl decls
 180   =  hPutCol if_hdl ppr_decl tc_decls_for_iface
 181   where
 182     tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
 183     for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
 184     for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
 185     for_iface other_decl   = False
 186
 187     for_iface_name name = isLocallyDefined name &&
 188                           not (isWiredInName name)
 189
 190     lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsection{Instance declarations}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199
 200 \begin{code}
 201 ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet            -- The IdSet is the needed dfuns
 202 ifaceInstances if_hdl inst_infos
 203   | null togo_insts = return emptyIdSet
 204   | otherwise       = hPutStr if_hdl "_instances_\n" >>
 205                       hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
 206                       return needed_ids
 207   where
 208     togo_insts  = filter is_togo_inst (bagToList inst_infos)
 209     needed_ids  = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
 210     is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
 211
 212     -------
 213     lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
 214             (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
 215       = getOccName dfun_id1 < getOccName dfun_id2
 216         -- The dfuns are assigned names df1, df2, etc, in order of original textual
 217         -- occurrence, and this makes as good a sort order as any
 218
 219     -------
 220     pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _)
 221       = let
 222             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 223             renumbered_ty = renumber_ty forall_ty
 224         in
 225         uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty,
 226                     uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection{Printing values}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 ifaceId :: (Id -> IdInfo)               -- This function "knows" the extra info added
 238                                         -- by the STG passes.  Sigh
 239
 240             -> IdSet                    -- Set of Ids that are needed by earlier interface
 241                                         -- file emissions.  If the Id isn't in this set, and isn't
 242                                         -- exported, there's no need to emit anything
 243             -> Bool                     -- True <=> recursive, so don't print unfolding
 244             -> Id
 245             -> CoreExpr                 -- The Id's right hand side
 246             -> Maybe (Pretty, IdSet)    -- The emitted stuff, plus a possibly-augmented set of needed Ids
 247
 248 ifaceId get_idinfo needed_ids is_rec id rhs
 249   | not (id `elementOfIdSet` needed_ids ||              -- Needed [no id in needed_ids has omitIfaceSigForId]
 250          (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
 251   = Nothing             -- Well, that was easy!
 252
 253 ifaceId get_idinfo needed_ids is_rec id rhs
 254   = Just (ppCat [sig_pretty, prag_pretty, ppStr ";;"], new_needed_ids)
 255   where
 256     idinfo        = get_idinfo id
 257     inline_pragma = idWantsToBeINLINEd id
 258
 259     ty_pretty  = pprType PprInterface (initNmbr (nmbrType (idType id)))
 260     sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty]
 261
 262     prag_pretty | opt_OmitInterfacePragmas = ppNil
 263                 | otherwise                = ppCat [arity_pretty, strict_pretty, unfold_pretty]
 264
 265     ------------  Arity  --------------
 266     arity_pretty  = ppArityInfo PprInterface (arityInfo idinfo)
 267
 268     ------------  Strictness  --------------
 269     strict_info   = strictnessInfo idinfo
 270     maybe_worker  = getWorkerId_maybe strict_info
 271     strict_pretty = ppStrictnessInfo PprInterface strict_info
 272
 273     ------------  Unfolding  --------------
 274     unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs]
 275                   | otherwise   = ppNil
 276
 277     show_unfold = not implicit_unfolding &&                     -- Unnecessary
 278                   (inline_pragma || not dodgy_unfolding)        -- Dangerous
 279
 280     implicit_unfolding = maybeToBool maybe_worker ||
 281                          bottomIsGuaranteed strict_info
 282
 283     dodgy_unfolding = is_rec ||                                 -- No recursive unfoldings please!
 284                       case guidance of                          -- Too big to show
 285                         UnfoldNever -> True
 286                         other       -> False
 287
 288     guidance    = calcUnfoldingGuidance inline_pragma
 289                                         opt_InterfaceUnfoldThreshold
 290                                         rhs
 291
 292
 293     ------------  Extra free Ids  --------------
 294     new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)     `unionIdSets`
 295                      extra_ids
 296
 297     extra_ids | opt_OmitInterfacePragmas = emptyIdSet
 298               | otherwise                = worker_ids   `unionIdSets`
 299                                            unfold_ids
 300
 301     worker_ids = case maybe_worker of
 302                         Just wkr -> unitIdSet wkr
 303                         Nothing  -> emptyIdSet
 304
 305     unfold_ids | show_unfold = free_vars
 306                | otherwise   = emptyIdSet
 307                              where
 308                                (_,free_vars) = addExprFVs interesting emptyIdSet rhs
 309                                interesting bound id = isLocallyDefined id &&
 310                                                       not (id `elementOfIdSet` bound) &&
 311                                                       not (omitIfaceSigForId id)
 312 \end{code}
 313
 314 \begin{code}
 315 ifaceBinds :: Handle
 316            -> IdSet             -- These Ids are needed already
 317            -> [Id]              -- Ids used at code-gen time; they have better pragma info!
 318            -> [CoreBinding]     -- In dependency order, later depend on earlier
 319            -> IO ()
 320
 321 ifaceBinds hdl needed_ids final_ids binds
 322   = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties)))    >>
 323     hPutStr hdl "\n"
 324   where
 325     final_id_map  = listToUFM [(id,id) | id <- final_ids]
 326     get_idinfo id = case lookupUFM final_id_map id of
 327                         Just id' -> getIdInfo id'
 328                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
 329                                     getIdInfo id
 330
 331     pretties = go needed_ids (reverse binds)    -- Reverse so that later things will
 332                                                 -- provoke earlier ones to be emitted
 333     go needed [] = if not (isEmptyIdSet needed) then
 334                         pprTrace "ifaceBinds: free vars:"
 335                                   (ppSep (map (ppr PprDebug) (idSetToList needed))) $
 336                         []
 337                    else
 338                         []
 339
 340     go needed (NonRec id rhs : binds)
 341         = case ifaceId get_idinfo needed False id rhs of
 342                 Nothing                -> go needed binds
 343                 Just (pretty, needed') -> pretty : go needed' binds
 344
 345         -- Recursive groups are a bit more of a pain.  We may only need one to
 346         -- start with, but it may call out the next one, and so on.  So we
 347         -- have to look for a fixed point.
 348     go needed (Rec pairs : binds)
 349         = pretties ++ go needed'' binds
 350         where
 351           (needed', pretties) = go_rec needed pairs
 352           needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
 353                 -- Later ones may spuriously cause earlier ones to be "needed" again
 354
 355     go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty])
 356     go_rec needed pairs
 357         | null pretties = (needed, [])
 358         | otherwise     = (final_needed, more_pretties ++ pretties)
 359         where
 360           reduced_pairs                 = [pair | (pair,Nothing) <- pairs `zip` maybes]
 361           pretties                      = catMaybes maybes
 362           (needed', maybes)             = mapAccumL do_one needed pairs
 363           (final_needed, more_pretties) = go_rec needed' reduced_pairs
 364
 365           do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
 366                                         Nothing                -> (needed,  Nothing)
 367                                         Just (pretty, needed') -> (needed', Just pretty)
 368 \end{code}
 369
 370
 371 %************************************************************************
 372 %*                                                                      *
 373 \subsection{Random small things}
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 \begin{code}
 378 upp_avail NotAvailable    = uppNil
 379 upp_avail (Avail name ns) = uppBesides [upp_occname (getOccName name), upp_export ns]
 380
 381 upp_export []    = uppNil
 382 upp_export names = uppBesides [uppStr "(",
 383                                uppIntersperse uppSP (map (upp_occname . getOccName) names),
 384                                uppStr ")"]
 385
 386 upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP,
 387                                                         uppInt prec, uppSP,
 388                                                         upp_occname occ, uppSemi]
 389 upp_dir InfixR = uppStr "infixr"
 390 upp_dir InfixL = uppStr "infixl"
 391 upp_dir InfixN = uppStr "infix"
 392
 393 ppr_unqual_name :: NamedThing a => a -> Unpretty                -- Just its occurrence name
 394 ppr_unqual_name name = upp_occname (getOccName name)
 395
 396 ppr_name :: NamedThing a => a -> Unpretty               -- Its full name
 397 ppr_name   n = uppPStr (nameString (getName n))
 398
 399 upp_occname :: OccName -> Unpretty
 400 upp_occname occ = uppPStr (occNameString occ)
 401
 402 upp_module :: Module -> Unpretty
 403 upp_module mod = uppPStr mod
 404
 405 uppSemid   x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
 406
 407 ppr_ty    ty = prettyToUn (pprType PprInterface ty)
 408 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
 409 ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
 410
 411 ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
 412
 413 renumber_ty ty = initNmbr (nmbrType ty)
 414 \end{code}
 415
 416
 417 %************************************************************************
 418 %*                                                                      *
 419 \subsection{Comparisons
 420 %*                                                                      *
 421 %************************************************************************
 422
 423
 424 The various sorts above simply prevent unnecessary "wobbling" when
 425 things change that don't have to.  We therefore compare lexically, not
 426 by unique
 427
 428 \begin{code}
 429 lt_avail :: AvailInfo -> AvailInfo -> Bool
 430
 431 NotAvailable `lt_avail` (Avail _ _)  = True
 432 (Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2
 433 any          `lt_avail` NotAvailable = False
 434
 435 lt_name :: Name -> Name -> Bool
 436 n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
 437
 438 lt_lexical :: NamedThing a => a -> a -> Bool
 439 lt_lexical a1 a2 = getName a1 `lt_name` getName a2
 440
 441 lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
 442 lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
 443
 444 sort_versions vs = sortLt lt_vers vs
 445
 446 lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
 447 lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
 448 \end{code}
 449
 450
 451 \begin{code}
 452 hPutCol :: Handle
 453         -> (a -> Unpretty)
 454         -> [a]
 455         -> IO ()
 456 hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>
 457                      hPutStr hdl "\n"
 458 \end{code}