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 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 )
38 import Module ( ModuleName, moduleNameUserString )
40 import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
41 import UniqSupply ( mkSplitUniqSupply )
44 import Char ( isSpace )
45 import StgInterp ( runStgI )
46 import HscStats ( ppSourceStats )
50 %************************************************************************
52 \subsection{The main compiler pipeline}
54 %************************************************************************
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
66 | HscErrs PersistentCompilerState -- updated PCS
67 (Bag ErrMsg) -- errors
68 (Bag WarnMsg) -- warnings
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
79 hscMain dflags core_cmds stg_cmds summary maybe_old_iface
80 output_filename mod_details pcs1
82 source_unchanged :: Bool -- extracted from summary?
84 (pcs2, check_errs, (recomp_reqd, maybe_checked_iface))
85 <- checkOldIface dflags finder hit hst pcs1 mod source_unchanged
88 -- test check_errs and give up if a problem happened
89 what_next = if recomp_reqd then hscRecomp else hscNoRecomp
92 what_next dflags core_cmds stg_cmds summary hit hst
93 pcs2 maybe_checked_iface
95 hscNoRecomp = panic "hscNoRecomp"
97 hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
99 -- parsed :: RdrNameHsModule
100 parsed <- parseModule summary
101 -- check for parse errors
103 (pcs_rn, maybe_rn_result)
104 <- renameModule dflags finder hit hst pcs mod parsed
106 -- check maybe_rn_result for failure
108 (new_iface, rn_hs_decls) = unJust maybe_rn_result
111 <- typecheckModule dflags mod pcs hst hit pit rn_hs_decls
113 -- check maybe_tc_result for failure
114 let tc_result = unJust maybe_tc_result
115 let tc_pcs = tc_pcs tc_result
116 let tc_env = tc_env tc_result
117 let tc_binds = tc_binds tc_result
119 -- desugar, simplify and tidy, to create the unfoldings
120 -- why is this IO-typed?
121 (core_binds, orphan_rules)
122 <- dsThenSimplThenTidy dflags mod tc_binds rule_base
124 -- convert to Stg; needed for binders
125 let (stg_binds, top_level_ids) = myCoreToStg core_binds
126 -- myCoreToStg does occurAnalyseBinds,
127 -- `seq`, topCoreBindsToStg
129 -- cook up a new ModDetails now we (finally) have all the bits
130 let new_details = completeModDetails tc_env core_binds top_level_ids orphan_rules
132 -- and possibly create a new ModIface
133 let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
135 -- do the rest of code generation/emission
136 (unlinkeds, stub_h_filename, stub_c_filename) <- restOfCodeGeneration stg_binds
138 -- and the answer is ...
139 return (HscOK new_details maybe_final_iface stub_h_filename stub_c_filename
140 unlinkeds tc_pcs (unionBags rn_warns tc_warns))
145 -------------------------- Reader ----------------
146 show_pass "Parser" >>
149 let src_filename -- name of the preprocessed source file
150 = case ms_ppsource summary of
151 Just (filename, fingerprint) -> filename
152 Nothing -> pprPanic "hscMain:summary is not of a source module"
155 buf <- hGetStringBuffer True{-expand tabs-} src_filename
157 let glaexts | dopt Opt_GlasgowExts dflags = 1#
160 case parse buf PState{ bol = 0#, atbol = 1#,
161 context = [], glasgow_exts = glaexts,
162 loc = mkSrcLoc src_filename 1 } of {
164 PFailed err -> return (HscErrs pcs (unitBag err) emptyBag)
166 POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
168 dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
170 dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
171 (ppSourceStats False rdr_module) >>
173 -- UniqueSupplies for later use (these are the only lower case uniques)
174 mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
175 mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
176 mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
177 mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
178 mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
180 -------------------------- Rename ----------------
181 show_pass "Renamer" >>
184 renameModule dflags finder pcs hst rdr_module
185 >>= \ (pcs_rn, maybe_rn_stuff) ->
186 case maybe_rn_stuff of {
187 Nothing -> -- Hurrah! Renamer reckons that there's no need to
189 reportCompile mod_name "Compilation NOT required!" >>
192 Just (this_mod, rn_mod,
193 old_iface, new_iface,
194 rn_name_supply, fixity_env,
196 -- Oh well, we've got to recompile for real
199 -------------------------- Typechecking ----------------
200 show_pass "TypeCheck" >>
202 typecheckModule dflags mod pcs hst hit pit rn_mod
203 -- tc_uniqs rn_name_supply
205 >>= \ maybe_tc_stuff ->
206 case maybe_tc_stuff of {
207 Nothing -> ghcExit 1; -- Type checker failed
209 Just (tc_results@(TcResults {tc_tycons = local_tycons,
210 tc_classes = local_classes,
211 tc_insts = inst_info })) ->
214 -------------------------- Desugaring ----------------
216 deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
219 -------------------------- Main Core-language transformations ----------------
221 core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
223 -- Do the final tidy-up
225 simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
227 -- Run the occurrence analyser one last time, so that
228 -- dead binders get dead-binder info. This is exploited by
229 -- code generators to avoid spitting out redundant bindings.
230 -- The occurrence-zapping in Simplify.simplCaseBinder means
231 -- that the Simplifier nukes useful dead-var stuff especially
233 let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
235 coreBindsSize occ_anal_tidy_binds `seq`
236 -- TEMP: the above call zaps some space usage allocated by the
237 -- simplifier, which for reasons I don't understand, persists
238 -- thoroughout code generation
242 -------------------------- Convert to STG code -------------------------------
243 show_pass "Core2Stg" >>
246 stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
249 -------------------------- Simplify STG code -------------------------------
250 show_pass "Stg2Stg" >>
252 stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
255 runStgI local_tycons local_classes
256 (map fst stg_binds2) >>= \ i_result ->
257 putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
261 -------------------------- Interface file -------------------------------
262 -- Dump instance decls and type signatures into the interface file
265 final_ids = collectFinalStgBinders (map fst stg_binds2)
267 writeIface this_mod old_iface new_iface
268 local_tycons local_classes inst_info
269 final_ids occ_anal_tidy_binds tidy_orphan_rules >>
272 -------------------------- Code generation -------------------------------
273 show_pass "CodeGen" >>
275 codeGen this_mod imported_modules
278 local_tycons local_classes
279 stg_binds2 >>= \ abstractC ->
282 -------------------------- Code output -------------------------------
283 show_pass "CodeOutput" >>
285 codeOutput this_mod local_tycons local_classes
286 occ_anal_tidy_binds stg_binds2
287 c_code h_code abstractC
291 -------------------------- Final report -------------------------------
292 reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
300 -------------------------------------------------------------
301 -- ****** help functions:
304 = if opt_D_show_passes
305 then \ what -> hPutStr stderr ("*** "++what++":\n")
306 else \ what -> return ()
312 %************************************************************************
314 \subsection{Initial persistent state}
316 %************************************************************************
319 initPersistentCompilerState :: IO PersistentCompilerState
320 initPersistentCompilerState
322 = do prs <- initPersistentRenamerState
324 PCS { pcs_PST = initPackageDetails,
325 pcs_insts = emptyInstEnv,
326 pcs_rules = emptyRuleEnv,
327 pcs_PRS = initPersistentRenamerState
331 = PCS { pcs_PST = initPackageDetails,
332 pcs_insts = emptyInstEnv,
333 pcs_rules = initRules,
334 pcs_PRS = initPersistentRenamerState }
337 initPackageDetails :: PackageSymbolTable
338 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
340 initPersistentRenamerState :: IO PersistentRenamerState
341 = do ns <- mkSplitUniqSupply 'r'
343 PRS { prsOrig = Orig { origNames = initOrigNames,
344 origIParam = emptyFM },
345 prsDecls = emptyNameEnv,
352 initOrigNames :: FiniteMap (ModuleName,OccName) Name
353 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
355 grab names = foldl add emptyFM names
356 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
360 initRules = foldl add emptyVarEnv builtinRules
362 add env (name,rule) = extendNameEnv_C add1 env name [rule]
363 add1 rules _ = rule : rules
369 writeIface this_mod old_iface new_iface
370 local_tycons local_classes inst_info
371 final_ids tidy_binds tidy_orphan_rules
373 if isNothing opt_HiDir && isNothing opt_HiFile
374 then return () -- not producing any .hi file
378 hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
379 filename = case opt_HiFile of {
383 Just dir -> dir ++ '/':moduleUserString this_mod
385 Nothing -> panic "writeIface"
389 do maybe_final_iface <- checkIface old_iface full_new_iface
390 case maybe_final_iface of {
391 Nothing -> when opt_D_dump_rn_trace $
392 putStrLn "Interface file unchanged" ; -- No need to update .hi file
396 do let mod_vers_unchanged = case old_iface of
397 Just iface -> pi_vers iface == pi_vers final_iface
399 when (mod_vers_unchanged && opt_D_dump_rn_trace) $
400 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
402 if_hdl <- openFile filename WriteMode
403 printForIface if_hdl (pprIface final_iface)
407 full_new_iface = completeIface new_iface local_tycons local_classes
408 inst_info final_ids tidy_binds
413 %************************************************************************
415 \subsection{Printing the interface}
417 %************************************************************************
420 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
421 pi_usages = usages, pi_exports = exports,
422 pi_fixity = (fix_vers, fixities),
423 pi_insts = insts, pi_decls = decls,
424 pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
425 = vcat [ ptext SLIT("__interface")
426 <+> doubleQuotes (ptext opt_InPackage)
427 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
428 <+> (if orphan then char '!' else empty)
429 <+> int opt_HiVersion
430 <+> ptext SLIT("where")
431 , vcat (map pprExport exports)
432 , vcat (map pprUsage usages)
433 , pprFixities fixities
434 , vcat [ppr i <+> semi | i <- insts]
435 , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
440 ppr_vers v | v == initialVersion = empty
443 | fix_vers == initialVersion && rule_vers == initialVersion = empty
444 | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
447 When printing export lists, we print like this:
449 AvailTC C [C, x, y] C(x,y)
450 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
453 pprExport :: ExportItem -> SDoc
454 pprExport (mod, items)
455 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
457 upp_avail :: RdrAvailInfo -> SDoc
458 upp_avail (Avail name) = pprOccName name
459 upp_avail (AvailTC name []) = empty
460 upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
462 bang | name `elem` ns = empty
463 | otherwise = char '|'
464 ns' = filter (/= name) ns
466 upp_export [] = empty
467 upp_export names = braces (hsep (map pprOccName names))
472 pprUsage :: ImportVersion OccName -> SDoc
473 pprUsage (m, has_orphans, is_boot, whats_imported)
474 = hsep [ptext SLIT("import"), pprModuleName m,
476 upp_import_versions whats_imported
479 pp_orphan | has_orphans = char '!'
481 pp_boot | is_boot = char '@'
484 -- Importing the whole module is indicated by an empty list
485 upp_import_versions NothingAtAll = empty
486 upp_import_versions (Everything v) = dcolon <+> int v
487 upp_import_versions (Specifically vm vf vr nvs)
488 = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
493 pprFixities [] = empty
494 pprFixities fixes = hsep (map ppr fixes) <> semi
497 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
499 pprDeprecs [] = empty
500 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
502 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
503 | Deprecation ie txt _ <- deps ]