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 CoreUtils ( coreBindsSize )
52 import TidyPgm ( tidyCorePgm )
53 import CorePrep ( corePrepPgm )
55 import CoreToStg ( coreToStg )
56 import SimplStg ( stg2stg )
57 import CodeGen ( codeGen )
58 import CodeOutput ( codeOutput )
60 import Module ( emptyModuleEnv )
62 import DriverPhases ( isExtCore_file )
63 import ErrUtils ( dumpIfSet_dyn, showPass )
64 import UniqSupply ( mkSplitUniqSupply )
66 import Bag ( consBag, emptyBag )
68 import HscStats ( ppSourceStats )
70 import MkExternalCore ( emitExternalCore )
72 import ParserCoreUtils
73 import FiniteMap ( emptyFM )
74 import Name ( nameModule )
75 import NameEnv ( emptyNameEnv )
76 import NameSet ( emptyNameSet )
77 import Module ( Module, ModLocation(..), showModMsg )
79 import Maybes ( expectJust )
82 import Maybe ( isJust, fromJust )
87 %************************************************************************
89 \subsection{The main compiler pipeline}
91 %************************************************************************
96 = HscFail PersistentCompilerState -- updated PCS
97 -- concluded that it wasn't necessary
98 | HscNoRecomp PersistentCompilerState -- updated PCS
99 ModDetails -- new details (HomeSymbolTable additions)
100 ModIface -- new iface (if any compilation was done)
102 | HscRecomp PersistentCompilerState -- updated PCS
103 ModDetails -- new details (HomeSymbolTable additions)
104 ModIface -- new iface (if any compilation was done)
105 Bool -- stub_h exists
106 Bool -- stub_c exists
107 (Maybe CompiledByteCode)
109 -- no errors or warnings; the individual passes
110 -- (parse/rename/typecheck) print messages themselves
114 -> PersistentCompilerState -- IN: persistent compiler state
116 -> ModLocation -- location info
117 -> Bool -- True <=> source unchanged
118 -> Bool -- True <=> have an object file (for msgs only)
119 -> Maybe ModIface -- old interface, if available
122 hscMain hsc_env pcs mod location
123 source_unchanged have_object maybe_old_iface
125 (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
126 checkOldIface hsc_env pcs mod
127 (ml_hi_file location)
128 source_unchanged maybe_old_iface;
129 case maybe_chk_result of {
130 Nothing -> return (HscFail pcs_ch) ;
131 Just (recomp_reqd, maybe_checked_iface) -> do {
133 let no_old_iface = not (isJust maybe_checked_iface)
134 what_next | recomp_reqd || no_old_iface = hscRecomp
135 | otherwise = hscNoRecomp
137 ; what_next hsc_env pcs_ch have_object
138 mod location maybe_checked_iface
142 -- hscNoRecomp definitely expects to have the old interface available
143 hscNoRecomp hsc_env pcs_ch have_object
144 mod location (Just old_iface)
145 | hsc_mode hsc_env == OneShot
147 when (verbosity (hsc_dflags hsc_env) > 0) $
148 hPutStrLn stderr "compilation IS NOT required";
149 let { bomb = panic "hscNoRecomp:OneShot" };
150 return (HscNoRecomp pcs_ch bomb bomb)
154 when (verbosity (hsc_dflags hsc_env) >= 1) $
155 hPutStrLn stderr ("Skipping " ++
156 showModMsg have_object mod location);
159 (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
161 case maybe_tc_result of {
162 Nothing -> return (HscFail pcs_tc);
165 return (HscNoRecomp pcs_tc new_details old_iface)
168 hscRecomp hsc_env pcs_ch have_object
169 mod location maybe_checked_iface
171 -- what target are we shooting for?
172 ; let one_shot = hsc_mode hsc_env == OneShot
173 ; let dflags = hsc_dflags hsc_env
174 ; let toInterp = dopt_HscLang dflags == HscInterpreted
175 ; let toCore = isJust (ml_hs_file location) &&
176 isExtCore_file (fromJust (ml_hs_file location))
178 ; when (not one_shot && verbosity dflags >= 1) $
179 hPutStrLn stderr ("Compiling " ++
180 showModMsg (not toInterp) mod location);
182 ; front_res <- if toCore then
183 hscCoreFrontEnd hsc_env pcs_ch location
185 hscFrontEnd hsc_env pcs_ch location
188 Left flure -> return flure;
189 Right (pcs_tc, ds_result) -> do {
193 -- ; seqList imported_modules (return ())
198 ; flat_result <- _scc_ "Flattening"
199 flatten hsc_env pcs_tc ds_result
202 ; let -- Rule-base accumulated from imported packages
203 pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
205 -- In one-shot mode, ZAP the external package state at
206 -- this point, because we aren't going to need it from
207 -- now on. We keep the name cache, however, because
208 -- tidyCore needs it.
210 | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
213 ; pkg_rule_base `seq` pcs_middle `seq` return ()
215 -- alive at this point:
223 ; simpl_result <- _scc_ "Core2Core"
224 core2core hsc_env pkg_rule_base flat_result
229 ; (pcs_simpl, tidy_result)
231 tidyCorePgm dflags pcs_middle simpl_result
233 -- ZAP the persistent compiler state altogether now if we're
234 -- in one-shot mode, to save space.
235 ; pcs_final <- if one_shot then return (error "pcs_final missing")
236 else return pcs_simpl
238 ; emitExternalCore dflags tidy_result
240 -- Alive at this point:
241 -- tidy_result, pcs_final
245 -- BUILD THE NEW ModIface and ModDetails
246 -- and emit external core if necessary
247 -- This has to happen *after* code gen so that the back-end
248 -- info has been set. Not yet clear if it matters waiting
249 -- until after code output
250 ; new_iface <- _scc_ "MkFinalIface"
251 mkIface hsc_env location
252 maybe_checked_iface tidy_result
255 -- Space leak reduction: throw away the new interface if
256 -- we're in one-shot mode; we won't be needing it any
259 if one_shot then return (error "no final iface")
260 else return new_iface
262 -- Build the final ModDetails (except in one-shot mode, where
263 -- we won't need this information after compilation).
265 if one_shot then return (error "no final details")
266 else return $! ModDetails {
267 md_types = mg_types tidy_result,
268 md_insts = mg_insts tidy_result,
269 md_rules = mg_rules tidy_result }
272 -- CONVERT TO STG and COMPLETE CODE GENERATION
273 ; (stub_h_exists, stub_c_exists, maybe_bcos)
274 <- hscBackEnd dflags tidy_result
276 -- and the answer is ...
277 ; return (HscRecomp pcs_final
280 stub_h_exists stub_c_exists
284 hscCoreFrontEnd hsc_env pcs_ch location = do {
288 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
289 ; case parseCore inp 1 of
290 FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
291 OkP rdr_module -> do {
294 -- RENAME and TYPECHECK
296 ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
297 tcRnExtCore hsc_env pcs_ch rdr_module
298 ; case maybe_tc_result of {
299 Nothing -> return (Left (HscFail pcs_tc));
300 Just mod_guts -> return (Right (pcs_tc, mod_guts))
301 -- No desugaring to do!
305 hscFrontEnd hsc_env pcs_ch location = do {
309 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
310 (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
312 ; case maybe_parsed of {
313 Nothing -> return (Left (HscFail pcs_ch));
314 Just rdr_module -> do {
317 -- RENAME and TYPECHECK
319 ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
320 tcRnModule hsc_env pcs_ch rdr_module
321 ; case maybe_tc_result of {
322 Nothing -> return (Left (HscFail pcs_ch));
323 Just tc_result -> do {
328 ; ds_result <- _scc_ "DeSugar"
329 deSugar hsc_env pcs_tc tc_result
330 ; return (Right (pcs_tc, ds_result))
335 ModGuts{ -- This is the last use of the ModGuts in a compilation.
336 -- From now on, we just use the bits we need.
337 mg_module = this_mod,
338 mg_binds = core_binds,
340 mg_dir_imps = dir_imps,
341 mg_foreign = foreign_stubs,
342 mg_deps = dependencies } = do {
345 -- PREPARE FOR CODE GENERATION
346 -- Do saturation and convert to A-normal form
347 prepd_binds <- _scc_ "CorePrep"
348 corePrepPgm dflags core_binds type_env;
350 case dopt_HscLang dflags of
351 HscNothing -> return (False, False, Nothing)
355 do ----------------- Generate byte code ------------------
356 comp_bc <- byteCodeGen dflags prepd_binds type_env
358 ------------------ Create f-x-dynamic C-side stuff ---
359 (istub_h_exists, istub_c_exists)
360 <- outputForeignStubs dflags foreign_stubs
362 return ( istub_h_exists, istub_c_exists, Just comp_bc )
364 panic "GHC not compiled with interpreter"
369 ----------------- Convert to STG ------------------
370 (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
371 myCoreToStg dflags this_mod prepd_binds
373 ------------------ Code generation ------------------
374 abstractC <- _scc_ "CodeGen"
375 codeGen dflags this_mod type_env foreign_stubs
376 dir_imps cost_centre_info stg_binds
378 ------------------ Code output -----------------------
379 (stub_h_exists, stub_c_exists)
380 <- codeOutput dflags this_mod foreign_stubs
381 dependencies abstractC
383 return (stub_h_exists, stub_c_exists, Nothing)
387 myParseModule dflags src_filename
388 = do -------------------------- Parser ----------------
389 showPass dflags "Parser"
391 buf <- hGetStringBuffer src_filename
393 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
394 ffiEF = dopt Opt_FFI dflags,
395 withEF = dopt Opt_With dflags,
396 parrEF = dopt Opt_PArr dflags}
397 loc = mkSrcLoc (mkFastString src_filename) 1
399 case parseModule buf (mkPState loc exts) of {
401 PFailed err -> do { hPutStrLn stderr (showSDoc err);
402 freeStringBuffer buf;
405 POk _ rdr_module -> do {
407 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
409 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
410 (ppSourceStats False rdr_module) ;
412 return (Just rdr_module)
413 -- ToDo: free the string buffer later.
417 myCoreToStg dflags this_mod prepd_binds
419 stg_binds <- _scc_ "Core2Stg"
420 coreToStg dflags prepd_binds
422 (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
423 stg2stg dflags this_mod stg_binds
425 return (stg_binds2, cost_centre_info)
429 %************************************************************************
431 \subsection{Compiling a do-statement}
433 %************************************************************************
435 When the UnlinkedBCOExpr is linked you get an HValue of type
437 When you run it you get a list of HValues that should be
438 the same length as the list of names; add them to the ClosureEnv.
440 A naked expression returns a singleton Name [it].
442 What you type The IO [HValue] that hscStmt returns
443 ------------- ------------------------------------
444 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
447 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
450 expr (of IO type) ==> expr >>= \ v -> return [v]
451 [NB: result not printed] bindings: [it]
454 expr (of non-IO type,
455 result showable) ==> let v = expr in print v >> return [v]
458 expr (of non-IO type,
459 result not showable) ==> error
463 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
465 -> PersistentCompilerState -- IN: persistent compiler state
466 -> InteractiveContext -- Context for compiling
467 -> String -- The statement
468 -> IO ( PersistentCompilerState,
469 Maybe (InteractiveContext, [Name], HValue) )
471 hscStmt hsc_env pcs icontext stmt
472 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
473 ; case maybe_stmt of {
474 Nothing -> return (pcs, Nothing) ;
475 Just parsed_stmt -> do {
477 -- Rename and typecheck it
478 (pcs1, maybe_tc_result)
479 <- tcRnStmt hsc_env pcs icontext parsed_stmt
481 ; case maybe_tc_result of {
482 Nothing -> return (pcs1, Nothing) ;
483 Just (new_ic, bound_names, tc_expr) -> do {
485 -- Then desugar, code gen, and link it
486 ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
487 (ic_rn_gbl_env new_ic)
491 ; return (pcs1, Just (new_ic, bound_names, hval))
494 hscTcExpr -- Typecheck an expression (but don't run it)
496 -> PersistentCompilerState -- IN: persistent compiler state
497 -> InteractiveContext -- Context for compiling
498 -> String -- The expression
499 -> IO (PersistentCompilerState, Maybe Type)
501 hscTcExpr hsc_env pcs icontext expr
502 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
503 ; case maybe_stmt of {
504 Just (ExprStmt expr _ _)
505 -> tcRnExpr hsc_env pcs icontext expr ;
506 Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
507 return (pcs, Nothing) } ;
508 Nothing -> return (pcs, Nothing) } }
512 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
513 hscParseStmt dflags str
514 = do showPass dflags "Parser"
517 buf <- stringToStringBuffer str
519 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
520 ffiEF = dopt Opt_FFI dflags,
521 withEF = dopt Opt_With dflags,
522 parrEF = dopt Opt_PArr dflags}
523 loc = mkSrcLoc FSLIT("<interactive>") 1
525 case parseStmt buf (mkPState loc exts) of {
527 PFailed err -> do { hPutStrLn stderr (showSDoc err);
528 -- Not yet implemented in <4.11 freeStringBuffer buf;
531 -- no stmt: the line consisted of just space or comments
532 POk _ Nothing -> return Nothing;
534 POk _ (Just rdr_stmt) -> do {
536 --ToDo: can't free the string buffer until we've finished this
537 -- compilation sweep and all the identifiers have gone away.
538 --freeStringBuffer buf;
539 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
540 return (Just rdr_stmt)
545 %************************************************************************
547 \subsection{Getting information about an identifer}
549 %************************************************************************
553 hscThing -- like hscStmt, but deals with a single identifier
555 -> PersistentCompilerState -- IN: persistent compiler state
556 -> InteractiveContext -- Context for compiling
557 -> String -- The identifier
558 -> IO ( PersistentCompilerState,
561 hscThing hsc_env pcs0 ic str
562 = do let dflags = hsc_dflags hsc_env
564 maybe_rdr_name <- myParseIdentifier dflags str
565 case maybe_rdr_name of {
566 Nothing -> return (pcs0, []);
569 (pcs1, maybe_tc_result) <-
570 tcRnThing hsc_env pcs0 ic rdr_name
572 case maybe_tc_result of {
573 Nothing -> return (pcs1, []) ;
574 Just things -> return (pcs1, things)
577 myParseIdentifier dflags str
578 = do buf <- stringToStringBuffer str
580 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
581 ffiEF = dopt Opt_FFI dflags,
582 withEF = dopt Opt_With dflags,
583 parrEF = dopt Opt_PArr dflags}
584 loc = mkSrcLoc FSLIT("<interactive>") 1
586 case parseIdentifier buf (mkPState loc exts) of
588 PFailed err -> do { hPutStrLn stderr (showSDoc err);
589 freeStringBuffer buf;
592 POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
593 return (Just rdr_name) }
597 %************************************************************************
599 Desugar, simplify, convert to bytecode, and link an expression
601 %************************************************************************
605 compileExpr :: HscEnv
606 -> PersistentCompilerState
607 -> Module -> GlobalRdrEnv -> TypeEnv
611 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
612 = do { let { dflags = hsc_dflags hsc_env ;
613 lint_on = dopt Opt_DoCoreLinting dflags }
616 ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
619 ; flat_expr <- flattenExpr hsc_env pcs ds_expr
622 ; simpl_expr <- simplifyExpr dflags flat_expr
624 -- Tidy it (temporary, until coreSat does cloning)
625 ; tidy_expr <- tidyCoreExpr simpl_expr
627 -- Prepare for codegen
628 ; prepd_expr <- corePrepExpr dflags tidy_expr
631 -- ToDo: improve SrcLoc
633 case lintUnfolding noSrcLoc [] prepd_expr of
634 Just err -> pprPanic "compileExpr" err
640 ; bcos <- coreExprToBCOs dflags prepd_expr
643 ; hval <- linkExpr hsc_env pcs bcos
651 %************************************************************************
653 \subsection{Initial persistent state}
655 %************************************************************************
658 initPersistentCompilerState :: IO PersistentCompilerState
659 initPersistentCompilerState
660 = do nc <- initNameCache
662 PCS { pcs_EPS = initExternalPackageState,
665 initNameCache :: IO NameCache
666 = do us <- mkSplitUniqSupply 'r'
667 return (NameCache { nsUniqs = us,
668 nsNames = initOrigNames,
671 initExternalPackageState :: ExternalPackageState
672 initExternalPackageState
673 = emptyExternalPackageState {
674 eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
675 eps_PTE = wiredInThingEnv,
678 add_rule (name,rule) (rules, n_slurped)
679 = (gated_decl `consBag` rules, n_slurped)
681 gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
682 mod = nameModule name
683 rdr_name = nameRdrName name -- Seems a bit of a hack to go back
685 gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
687 initOrigNames :: OrigNameCache
688 initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames