ghc/compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
   5
   6 \begin{code}
   7 module HscMain ( hscMain ) where
   8
   9 #include "HsVersions.h"
  10
  11 import IO               ( hPutStr, stderr )
  12 import HsSyn
  13
  14 import RdrHsSyn         ( RdrNameHsModule )
  15 import FastString       ( unpackFS )
  16 import StringBuffer     ( hGetStringBuffer )
  17 import Parser           ( parse )
  18 import Lex              ( PState(..), ParseResult(..) )
  19 import SrcLoc           ( mkSrcLoc )
  20
  21 import Rename           ( renameModule )
  22
  23 import PrelInfo         ( wiredInThings )
  24 import PrelRules        ( builtinRules )
  25 import MkIface          ( writeIface )
  26 import TcModule         ( TcResults(..), typecheckModule )
  27 import Desugar          ( deSugar )
  28 import SimplCore        ( core2core )
  29 import OccurAnal        ( occurAnalyseBinds )
  30 import CoreUtils        ( coreBindsSize )
  31 import CoreTidy         ( tidyCorePgm )
  32 import CoreToStg        ( topCoreBindsToStg )
  33 import StgSyn           ( collectFinalStgBinders )
  34 import SimplStg         ( stg2stg )
  35 import CodeGen          ( codeGen )
  36 import CodeOutput       ( codeOutput )
  37
  38 import Module           ( ModuleName, moduleNameUserString )
  39 import CmdLineOpts
  40 import ErrUtils         ( ghcExit, doIfSet, dumpIfSet )
  41 import UniqSupply       ( mkSplitUniqSupply )
  42
  43 import Outputable
  44 import Char             ( isSpace )
  45 import StgInterp        ( runStgI )
  46 import HscStats         ( ppSourceStats )
  47 \end{code}
  48
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{The main compiler pipeline}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 data HscResult
  58    = HscOK   ModDetails              -- new details (HomeSymbolTable additions)
  59              (Maybe ModIface)        -- new iface (if any compilation was done)
  60              (Maybe String)          -- generated stub_h filename (in /tmp)
  61              (Maybe String)          -- generated stub_c filename (in /tmp)
  62              (Maybe [UnlinkedIBind]) -- interpreted code, if any
  63              PersistentCompilerState -- updated PCS
  64              (Bag WarnMsg)              -- warnings
  65
  66    | HscErrs PersistentCompilerState -- updated PCS
  67              (Bag ErrMsg)               -- errors
  68              (Bag WarnMsg)             -- warnings
  69
  70 hscMain
  71   :: DynFlags
  72   -> ModSummary       -- summary, including source filename
  73   -> Maybe ModIFace   -- old interface, if available
  74   -> String           -- file in which to put the output (.s, .hc, .java etc.)
  75   -> HomeSymbolTable            -- for home module ModDetails
  76   -> PersistentCompilerState    -- IN: persistent compiler state
  77   -> IO HscResult
  78
  79 hscMain flags core_cmds stg_cmds summary maybe_old_iface
  80         output_filename mod_details pcs1 =
  81
  82         --------------------------  Reader  ----------------
  83     show_pass "Parser"  >>
  84     _scc_     "Parser"
  85
  86     let src_filename -- name of the preprocessed source file
  87        = case ms_ppsource summary of
  88             Just (filename, fingerprint) -> filename
  89             Nothing -> pprPanic "hscMain:summary is not of a source module"
  90                                 (ppr summary)
  91
  92     buf <- hGetStringBuffer True{-expand tabs-} src_filename
  93
  94     let glaexts | opt_GlasgowExts = 1#
  95                 | otherwise       = 0#
  96
  97     case parse buf PState{ bol = 0#, atbol = 1#,
  98                            context = [], glasgow_exts = glaexts,
  99                            loc = mkSrcLoc src_filename 1 } of {
 100
 101         PFailed err -> return (CompErrs pcs err)
 102
 103         POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
 104
 105     dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
 106
 107     dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
 108         (ppSourceStats False rdr_module)                >>
 109
 110     -- UniqueSupplies for later use (these are the only lower case uniques)
 111     mkSplitUniqSupply 'd'       >>= \ ds_uniqs  -> -- desugarer
 112     mkSplitUniqSupply 'r'       >>= \ ru_uniqs  -> -- rules
 113     mkSplitUniqSupply 'c'       >>= \ c2s_uniqs -> -- core-to-stg
 114     mkSplitUniqSupply 'g'       >>= \ st_uniqs  -> -- stg-to-stg passes
 115     mkSplitUniqSupply 'n'       >>= \ ncg_uniqs -> -- native-code generator
 116
 117         --------------------------  Rename  ----------------
 118     show_pass "Renamer"                         >>
 119     _scc_     "Renamer"
 120
 121     renameModule rn_uniqs rdr_module            >>= \ maybe_rn_stuff ->
 122     case maybe_rn_stuff of {
 123         Nothing ->      -- Hurrah!  Renamer reckons that there's no need to
 124                         -- go any further
 125                         reportCompile mod_name "Compilation NOT required!" >>
 126                         return ();
 127
 128         Just (this_mod, rn_mod,
 129               old_iface, new_iface,
 130               rn_name_supply, fixity_env,
 131               imported_modules) ->
 132                         -- Oh well, we've got to recompile for real
 133
 134
 135         --------------------------  Typechecking ----------------
 136     show_pass "TypeCheck"                               >>
 137     _scc_     "TypeCheck"
 138     typecheckModule dflags mod pcs hst hit pit rn_mod
 139     --                tc_uniqs rn_name_supply
 140     --              fixity_env rn_mod
 141                                                 >>= \ maybe_tc_stuff ->
 142     case maybe_tc_stuff of {
 143         Nothing -> ghcExit 1;   -- Type checker failed
 144
 145         Just (tc_results@(TcResults {tc_tycons  = local_tycons,
 146                                      tc_classes = local_classes,
 147                                      tc_insts   = inst_info })) ->
 148
 149
 150         --------------------------  Desugaring ----------------
 151     _scc_     "DeSugar"
 152     deSugar this_mod ds_uniqs tc_results        >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
 153
 154
 155         --------------------------  Main Core-language transformations ----------------
 156     _scc_     "Core2Core"
 157     core2core core_cmds desugared rules         >>= \ (simplified, orphan_rules) ->
 158
 159         -- Do the final tidy-up
 160     tidyCorePgm this_mod
 161                 simplified orphan_rules         >>= \ (tidy_binds, tidy_orphan_rules) ->
 162
 163         -- Run the occurrence analyser one last time, so that
 164         -- dead binders get dead-binder info.  This is exploited by
 165         -- code generators to avoid spitting out redundant bindings.
 166         -- The occurrence-zapping in Simplify.simplCaseBinder means
 167         -- that the Simplifier nukes useful dead-var stuff especially
 168         -- in case patterns.
 169     let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
 170
 171     coreBindsSize occ_anal_tidy_binds `seq`
 172 --      TEMP: the above call zaps some space usage allocated by the
 173 --      simplifier, which for reasons I don't understand, persists
 174 --      thoroughout code generation
 175
 176
 177
 178         --------------------------  Convert to STG code -------------------------------
 179     show_pass "Core2Stg"                        >>
 180     _scc_     "Core2Stg"
 181     let
 182         stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 183     in
 184
 185         --------------------------  Simplify STG code -------------------------------
 186     show_pass "Stg2Stg"                          >>
 187     _scc_     "Stg2Stg"
 188     stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
 189
 190 #ifdef GHCI
 191     runStgI local_tycons local_classes
 192                          (map fst stg_binds2)    >>= \ i_result ->
 193     putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
 194     >>
 195
 196 #else
 197         --------------------------  Interface file -------------------------------
 198         -- Dump instance decls and type signatures into the interface file
 199     _scc_     "Interface"
 200     let
 201         final_ids = collectFinalStgBinders (map fst stg_binds2)
 202     in
 203     writeIface this_mod old_iface new_iface
 204                local_tycons local_classes inst_info
 205                final_ids occ_anal_tidy_binds tidy_orphan_rules          >>
 206
 207
 208         --------------------------  Code generation -------------------------------
 209     show_pass "CodeGen"                         >>
 210     _scc_     "CodeGen"
 211     codeGen this_mod imported_modules
 212             cost_centre_info
 213             fe_binders
 214             local_tycons local_classes
 215             stg_binds2                          >>= \ abstractC ->
 216
 217
 218         --------------------------  Code output -------------------------------
 219     show_pass "CodeOutput"                              >>
 220     _scc_     "CodeOutput"
 221     codeOutput this_mod local_tycons local_classes
 222                occ_anal_tidy_binds stg_binds2
 223                c_code h_code abstractC
 224                ncg_uniqs                                >>
 225
 226
 227         --------------------------  Final report -------------------------------
 228     reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
 229
 230 #endif
 231
 232
 233     ghcExit 0
 234     } }
 235   where
 236     -------------------------------------------------------------
 237     -- ****** help functions:
 238
 239     show_pass
 240       = if opt_D_show_passes
 241         then \ what -> hPutStr stderr ("*** "++what++":\n")
 242         else \ what -> return ()
 243 \end{code}
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection{Initial persistent state}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 \begin{code}
 253 initPersistentCompilerState :: PersistentCompilerState
 254 initPersistentCompilerState
 255   = PCS { pcs_PST   = initPackageDetails,
 256           pcs_insts = emptyInstEnv,
 257           pcs_rules = initRules,
 258           pcs_PRS   = initPersistentRenamerState }
 259
 260 initPackageDetails :: PackageSymbolTable
 261 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
 262
 263 initPersistentRenamerState :: PersistentRenamerState
 264   = PRS { prsOrig  = Orig { origNames  = initOrigNames,
 265                             origIParam = emptyFM },
 266           prsDecls = emptyNameEnv,
 267           prsInsts = emptyBag,
 268           prsRules = emptyBag
 269     }
 270
 271 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 272 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
 273               where
 274                 grab names   = foldl add emptyFM names
 275                 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
 276
 277
 278 initRules :: RuleEnv
 279 initRules = foldl add emptyVarEnv builtinRules
 280           where
 281             add env (name,rule) = extendNameEnv_C add1 env name [rule]
 282             add1 rules _        = rule : rules
 283 \end{code}
 284
 285
 286
 287 \begin{code}
 288 writeIface this_mod old_iface new_iface
 289            local_tycons local_classes inst_info
 290            final_ids tidy_binds tidy_orphan_rules
 291   =
 292     if isNothing opt_HiDir && isNothing opt_HiFile
 293         then return ()  -- not producing any .hi file
 294         else
 295
 296     let
 297         hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
 298         filename = case opt_HiFile of {
 299                         Just f  -> f;
 300                         Nothing ->
 301                    case opt_HiDir of {
 302                         Just dir -> dir ++ '/':moduleUserString this_mod
 303                                         ++ '.':hi_suf;
 304                         Nothing  -> panic "writeIface"
 305                 }}
 306     in
 307
 308     do maybe_final_iface <- checkIface old_iface full_new_iface
 309        case maybe_final_iface of {
 310           Nothing -> when opt_D_dump_rn_trace $
 311                      putStrLn "Interface file unchanged" ;  -- No need to update .hi file
 312
 313           Just final_iface ->
 314
 315        do  let mod_vers_unchanged = case old_iface of
 316                                       Just iface -> pi_vers iface == pi_vers final_iface
 317                                       Nothing -> False
 318            when (mod_vers_unchanged && opt_D_dump_rn_trace) $
 319                 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 320
 321            if_hdl <- openFile filename WriteMode
 322            printForIface if_hdl (pprIface final_iface)
 323            hClose if_hdl
 324     }
 325   where
 326     full_new_iface = completeIface new_iface local_tycons local_classes
 327                                              inst_info final_ids tidy_binds
 328                                              tidy_orphan_rules
 329 \end{code}
 330
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection{Printing the interface}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 \begin{code}
 339 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
 340                         pi_usages = usages, pi_exports = exports,
 341                         pi_fixity = (fix_vers, fixities),
 342                         pi_insts = insts, pi_decls = decls,
 343                         pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
 344  = vcat [ ptext SLIT("__interface")
 345                 <+> doubleQuotes (ptext opt_InPackage)
 346                 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
 347                 <+> (if orphan then char '!' else empty)
 348                 <+> int opt_HiVersion
 349                 <+> ptext SLIT("where")
 350         , vcat (map pprExport exports)
 351         , vcat (map pprUsage usages)
 352         , pprFixities fixities
 353         , vcat [ppr i <+> semi | i <- insts]
 354         , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
 355         , pprRules rules
 356         , pprDeprecs deprecs
 357         ]
 358   where
 359     ppr_vers v | v == initialVersion = empty
 360                | otherwise           = int v
 361     pp_sub_vers
 362         | fix_vers == initialVersion && rule_vers == initialVersion = empty
 363         | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
 364 \end{code}
 365
 366 When printing export lists, we print like this:
 367         Avail   f               f
 368         AvailTC C [C, x, y]     C(x,y)
 369         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 370
 371 \begin{code}
 372 pprExport :: ExportItem -> SDoc
 373 pprExport (mod, items)
 374  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
 375   where
 376     upp_avail :: RdrAvailInfo -> SDoc
 377     upp_avail (Avail name)      = pprOccName name
 378     upp_avail (AvailTC name []) = empty
 379     upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
 380                                 where
 381                                   bang | name `elem` ns = empty
 382                                        | otherwise      = char '|'
 383                                   ns' = filter (/= name) ns
 384
 385     upp_export []    = empty
 386     upp_export names = braces (hsep (map pprOccName names))
 387 \end{code}
 388
 389
 390 \begin{code}
 391 pprUsage :: ImportVersion OccName -> SDoc
 392 pprUsage (m, has_orphans, is_boot, whats_imported)
 393   = hsep [ptext SLIT("import"), pprModuleName m,
 394           pp_orphan, pp_boot,
 395           upp_import_versions whats_imported
 396     ] <> semi
 397   where
 398     pp_orphan | has_orphans = char '!'
 399               | otherwise   = empty
 400     pp_boot   | is_boot     = char '@'
 401               | otherwise   = empty
 402
 403         -- Importing the whole module is indicated by an empty list
 404     upp_import_versions NothingAtAll   = empty
 405     upp_import_versions (Everything v) = dcolon <+> int v
 406     upp_import_versions (Specifically vm vf vr nvs)
 407       = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
 408 \end{code}
 409
 410
 411 \begin{code}
 412 pprFixities []    = empty
 413 pprFixities fixes = hsep (map ppr fixes) <> semi
 414
 415 pprRules []    = empty
 416 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
 417
 418 pprDeprecs []   = empty
 419 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
 420                 where
 421                   guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
 422                               | Deprecation ie txt _ <- deps ]
 423 \end{code}
 424
 425