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"
12 import IO ( hPutStr, hClose, stderr, openFile, IOMode(..) )
15 import RdrHsSyn ( RdrNameHsModule )
16 import FastString ( unpackFS )
17 import StringBuffer ( hGetStringBuffer )
18 import Parser ( parse )
19 import Lex ( PState(..), ParseResult(..) )
20 import SrcLoc ( mkSrcLoc )
22 import Rename ( renameModule, checkOldIface )
24 import PrelInfo ( wiredInThings )
25 import PrelRules ( builtinRules )
26 import MkIface ( completeIface, mkModDetailsFromIface )
27 import TcModule ( TcResults(..), typecheckModule )
28 import Desugar ( deSugar )
29 import SimplCore ( core2core )
30 import OccurAnal ( occurAnalyseBinds )
31 import CoreUtils ( coreBindsSize )
32 import CoreTidy ( tidyCorePgm )
33 import CoreToStg ( topCoreBindsToStg )
34 import StgSyn ( collectFinalStgBinders )
35 import SimplStg ( stg2stg )
36 import CodeGen ( codeGen )
37 import CodeOutput ( codeOutput )
39 import Module ( ModuleName, moduleNameUserString,
40 moduleUserString, moduleName )
42 import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
43 import UniqSupply ( mkSplitUniqSupply )
45 import Bag ( emptyBag )
47 import Char ( isSpace )
48 import StgInterp ( stgToInterpSyn )
49 import HscStats ( ppSourceStats )
50 import HscTypes ( ModDetails, ModIface, PersistentCompilerState(..),
51 PersistentRenamerState(..), WhatsImported(..),
52 HomeSymbolTable, PackageSymbolTable, ImportVersion,
53 GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..),
55 import RnMonad ( ExportItem, ParsedIface(..) )
56 import CmSummarise ( ModSummary )
57 import InterpSyn ( UnlinkedIBind )
58 import StgInterp ( ItblEnv )
59 import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
60 import OccName ( OccName, pprOccName )
61 import Name ( Name, nameModule )
65 %************************************************************************
67 \subsection{The main compiler pipeline}
69 %************************************************************************
73 = HscOK ModDetails -- new details (HomeSymbolTable additions)
74 (Maybe ModIface) -- new iface (if any compilation was done)
75 (Maybe String) -- generated stub_h filename (in /tmp)
76 (Maybe String) -- generated stub_c filename (in /tmp)
77 (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any
78 PersistentCompilerState -- updated PCS
80 | HscFail PersistentCompilerState -- updated PCS
81 -- no errors or warnings; the individual passes
82 -- (parse/rename/typecheck) print messages themselves
86 -> ModSummary -- summary, including source filename
87 -> Maybe ModIface -- old interface, if available
88 -> String -- file in which to put the output (.s, .hc, .java etc.)
89 -> HomeSymbolTable -- for home module ModDetails
90 -> PersistentCompilerState -- IN: persistent compiler state
93 hscMain dflags core_cmds stg_cmds summary maybe_old_iface
94 output_filename mod_details pcs
96 -- ????? source_unchanged :: Bool -- extracted from summary?
98 (ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface))
99 <- checkOldIface dflags finder hit hst pcs mod source_unchanged
102 return (HscFail ch_pcs)
105 let no_old_iface = not (isJust maybe_checked_iface)
106 what_next | recomp_reqd || no_old_iface = hscRecomp
107 | otherwise = hscNoRecomp
109 return (what_next dflags core_cmds stg_cmds summary hit hst
110 pcs2 maybe_checked_iface)
114 hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
116 -- we definitely expect to have the old interface available
117 let old_iface = case maybe_old_iface of
118 Just old_if -> old_if
119 Nothing -> panic "hscNoRecomp:old_iface"
122 (pcs_cl, closure_errs, cl_hs_decls)
123 <- closeIfaceDecls dflags finder hit hst pcs old_iface ;
125 return (HscFail cl_pcs)
130 <- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls;
131 case maybe_tc_result of {
132 Nothing -> return (HscFail cl_pcs);
133 Just tc_result -> do {
135 let pcs_tc = tc_pcs tc_result
136 env_tc = tc_env tc_result
137 binds_tc = tc_binds tc_result
138 local_tycons = tc_tycons tc_result
139 local_classes = tc_classes tc_result
140 local_insts = tc_insts tc_result
141 local_rules = tc_rules tc_result
143 -- create a new details from the closed, typechecked, old iface
144 let new_details = mkModDetailsFromIface env_tc local_insts local_rules
146 return (HscOK final_details
147 Nothing -- tells CM to use old iface and linkables
148 Nothing Nothing -- foreign export stuff
154 hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
156 -- what target are we shooting for?
157 let toInterp = dopt_HscLang dflags == HscInterpreted
160 maybe_parsed <- myParseModule dflags summary;
161 case maybe_parsed of {
162 Nothing -> return (HscFail pcs);
163 Just rdr_module -> do {
166 (pcs_rn, maybe_rn_result)
167 <- renameModule dflags finder hit hst pcs mod rdr_module;
168 case maybe_rn_result of {
169 Nothing -> return (HscFail pcs_rn);
170 Just (new_iface, rn_hs_decls) -> do {
174 <- typecheckModule dflags mod pcs_rn hst hit pit rn_hs_decls;
175 case maybe_tc_result of {
176 Nothing -> return (HscFail pcs_rn);
177 Just tc_result -> do {
179 let pcs_tc = tc_pcs tc_result
180 env_tc = tc_env tc_result
181 binds_tc = tc_binds tc_result
182 local_tycons = tc_tycons tc_result
183 local_classes = tc_classes tc_result
184 local_insts = tc_insts tc_result
186 -- DESUGAR, SIMPLIFY, TIDY-CORE
187 -- We grab the the unfoldings at this point.
188 (tidy_binds, orphan_rules, foreign_stuff)
189 <- dsThenSimplThenTidy dflags mod tc_result ds_uniqs
192 (stg_binds, cost_centre_info, top_level_ids)
193 <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
195 -- cook up a new ModDetails now we (finally) have all the bits
196 let new_details = mkModDetails tc_env local_insts tidy_binds
197 top_level_ids orphan_rules
199 -- and possibly create a new ModIface
200 let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
202 -- do the rest of code generation/emission
203 (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename)
204 <- restOfCodeGeneration toInterp
205 this_mod imported_modules cost_centre_info
206 fe_binders tc_env stg_binds
208 -- and the answer is ...
209 return (HscOK new_details maybe_final_iface
210 maybe_stub_h_filename maybe_stub_c_filename
215 myParseModule dflags summary
216 = do -------------------------- Reader ----------------
220 let src_filename -- name of the preprocessed source file
221 = case ms_ppsource summary of
222 Just (filename, fingerprint) -> filename
224 "myParseModule:summary is not of a source module"
227 buf <- hGetStringBuffer True{-expand tabs-} src_filename
229 let glaexts | dopt Opt_GlasgowExts dflags = 1#
232 case parse buf PState{ bol = 0#, atbol = 1#,
233 context = [], glasgow_exts = glaexts,
234 loc = mkSrcLoc src_filename 1 } of {
236 PFailed err -> do { hPutStrLn stderr (showSDoc err);
238 POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
240 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module)
241 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
242 (ppSourceStats False rdr_module)
244 return (Just rdr_module)
248 restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
249 foreign_stuff tc_env stg_binds
251 = return (Nothing, Nothing,
252 Just (stgToInterpSyn stg_binds local_tycons local_classes))
254 = do -------------------------- Code generation -------------------------------
257 abstractC <- codeGen this_mod imported_modules
258 cost_centre_info fe_binders
259 local_tycons local_classes stg_binds
261 -------------------------- Code output -------------------------------
262 show_pass "CodeOutput"
263 -- _scc_ "CodeOutput"
264 let (fe_binders, h_code, c_code) = foreign_stuff
265 (maybe_stub_h_name, maybe_stub_c_name)
266 <- codeOutput this_mod local_tycons local_classes
267 occ_anal_tidy_binds stg_binds2
268 c_code h_code abstractC ncg_uniqs
270 return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
272 local_tycons = tcEnvTyCons tc_env
273 local_classes = tcEnvClasses tc_env
276 dsThenSimplThenTidy dflags mod tc_result
277 -- make up ds_uniqs here
278 = do -------------------------- Desugaring ----------------
280 (desugared, rules, h_code, c_code, fe_binders)
281 <- deSugar this_mod ds_uniqs tc_result
283 -------------------------- Main Core-language transformations ----------------
285 (simplified, orphan_rules) <- core2core core_cmds desugared rules
287 -- Do the final tidy-up
288 (tidy_binds, tidy_orphan_rules)
289 <- tidyCorePgm this_mod simplified orphan_rules
291 return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
294 myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
295 = do let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
297 () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
298 -- TEMP: the above call zaps some space usage allocated by the
299 -- simplifier, which for reasons I don't understand, persists
300 -- thoroughout code generation
304 let stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
308 (stg_binds2, cost_centre_info) <- stg2stg stg_cmds this_mod st_uniqs stg_binds
309 let final_ids = collectFinalStgBinders (map fst stg_binds2)
311 return (stg_binds2, cost_centre_info, final_ids)
315 -- UniqueSupplies for later use (these are the only lower case uniques)
316 mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
317 mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
318 mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
319 mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
320 mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
322 -------------------------- Interface file -------------------------------
323 -- Dump instance decls and type signatures into the interface file
326 final_ids = collectFinalStgBinders (map fst stg_binds2)
328 writeIface this_mod old_iface new_iface
329 local_tycons local_classes inst_info
330 final_ids occ_anal_tidy_binds tidy_orphan_rules >>
333 -------------------------- Code generation -------------------------------
334 show_pass "CodeGen" >>
336 codeGen this_mod imported_modules
339 local_tycons local_classes
340 stg_binds2 >>= \ abstractC ->
343 -------------------------- Code output -------------------------------
344 show_pass "CodeOutput" >>
346 codeOutput this_mod local_tycons local_classes
347 occ_anal_tidy_binds stg_binds2
348 c_code h_code abstractC
352 -------------------------- Final report -------------------------------
353 reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
358 -------------------------------------------------------------
359 -- ****** help functions:
362 = if opt_D_show_passes
363 then \ what -> hPutStr stderr ("*** "++what++":\n")
364 else \ what -> return ()
370 %************************************************************************
372 \subsection{Initial persistent state}
374 %************************************************************************
377 initPersistentCompilerState :: IO PersistentCompilerState
378 initPersistentCompilerState
379 = do prs <- initPersistentRenamerState
381 PCS { pcs_PST = initPackageDetails,
382 pcs_insts = emptyInstEnv,
383 pcs_rules = emptyRuleEnv,
388 initPackageDetails :: PackageSymbolTable
389 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
391 initPersistentRenamerState :: IO PersistentRenamerState
392 = do ns <- mkSplitUniqSupply 'r'
394 PRS { prsOrig = Orig { origNames = initOrigNames,
395 origIParam = emptyFM },
396 prsDecls = emptyNameEnv,
403 initOrigNames :: FiniteMap (ModuleName,OccName) Name
404 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
406 grab names = foldl add emptyFM names
407 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
410 initRules :: PackageRuleBase
411 initRules = foldl add emptyVarEnv builtinRules
413 add env (name,rule) = extendNameEnv_C add1 env name [rule]
414 add1 rules _ = rule : rules
420 writeIface this_mod old_iface new_iface
421 local_tycons local_classes inst_info
422 final_ids tidy_binds tidy_orphan_rules
424 if isNothing opt_HiDir && isNothing opt_HiFile
425 then return () -- not producing any .hi file
429 hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
430 filename = case opt_HiFile of {
434 Just dir -> dir ++ '/':moduleUserString this_mod
436 Nothing -> panic "writeIface"
440 do maybe_final_iface <- checkIface old_iface full_new_iface
441 case maybe_final_iface of {
442 Nothing -> when opt_D_dump_rn_trace $
443 putStrLn "Interface file unchanged" ; -- No need to update .hi file
447 do let mod_vers_unchanged = case old_iface of
448 Just iface -> pi_vers iface == pi_vers final_iface
450 when (mod_vers_unchanged && opt_D_dump_rn_trace) $
451 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
453 if_hdl <- openFile filename WriteMode
454 printForIface if_hdl (pprIface final_iface)
458 full_new_iface = completeIface new_iface local_tycons local_classes
459 inst_info final_ids tidy_binds
461 isNothing = not . isJust
465 %************************************************************************
467 \subsection{Printing the interface}
469 %************************************************************************
472 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
473 pi_usages = usages, pi_exports = exports,
474 pi_fixity = (fix_vers, fixities),
475 pi_insts = insts, pi_decls = decls,
476 pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
477 = vcat [ ptext SLIT("__interface")
478 <+> doubleQuotes (ptext opt_InPackage)
479 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
480 <+> (if orphan then char '!' else empty)
481 <+> int opt_HiVersion
482 <+> ptext SLIT("where")
483 , vcat (map pprExport exports)
484 , vcat (map pprUsage usages)
485 , pprFixities fixities
486 , vcat [ppr i <+> semi | i <- insts]
487 , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
492 ppr_vers v | v == initialVersion = empty
495 | fix_vers == initialVersion && rule_vers == initialVersion = empty
496 | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
499 When printing export lists, we print like this:
501 AvailTC C [C, x, y] C(x,y)
502 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
505 pprExport :: ExportItem -> SDoc
506 pprExport (mod, items)
507 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
509 upp_avail :: RdrAvailInfo -> SDoc
510 upp_avail (Avail name) = pprOccName name
511 upp_avail (AvailTC name []) = empty
512 upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
514 bang | name `elem` ns = empty
515 | otherwise = char '|'
516 ns' = filter (/= name) ns
518 upp_export [] = empty
519 upp_export names = braces (hsep (map pprOccName names))
524 pprUsage :: ImportVersion OccName -> SDoc
525 pprUsage (m, has_orphans, is_boot, whats_imported)
526 = hsep [ptext SLIT("import"), ppr (moduleName m),
528 upp_import_versions whats_imported
531 pp_orphan | has_orphans = char '!'
533 pp_boot | is_boot = char '@'
536 -- Importing the whole module is indicated by an empty list
537 upp_import_versions NothingAtAll = empty
538 upp_import_versions (Everything v) = dcolon <+> int v
539 upp_import_versions (Specifically vm vf vr nvs)
540 = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
545 pprFixities [] = empty
546 pprFixities fixes = hsep (map ppr fixes) <> semi
549 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
551 pprDeprecs [] = empty
552 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
554 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
555 | Deprecation ie txt _ <- deps ]