2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
5 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
9 HscResult(..), hscMain, initPersistentCompilerState
11 , hscStmt, hscTcExpr, hscThing,
16 #include "HsVersions.h"
19 import TcHsSyn ( TypecheckedHsExpr )
20 import CodeOutput ( outputForeignStubs )
21 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
22 import Linker ( HValue, linkExpr )
23 import TidyPgm ( tidyCoreExpr )
24 import CorePrep ( corePrepExpr )
25 import Flattening ( flattenExpr )
26 import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing )
27 import RdrHsSyn ( RdrNameStmt )
29 import PrelNames ( iNTERACTIVE )
30 import StringBuffer ( stringToStringBuffer )
31 import SrcLoc ( noSrcLoc )
33 import CoreLint ( lintUnfolding )
38 import RdrName ( nameRdrName )
39 import StringBuffer ( hGetStringBuffer, freeStringBuffer )
41 import Lex ( ParseResult(..), ExtFlags(..), mkPState )
42 import SrcLoc ( mkSrcLoc )
43 import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
44 import RnEnv ( extendOrigNameCache )
45 import PrelInfo ( wiredInThingEnv, knownKeyNames )
46 import PrelRules ( builtinRules )
47 import MkIface ( mkIface )
49 import Flattening ( flatten )
51 import TidyPgm ( tidyCorePgm )
52 import CorePrep ( corePrepPgm )
53 import CoreToStg ( coreToStg )
54 import SimplStg ( stg2stg )
55 import CodeGen ( codeGen )
56 import CodeOutput ( codeOutput )
58 import Module ( emptyModuleEnv )
60 import DriverPhases ( isExtCore_file )
61 import ErrUtils ( dumpIfSet_dyn, showPass )
62 import UniqSupply ( mkSplitUniqSupply )
64 import Bag ( consBag, emptyBag )
66 import HscStats ( ppSourceStats )
68 import MkExternalCore ( emitExternalCore )
70 import ParserCoreUtils
71 import FiniteMap ( emptyFM )
72 import Name ( nameModule )
73 import Module ( Module, ModLocation(..), showModMsg )
75 import Maybes ( expectJust )
78 import Maybe ( isJust, fromJust )
83 %************************************************************************
85 \subsection{The main compiler pipeline}
87 %************************************************************************
92 = HscFail PersistentCompilerState -- updated PCS
93 -- concluded that it wasn't necessary
94 | HscNoRecomp PersistentCompilerState -- updated PCS
95 ModDetails -- new details (HomeSymbolTable additions)
96 ModIface -- new iface (if any compilation was done)
98 | HscRecomp PersistentCompilerState -- updated PCS
99 ModDetails -- new details (HomeSymbolTable additions)
100 ModIface -- new iface (if any compilation was done)
101 Bool -- stub_h exists
102 Bool -- stub_c exists
103 (Maybe CompiledByteCode)
105 -- no errors or warnings; the individual passes
106 -- (parse/rename/typecheck) print messages themselves
110 -> PersistentCompilerState -- IN: persistent compiler state
112 -> ModLocation -- location info
113 -> Bool -- True <=> source unchanged
114 -> Bool -- True <=> have an object file (for msgs only)
115 -> Maybe ModIface -- old interface, if available
118 hscMain hsc_env pcs mod location
119 source_unchanged have_object maybe_old_iface
121 (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
122 checkOldIface hsc_env pcs mod
123 (ml_hi_file location)
124 source_unchanged maybe_old_iface;
125 case maybe_chk_result of {
126 Nothing -> return (HscFail pcs_ch) ;
127 Just (recomp_reqd, maybe_checked_iface) -> do {
129 let no_old_iface = not (isJust maybe_checked_iface)
130 what_next | recomp_reqd || no_old_iface = hscRecomp
131 | otherwise = hscNoRecomp
133 ; what_next hsc_env pcs_ch have_object
134 mod location maybe_checked_iface
138 -- hscNoRecomp definitely expects to have the old interface available
139 hscNoRecomp hsc_env pcs_ch have_object
140 mod location (Just old_iface)
141 | hsc_mode hsc_env == OneShot
143 when (verbosity (hsc_dflags hsc_env) > 0) $
144 hPutStrLn stderr "compilation IS NOT required";
145 let { bomb = panic "hscNoRecomp:OneShot" };
146 return (HscNoRecomp pcs_ch bomb bomb)
150 when (verbosity (hsc_dflags hsc_env) >= 1) $
151 hPutStrLn stderr ("Skipping " ++
152 showModMsg have_object mod location);
155 (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
157 case maybe_tc_result of {
158 Nothing -> return (HscFail pcs_tc);
161 return (HscNoRecomp pcs_tc new_details old_iface)
164 hscRecomp hsc_env pcs_ch have_object
165 mod location maybe_checked_iface
167 -- what target are we shooting for?
168 ; let one_shot = hsc_mode hsc_env == OneShot
169 ; let dflags = hsc_dflags hsc_env
170 ; let toInterp = dopt_HscLang dflags == HscInterpreted
171 ; let toCore = isJust (ml_hs_file location) &&
172 isExtCore_file (fromJust (ml_hs_file location))
174 ; when (not one_shot && verbosity dflags >= 1) $
175 hPutStrLn stderr ("Compiling " ++
176 showModMsg (not toInterp) mod location);
178 ; front_res <- if toCore then
179 hscCoreFrontEnd hsc_env pcs_ch location
181 hscFrontEnd hsc_env pcs_ch location
184 Left flure -> return flure;
185 Right (pcs_tc, ds_result) -> do {
189 -- ; seqList imported_modules (return ())
194 ; flat_result <- _scc_ "Flattening"
195 flatten hsc_env pcs_tc ds_result
198 ; let -- Rule-base accumulated from imported packages
199 pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
201 -- In one-shot mode, ZAP the external package state at
202 -- this point, because we aren't going to need it from
203 -- now on. We keep the name cache, however, because
204 -- tidyCore needs it.
206 | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
209 ; pkg_rule_base `seq` pcs_middle `seq` return ()
211 -- alive at this point:
219 ; simpl_result <- _scc_ "Core2Core"
220 core2core hsc_env pkg_rule_base flat_result
225 ; (pcs_simpl, tidy_result)
227 tidyCorePgm dflags pcs_middle simpl_result
229 -- ZAP the persistent compiler state altogether now if we're
230 -- in one-shot mode, to save space.
231 ; pcs_final <- if one_shot then return (error "pcs_final missing")
232 else return pcs_simpl
234 ; emitExternalCore dflags tidy_result
236 -- Alive at this point:
237 -- tidy_result, pcs_final
241 -- BUILD THE NEW ModIface and ModDetails
242 -- and emit external core if necessary
243 -- This has to happen *after* code gen so that the back-end
244 -- info has been set. Not yet clear if it matters waiting
245 -- until after code output
246 ; new_iface <- _scc_ "MkFinalIface"
247 mkIface hsc_env location
248 maybe_checked_iface tidy_result
251 -- Space leak reduction: throw away the new interface if
252 -- we're in one-shot mode; we won't be needing it any
255 if one_shot then return (error "no final iface")
256 else return new_iface
258 -- Build the final ModDetails (except in one-shot mode, where
259 -- we won't need this information after compilation).
261 if one_shot then return (error "no final details")
262 else return $! ModDetails {
263 md_types = mg_types tidy_result,
264 md_insts = mg_insts tidy_result,
265 md_rules = mg_rules tidy_result }
268 -- CONVERT TO STG and COMPLETE CODE GENERATION
269 ; (stub_h_exists, stub_c_exists, maybe_bcos)
270 <- hscBackEnd dflags tidy_result
272 -- and the answer is ...
273 ; return (HscRecomp pcs_final
276 stub_h_exists stub_c_exists
280 hscCoreFrontEnd hsc_env pcs_ch location = do {
284 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
285 ; case parseCore inp 1 of
286 FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
287 OkP rdr_module -> do {
290 -- RENAME and TYPECHECK
292 ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
293 tcRnExtCore hsc_env pcs_ch rdr_module
294 ; case maybe_tc_result of {
295 Nothing -> return (Left (HscFail pcs_tc));
296 Just mod_guts -> return (Right (pcs_tc, mod_guts))
297 -- No desugaring to do!
301 hscFrontEnd hsc_env pcs_ch location = do {
305 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
306 (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
308 ; case maybe_parsed of {
309 Nothing -> return (Left (HscFail pcs_ch));
310 Just rdr_module -> do {
313 -- RENAME and TYPECHECK
315 ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
316 tcRnModule hsc_env pcs_ch rdr_module
317 ; case maybe_tc_result of {
318 Nothing -> return (Left (HscFail pcs_ch));
319 Just tc_result -> do {
324 ; ds_result <- _scc_ "DeSugar"
325 deSugar hsc_env pcs_tc tc_result
326 ; return (Right (pcs_tc, ds_result))
331 ModGuts{ -- This is the last use of the ModGuts in a compilation.
332 -- From now on, we just use the bits we need.
333 mg_module = this_mod,
334 mg_binds = core_binds,
336 mg_dir_imps = dir_imps,
337 mg_foreign = foreign_stubs,
338 mg_deps = dependencies } = do {
341 -- PREPARE FOR CODE GENERATION
342 -- Do saturation and convert to A-normal form
343 prepd_binds <- _scc_ "CorePrep"
344 corePrepPgm dflags core_binds type_env;
346 case dopt_HscLang dflags of
347 HscNothing -> return (False, False, Nothing)
351 do ----------------- Generate byte code ------------------
352 comp_bc <- byteCodeGen dflags prepd_binds type_env
354 ------------------ Create f-x-dynamic C-side stuff ---
355 (istub_h_exists, istub_c_exists)
356 <- outputForeignStubs dflags foreign_stubs
358 return ( istub_h_exists, istub_c_exists, Just comp_bc )
360 panic "GHC not compiled with interpreter"
365 ----------------- Convert to STG ------------------
366 (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
367 myCoreToStg dflags this_mod prepd_binds
369 ------------------ Code generation ------------------
370 abstractC <- _scc_ "CodeGen"
371 codeGen dflags this_mod type_env foreign_stubs
372 dir_imps cost_centre_info stg_binds
374 ------------------ Code output -----------------------
375 (stub_h_exists, stub_c_exists)
376 <- codeOutput dflags this_mod foreign_stubs
377 dependencies abstractC
379 return (stub_h_exists, stub_c_exists, Nothing)
383 myParseModule dflags src_filename
384 = do -------------------------- Parser ----------------
385 showPass dflags "Parser"
387 buf <- hGetStringBuffer src_filename
389 let exts = mkExtFlags dflags
390 loc = mkSrcLoc (mkFastString src_filename) 1
392 case parseModule buf (mkPState loc exts) of {
394 PFailed err -> do { hPutStrLn stderr (showSDoc err);
395 freeStringBuffer buf;
398 POk _ rdr_module -> do {
400 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
402 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
403 (ppSourceStats False rdr_module) ;
405 return (Just rdr_module)
406 -- ToDo: free the string buffer later.
410 myCoreToStg dflags this_mod prepd_binds
412 stg_binds <- _scc_ "Core2Stg"
413 coreToStg dflags prepd_binds
415 (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
416 stg2stg dflags this_mod stg_binds
418 return (stg_binds2, cost_centre_info)
422 %************************************************************************
424 \subsection{Compiling a do-statement}
426 %************************************************************************
428 When the UnlinkedBCOExpr is linked you get an HValue of type
430 When you run it you get a list of HValues that should be
431 the same length as the list of names; add them to the ClosureEnv.
433 A naked expression returns a singleton Name [it].
435 What you type The IO [HValue] that hscStmt returns
436 ------------- ------------------------------------
437 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
440 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
443 expr (of IO type) ==> expr >>= \ v -> return [v]
444 [NB: result not printed] bindings: [it]
447 expr (of non-IO type,
448 result showable) ==> let v = expr in print v >> return [v]
451 expr (of non-IO type,
452 result not showable) ==> error
456 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
458 -> PersistentCompilerState -- IN: persistent compiler state
459 -> InteractiveContext -- Context for compiling
460 -> String -- The statement
461 -> IO ( PersistentCompilerState,
462 Maybe (InteractiveContext, [Name], HValue) )
464 hscStmt hsc_env pcs icontext stmt
465 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
466 ; case maybe_stmt of {
467 Nothing -> return (pcs, Nothing) ;
468 Just parsed_stmt -> do {
470 -- Rename and typecheck it
471 (pcs1, maybe_tc_result)
472 <- tcRnStmt hsc_env pcs icontext parsed_stmt
474 ; case maybe_tc_result of {
475 Nothing -> return (pcs1, Nothing) ;
476 Just (new_ic, bound_names, tc_expr) -> do {
478 -- Then desugar, code gen, and link it
479 ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
480 (ic_rn_gbl_env new_ic)
484 ; return (pcs1, Just (new_ic, bound_names, hval))
487 hscTcExpr -- Typecheck an expression (but don't run it)
489 -> PersistentCompilerState -- IN: persistent compiler state
490 -> InteractiveContext -- Context for compiling
491 -> String -- The expression
492 -> IO (PersistentCompilerState, Maybe Type)
494 hscTcExpr hsc_env pcs icontext expr
495 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
496 ; case maybe_stmt of {
497 Just (ExprStmt expr _ _)
498 -> tcRnExpr hsc_env pcs icontext expr ;
499 Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
500 return (pcs, Nothing) } ;
501 Nothing -> return (pcs, Nothing) } }
505 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
506 hscParseStmt dflags str
507 = do showPass dflags "Parser"
510 buf <- stringToStringBuffer str
512 let exts = mkExtFlags dflags
513 loc = mkSrcLoc FSLIT("<interactive>") 1
515 case parseStmt buf (mkPState loc exts) of {
517 PFailed err -> do { hPutStrLn stderr (showSDoc err);
518 -- Not yet implemented in <4.11 freeStringBuffer buf;
521 -- no stmt: the line consisted of just space or comments
522 POk _ Nothing -> return Nothing;
524 POk _ (Just rdr_stmt) -> do {
526 --ToDo: can't free the string buffer until we've finished this
527 -- compilation sweep and all the identifiers have gone away.
528 --freeStringBuffer buf;
529 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
530 return (Just rdr_stmt)
535 %************************************************************************
537 \subsection{Getting information about an identifer}
539 %************************************************************************
543 hscThing -- like hscStmt, but deals with a single identifier
545 -> PersistentCompilerState -- IN: persistent compiler state
546 -> InteractiveContext -- Context for compiling
547 -> String -- The identifier
548 -> IO ( PersistentCompilerState,
551 hscThing hsc_env pcs0 ic str
552 = do let dflags = hsc_dflags hsc_env
554 maybe_rdr_name <- myParseIdentifier dflags str
555 case maybe_rdr_name of {
556 Nothing -> return (pcs0, []);
559 (pcs1, maybe_tc_result) <-
560 tcRnThing hsc_env pcs0 ic rdr_name
562 case maybe_tc_result of {
563 Nothing -> return (pcs1, []) ;
564 Just things -> return (pcs1, things)
567 myParseIdentifier dflags str
568 = do buf <- stringToStringBuffer str
570 let exts = mkExtFlags dflags
571 loc = mkSrcLoc FSLIT("<interactive>") 1
573 case parseIdentifier buf (mkPState loc exts) of
575 PFailed err -> do { hPutStrLn stderr (showSDoc err);
576 freeStringBuffer buf;
579 POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
580 return (Just rdr_name) }
584 %************************************************************************
586 Desugar, simplify, convert to bytecode, and link an expression
588 %************************************************************************
592 compileExpr :: HscEnv
593 -> PersistentCompilerState
594 -> Module -> GlobalRdrEnv -> TypeEnv
598 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
599 = do { let { dflags = hsc_dflags hsc_env ;
600 lint_on = dopt Opt_DoCoreLinting dflags }
603 ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
606 ; flat_expr <- flattenExpr hsc_env pcs ds_expr
609 ; simpl_expr <- simplifyExpr dflags flat_expr
611 -- Tidy it (temporary, until coreSat does cloning)
612 ; tidy_expr <- tidyCoreExpr simpl_expr
614 -- Prepare for codegen
615 ; prepd_expr <- corePrepExpr dflags tidy_expr
618 -- ToDo: improve SrcLoc
620 case lintUnfolding noSrcLoc [] prepd_expr of
621 Just err -> pprPanic "compileExpr" err
627 ; bcos <- coreExprToBCOs dflags prepd_expr
630 ; hval <- linkExpr hsc_env pcs bcos
638 %************************************************************************
640 \subsection{Initial persistent state}
642 %************************************************************************
645 initPersistentCompilerState :: IO PersistentCompilerState
646 initPersistentCompilerState
647 = do nc <- initNameCache
649 PCS { pcs_EPS = initExternalPackageState,
652 initNameCache :: IO NameCache
653 = do us <- mkSplitUniqSupply 'r'
654 return (NameCache { nsUniqs = us,
655 nsNames = initOrigNames,
658 initExternalPackageState :: ExternalPackageState
659 initExternalPackageState
660 = emptyExternalPackageState {
661 eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
662 eps_PTE = wiredInThingEnv,
665 add_rule (name,rule) (rules, n_slurped)
666 = (gated_decl `consBag` rules, n_slurped)
668 gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
669 mod = nameModule name
670 rdr_name = nameRdrName name -- Seems a bit of a hack to go back
672 gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
674 initOrigNames :: OrigNameCache
675 initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames
678 = ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
679 ffiEF = dopt Opt_FFI dflags,
680 withEF = dopt Opt_With dflags,
681 arrowsEF = dopt Opt_Arrows dflags,
682 parrEF = dopt Opt_PArr dflags}