2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
7 module HscMain ( hscMain ) where
9 #include "HsVersions.h"
11 import IO ( hPutStr, stderr )
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 )
21 import Rename ( renameModule )
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 )
37 import Module ( ModuleName, moduleNameUserString )
39 import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
40 import UniqSupply ( mkSplitUniqSupply )
43 import Char ( isSpace )
44 import StgInterp ( runStgI )
45 import HscStats ( ppSourceStats )
49 %************************************************************************
51 \subsection{The main compiler pipeline}
53 %************************************************************************
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
65 | HscErrs PersistentCompilerState -- updated PCS
66 (Bag ErrMsg) -- errors
67 (Bag WarnMsg) -- warnings
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
78 hscMain flags core_cmds stg_cmds summary maybe_old_iface
79 output_filename mod_details pcs1 =
81 -------------------------- Reader ----------------
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"
91 buf <- hGetStringBuffer True{-expand tabs-} src_filename
93 let glaexts | opt_GlasgowExts = 1#
96 case parse buf PState{ bol = 0#, atbol = 1#,
97 context = [], glasgow_exts = glaexts,
98 loc = mkSrcLoc src_filename 1 } of {
100 PFailed err -> return (CompErrs pcs err)
102 POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
104 dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
106 dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
107 (ppSourceStats False rdr_module) >>
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
117 -------------------------- Rename ----------------
118 show_pass "Renamer" >>
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
125 reportCompile mod_name "Compilation NOT required!" >>
128 Just (this_mod, rn_mod,
129 old_iface, new_iface,
130 rn_name_supply, fixity_env,
132 -- Oh well, we've got to recompile for real
135 -------------------------- Typechecking ----------------
136 show_pass "TypeCheck" >>
138 typecheckModule dflags mod pcs hst hit pit rn_mod
139 -- tc_uniqs rn_name_supply
141 >>= \ maybe_tc_stuff ->
142 case maybe_tc_stuff of {
143 Nothing -> ghcExit 1; -- Type checker failed
145 Just (tc_results@(TcResults {tc_tycons = local_tycons,
146 tc_classes = local_classes,
147 tc_insts = inst_info })) ->
150 -------------------------- Desugaring ----------------
152 deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
155 -------------------------- Main Core-language transformations ----------------
157 core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
159 -- Do the final tidy-up
160 tidyCorePgm tidy_uniqs this_mod
161 simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
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
169 let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
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
178 -------------------------- Convert to STG code -------------------------------
179 show_pass "Core2Stg" >>
182 stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
185 -------------------------- Simplify STG code -------------------------------
186 show_pass "Stg2Stg" >>
188 stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
191 runStgI local_tycons local_classes
192 (map fst stg_binds2) >>= \ i_result ->
193 putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
197 -------------------------- Interface file -------------------------------
198 -- Dump instance decls and type signatures into the interface file
201 final_ids = collectFinalStgBinders (map fst stg_binds2)
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 >>
208 -------------------------- Code generation -------------------------------
209 show_pass "CodeGen" >>
211 codeGen this_mod imported_modules
214 local_tycons local_classes
215 stg_binds2 >>= \ abstractC ->
218 -------------------------- Code output -------------------------------
219 show_pass "CodeOutput" >>
221 codeOutput this_mod local_tycons local_classes
222 occ_anal_tidy_binds stg_binds2
223 c_code h_code abstractC
227 -------------------------- Final report -------------------------------
228 reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
236 -------------------------------------------------------------
237 -- ****** help functions:
240 = if opt_D_show_passes
241 then \ what -> hPutStr stderr ("*** "++what++":\n")
242 else \ what -> return ()
246 %************************************************************************
248 \subsection{Initial persistent state}
250 %************************************************************************
253 initPersistentCompilerState :: PersistentCompilerState
254 initPersistentCompilerState
255 = PCS { pcs_PST = initPackageDetails,
256 pcs_insts = emptyInstEnv,
257 pcs_rules = emptyRuleEnv,
258 pcs_PRS = initPersistentRenamerState }
260 initPackageDetails :: PackageSymbolTable
261 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
263 initPersistentRenamerState :: PersistentRenamerState
264 = PRS { prsOrig = Orig { origNames = initOrigNames,
265 origIParam = emptyFM },
266 prsDecls = emptyNameEnv,
271 initOrigNames :: FiniteMap (ModuleName,OccName) Name
272 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
274 grab names = foldl add emptyFM names
275 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name