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 MkIface          ( writeIface )
  25 import TcModule         ( TcResults(..), typecheckModule )
  26 import Desugar          ( deSugar )
  27 import SimplCore        ( core2core )
  28 import OccurAnal        ( occurAnalyseBinds )
  29 import CoreUtils        ( coreBindsSize )
  30 import CoreTidy         ( tidyCorePgm )
  31 import CoreToStg        ( topCoreBindsToStg )
  32 import StgSyn           ( collectFinalStgBinders )
  33 import SimplStg         ( stg2stg )
  34 import CodeGen          ( codeGen )
  35 import CodeOutput       ( codeOutput )
  36
  37 import Module           ( ModuleName, moduleNameUserString )
  38 import CmdLineOpts
  39 import ErrUtils         ( ghcExit, doIfSet, dumpIfSet )
  40 import UniqSupply       ( mkSplitUniqSupply )
  41
  42 import Outputable
  43 import Char             ( isSpace )
  44 import StgInterp        ( runStgI )
  45 import HscStats         ( ppSourceStats )
  46 \end{code}
  47
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{The main compiler pipeline}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 \begin{code}
  56 data HscResult
  57    = HscOK   ModDetails              -- new details (HomeSymbolTable additions)
  58              (Maybe ModIface)        -- new iface (if any compilation was done)
  59              (Maybe String)          -- generated stub_h filename (in /tmp)
  60              (Maybe String)          -- generated stub_c filename (in /tmp)
  61              (Maybe [UnlinkedIBind]) -- interpreted code, if any
  62              PersistentCompilerState -- updated PCS
  63              (Bag WarnMsg)              -- warnings
  64
  65    | HscErrs PersistentCompilerState -- updated PCS
  66              (Bag ErrMsg)               -- errors
  67              (Bag WarnMsg)             -- warnings
  68
  69 hscMain
  70   :: DynFlags
  71   -> ModSummary       -- summary, including source filename
  72   -> Maybe ModIFace   -- old interface, if available
  73   -> String           -- file in which to put the output (.s, .hc, .java etc.)
  74   -> HomeSymbolTable            -- for home module ModDetails
  75   -> PersistentCompilerState    -- IN: persistent compiler state
  76   -> IO HscResult
  77
  78 hscMain flags core_cmds stg_cmds summary maybe_old_iface
  79         output_filename mod_details pcs1 =
  80
  81         --------------------------  Reader  ----------------
  82     show_pass "Parser"  >>
  83     _scc_     "Parser"
  84
  85     let src_filename -- name of the preprocessed source file
  86        = case ms_ppsource summary of
  87             Just (filename, fingerprint) -> filename
  88             Nothing -> pprPanic "hscMain:summary is not of a source module"
  89                                 (ppr summary)
  90
  91     buf <- hGetStringBuffer True{-expand tabs-} src_filename
  92
  93     let glaexts | opt_GlasgowExts = 1#
  94                 | otherwise       = 0#
  95
  96     case parse buf PState{ bol = 0#, atbol = 1#,
  97                            context = [], glasgow_exts = glaexts,
  98                            loc = mkSrcLoc src_filename 1 } of {
  99
 100         PFailed err -> return (CompErrs pcs err)
 101
 102         POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
 103
 104     dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
 105
 106     dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
 107         (ppSourceStats False rdr_module)                >>
 108
 109     -- UniqueSupplies for later use (these are the only lower case uniques)
 110     mkSplitUniqSupply 'd'       >>= \ ds_uniqs  -> -- desugarer
 111     mkSplitUniqSupply 'r'       >>= \ ru_uniqs  -> -- rules
 112     mkSplitUniqSupply 'c'       >>= \ c2s_uniqs -> -- core-to-stg
 113     mkSplitUniqSupply 'u'       >>= \ tidy_uniqs -> -- tidy up
 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 tc_uniqs rn_name_supply
 139                     fixity_env rn_mod           >>= \ maybe_tc_stuff ->
 140     case maybe_tc_stuff of {
 141         Nothing -> ghcExit 1;   -- Type checker failed
 142
 143         Just (tc_results@(TcResults {tc_tycons  = local_tycons,
 144                                      tc_classes = local_classes,
 145                                      tc_insts   = inst_info })) ->
 146
 147
 148         --------------------------  Desugaring ----------------
 149     _scc_     "DeSugar"
 150     deSugar this_mod ds_uniqs tc_results        >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
 151
 152
 153         --------------------------  Main Core-language transformations ----------------
 154     _scc_     "Core2Core"
 155     core2core core_cmds desugared rules         >>= \ (simplified, orphan_rules) ->
 156
 157         -- Do the final tidy-up
 158     tidyCorePgm tidy_uniqs this_mod
 159                 simplified orphan_rules         >>= \ (tidy_binds, tidy_orphan_rules) ->
 160
 161         -- Run the occurrence analyser one last time, so that
 162         -- dead binders get dead-binder info.  This is exploited by
 163         -- code generators to avoid spitting out redundant bindings.
 164         -- The occurrence-zapping in Simplify.simplCaseBinder means
 165         -- that the Simplifier nukes useful dead-var stuff especially
 166         -- in case patterns.
 167     let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
 168
 169     coreBindsSize occ_anal_tidy_binds `seq`
 170 --      TEMP: the above call zaps some space usage allocated by the
 171 --      simplifier, which for reasons I don't understand, persists
 172 --      thoroughout code generation
 173
 174
 175
 176         --------------------------  Convert to STG code -------------------------------
 177     show_pass "Core2Stg"                        >>
 178     _scc_     "Core2Stg"
 179     let
 180         stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 181     in
 182
 183         --------------------------  Simplify STG code -------------------------------
 184     show_pass "Stg2Stg"                          >>
 185     _scc_     "Stg2Stg"
 186     stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
 187
 188 #ifdef GHCI
 189     runStgI local_tycons local_classes
 190                          (map fst stg_binds2)    >>= \ i_result ->
 191     putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
 192     >>
 193
 194 #else
 195         --------------------------  Interface file -------------------------------
 196         -- Dump instance decls and type signatures into the interface file
 197     _scc_     "Interface"
 198     let
 199         final_ids = collectFinalStgBinders (map fst stg_binds2)
 200     in
 201     writeIface this_mod old_iface new_iface
 202                local_tycons local_classes inst_info
 203                final_ids occ_anal_tidy_binds tidy_orphan_rules          >>
 204
 205
 206         --------------------------  Code generation -------------------------------
 207     show_pass "CodeGen"                         >>
 208     _scc_     "CodeGen"
 209     codeGen this_mod imported_modules
 210             cost_centre_info
 211             fe_binders
 212             local_tycons local_classes
 213             stg_binds2                          >>= \ abstractC ->
 214
 215
 216         --------------------------  Code output -------------------------------
 217     show_pass "CodeOutput"                              >>
 218     _scc_     "CodeOutput"
 219     codeOutput this_mod local_tycons local_classes
 220                occ_anal_tidy_binds stg_binds2
 221                c_code h_code abstractC
 222                ncg_uniqs                                >>
 223
 224
 225         --------------------------  Final report -------------------------------
 226     reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
 227
 228 #endif
 229
 230
 231     ghcExit 0
 232     } }
 233   where
 234     -------------------------------------------------------------
 235     -- ****** help functions:
 236
 237     show_pass
 238       = if opt_D_show_passes
 239         then \ what -> hPutStr stderr ("*** "++what++":\n")
 240         else \ what -> return ()
 241 \end{code}
 242
 243
 244 %************************************************************************
 245 %*                                                                      *
 246 \subsection{Initial persistent state}
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 \begin{code}
 251 initPersistentCompilerState :: PersistentCompilerState
 252 initPersistentCompilerState
 253   = PCS { pcs_PST   = initPackageDetails,
 254           pcs_insts = emptyInstEnv,
 255           pcs_rules = emptyRuleEnv,
 256           pcs_PRS   = initPersistentRenamerState }
 257
 258 initPackageDetails :: PackageSymbolTable
 259 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
 260
 261 initPersistentRenamerState :: PersistentRenamerState
 262   = PRS { prsOrig  = Orig { origNames  = initOrigNames,
 263                             origIParam = emptyFM },
 264           prsDecls = emptyNameEnv,
 265           prsInsts = emptyBag,
 266           prsRules = emptyBag
 267     }
 268
 269 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 270 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
 271               where
 272                 grab names   = foldl add emptyFM names
 273                 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
 274 \end{code}