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 )
36 import RdrName ( nameRdrName )
38 import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
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 Rules ( emptyRuleBase )
46 import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
47 import PrelRules ( builtinRules )
48 import MkIface ( mkIface )
49 import InstEnv ( emptyInstEnv )
51 import Flattening ( flatten )
53 import CoreUtils ( coreBindsSize )
54 import TidyPgm ( tidyCorePgm )
55 import CorePrep ( corePrepPgm )
57 import CoreToStg ( coreToStg )
58 import SimplStg ( stg2stg )
59 import CodeGen ( codeGen )
60 import CodeOutput ( codeOutput )
62 import Module ( emptyModuleEnv )
64 import DriverPhases ( isExtCore_file )
65 import ErrUtils ( dumpIfSet_dyn, showPass, printError )
66 import UniqSupply ( mkSplitUniqSupply )
68 import Bag ( consBag, emptyBag )
70 import HscStats ( ppSourceStats )
72 import MkExternalCore ( emitExternalCore )
74 import ParserCoreUtils
75 import FiniteMap ( emptyFM )
76 import Name ( nameModule, getName )
77 import NameEnv ( emptyNameEnv, mkNameEnv )
78 import NameSet ( emptyNameSet )
79 import Module ( Module, ModLocation(..), showModMsg )
81 import Maybes ( expectJust )
83 import DATA_IOREF ( newIORef, readIORef, writeIORef )
84 import UNSAFE_IO ( unsafePerformIO )
87 import Maybe ( isJust, fromJust )
92 %************************************************************************
94 \subsection{The main compiler pipeline}
96 %************************************************************************
100 -- compilation failed
101 = HscFail PersistentCompilerState -- updated PCS
102 -- concluded that it wasn't necessary
103 | HscNoRecomp PersistentCompilerState -- updated PCS
104 ModDetails -- new details (HomeSymbolTable additions)
105 ModIface -- new iface (if any compilation was done)
107 | HscRecomp PersistentCompilerState -- updated PCS
108 ModDetails -- new details (HomeSymbolTable additions)
109 ModIface -- new iface (if any compilation was done)
110 Bool -- stub_h exists
111 Bool -- stub_c exists
112 (Maybe CompiledByteCode)
114 -- no errors or warnings; the individual passes
115 -- (parse/rename/typecheck) print messages themselves
119 -> PersistentCompilerState -- IN: persistent compiler state
121 -> ModLocation -- location info
122 -> Bool -- True <=> source unchanged
123 -> Bool -- True <=> have an object file (for msgs only)
124 -> Maybe ModIface -- old interface, if available
127 hscMain hsc_env pcs mod location
128 source_unchanged have_object maybe_old_iface
130 (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
131 checkOldIface hsc_env pcs mod
132 (ml_hi_file location)
133 source_unchanged maybe_old_iface;
134 case maybe_chk_result of {
135 Nothing -> return (HscFail pcs_ch) ;
136 Just (recomp_reqd, maybe_checked_iface) -> do {
138 let no_old_iface = not (isJust maybe_checked_iface)
139 what_next | recomp_reqd || no_old_iface = hscRecomp
140 | otherwise = hscNoRecomp
142 ; what_next hsc_env pcs_ch have_object
143 mod location maybe_checked_iface
147 -- hscNoRecomp definitely expects to have the old interface available
148 hscNoRecomp hsc_env pcs_ch have_object
149 mod location (Just old_iface)
150 | hsc_mode hsc_env == OneShot
152 when (verbosity (hsc_dflags hsc_env) > 0) $
153 hPutStrLn stderr "compilation IS NOT required";
154 let { bomb = panic "hscNoRecomp:OneShot" };
155 return (HscNoRecomp pcs_ch bomb bomb)
159 when (verbosity (hsc_dflags hsc_env) >= 1) $
160 hPutStrLn stderr ("Skipping " ++
161 showModMsg have_object mod location);
164 (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
166 case maybe_tc_result of {
167 Nothing -> return (HscFail pcs_tc);
170 return (HscNoRecomp pcs_tc new_details old_iface)
173 hscRecomp hsc_env pcs_ch have_object
174 mod location maybe_checked_iface
176 -- what target are we shooting for?
177 ; let one_shot = hsc_mode hsc_env == OneShot
178 ; let dflags = hsc_dflags hsc_env
179 ; let toInterp = dopt_HscLang dflags == HscInterpreted
180 ; let toCore = isJust (ml_hs_file location) &&
181 isExtCore_file (fromJust (ml_hs_file location))
183 ; when (not one_shot && verbosity dflags >= 1) $
184 hPutStrLn stderr ("Compiling " ++
185 showModMsg (not toInterp) mod location);
187 ; front_res <- if toCore then
188 hscCoreFrontEnd hsc_env pcs_ch location
190 hscFrontEnd hsc_env pcs_ch location
193 Left flure -> return flure;
194 Right (pcs_tc, ds_result) -> do {
198 -- ; seqList imported_modules (return ())
203 ; flat_result <- _scc_ "Flattening"
204 flatten hsc_env pcs_tc ds_result
206 ; let pcs_middle = pcs_tc
208 {- Again, omit this because it loses the usage info
209 which is needed in mkIface. Maybe we should compute
213 <- _scc_ "pcs_middle"
215 do init_pcs <- initPersistentCompilerState
216 init_prs <- initPersistentRenamerState
218 rules = pcs_rules pcs_tc
219 orig_tc = prsOrig (pcs_PRS pcs_tc)
220 new_prs = init_prs{ prsOrig=orig_tc }
222 orig_tc `seq` rules `seq` new_prs `seq`
223 return init_pcs{ pcs_PRS = new_prs,
228 -- Should we remove bits of flat_result at this point?
229 -- ; flat_result <- case flat_result of
230 -- ModResult { md_binds = binds } ->
231 -- return ModDetails { md_binds = binds,
233 -- md_types = emptyTypeEnv,
236 -- alive at this point:
243 ; simpl_result <- _scc_ "Core2Core"
244 core2core hsc_env pcs_middle flat_result
249 ; cg_info_ref <- newIORef Nothing ;
250 ; let cg_info :: CgInfoEnv
251 cg_info = unsafePerformIO $ do {
252 maybe_cg_env <- readIORef cg_info_ref ;
254 Just env -> return env
255 Nothing -> do { printError "Urk! Looked at CgInfo too early!";
256 return emptyNameEnv } }
257 -- cg_info_ref will be filled in just after restOfCodeGeneration
258 -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
260 ; (pcs_simpl, tidy_result)
262 tidyCorePgm dflags pcs_middle cg_info simpl_result
264 -- Space-saving ploy doesn't work so well now
265 -- because mkIface needs the populated PIT to
266 -- generate usage info. Maybe we should re-visit this.
267 -- ; pcs_final <- if one_shot then initPersistentCompilerState
268 -- else return pcs_simpl
269 ; let pcs_final = pcs_simpl
271 -- Alive at this point:
272 -- tidy_result, pcs_final
275 -- PREPARE FOR CODE GENERATION
276 -- Do saturation and convert to A-normal form
277 ; prepd_result <- _scc_ "CorePrep"
278 corePrepPgm dflags tidy_result
281 -- CONVERT TO STG and COMPLETE CODE GENERATION
282 ; (stub_h_exists, stub_c_exists, maybe_bcos)
283 <- hscBackEnd dflags cg_info_ref prepd_result
286 -- BUILD THE NEW ModIface and ModDetails
287 -- and emit external core if necessary
288 -- This has to happen *after* code gen so that the back-end
289 -- info has been set. Not yet clear if it matters waiting
290 -- until after code output
291 ; final_iface <- _scc_ "MkFinalIface"
292 mkIface hsc_env location
293 maybe_checked_iface tidy_result
294 ; let final_details = ModDetails { md_types = mg_types tidy_result,
295 md_insts = mg_insts tidy_result,
296 md_rules = mg_rules tidy_result }
297 ; emitExternalCore dflags tidy_result
299 -- and the answer is ...
300 ; return (HscRecomp pcs_final
303 stub_h_exists stub_c_exists
307 hscCoreFrontEnd hsc_env pcs_ch location = do {
311 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
312 ; case parseCore inp 1 of
313 FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
314 OkP rdr_module -> do {
317 -- RENAME and TYPECHECK
319 ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
320 tcRnExtCore hsc_env pcs_ch rdr_module
321 ; case maybe_tc_result of {
322 Nothing -> return (Left (HscFail pcs_tc));
323 Just mod_guts -> return (Right (pcs_tc, mod_guts))
324 -- No desugaring to do!
328 hscFrontEnd hsc_env pcs_ch location = do {
332 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
333 (expectJust "hscRecomp:hspp" (ml_hspp_file location))
335 ; case maybe_parsed of {
336 Nothing -> return (Left (HscFail pcs_ch));
337 Just rdr_module -> do {
340 -- RENAME and TYPECHECK
342 ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
343 tcRnModule hsc_env pcs_ch rdr_module
344 ; case maybe_tc_result of {
345 Nothing -> return (Left (HscFail pcs_ch));
346 Just tc_result -> do {
351 ; ds_result <- _scc_ "DeSugar"
352 deSugar hsc_env pcs_tc tc_result
353 ; return (Right (pcs_tc, ds_result))
357 hscBackEnd dflags cg_info_ref prepd_result
358 = case dopt_HscLang dflags of
359 HscNothing -> return (False, False, Nothing)
363 do ----------------- Generate byte code ------------------
364 comp_bc <- byteCodeGen dflags prepd_result
366 -- Fill in the code-gen info
367 writeIORef cg_info_ref (Just emptyNameEnv)
369 ------------------ Create f-x-dynamic C-side stuff ---
370 (istub_h_exists, istub_c_exists)
371 <- outputForeignStubs dflags (mg_foreign prepd_result)
373 return ( istub_h_exists, istub_c_exists,
376 panic "GHC not compiled with interpreter"
381 ----------------- Convert to STG ------------------
382 (stg_binds, cost_centre_info, stg_back_end_info)
384 myCoreToStg dflags prepd_result
386 -- Fill in the code-gen info for the earlier tidyCorePgm
387 writeIORef cg_info_ref (Just stg_back_end_info)
389 ------------------ Code generation ------------------
390 abstractC <- _scc_ "CodeGen"
391 codeGen dflags prepd_result
392 cost_centre_info stg_binds
394 ------------------ Code output -----------------------
395 (stub_h_exists, stub_c_exists)
396 <- codeOutput dflags prepd_result
399 return (stub_h_exists, stub_c_exists, Nothing)
402 myParseModule dflags src_filename
403 = do -------------------------- Parser ----------------
404 showPass dflags "Parser"
406 buf <- hGetStringBuffer src_filename
408 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
409 ffiEF = dopt Opt_FFI dflags,
410 withEF = dopt Opt_With dflags,
411 parrEF = dopt Opt_PArr dflags}
412 loc = mkSrcLoc (mkFastString src_filename) 1
414 case parseModule buf (mkPState loc exts) of {
416 PFailed err -> do { hPutStrLn stderr (showSDoc err);
417 freeStringBuffer buf;
420 POk _ rdr_module -> do {
422 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
424 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
425 (ppSourceStats False rdr_module) ;
427 return (Just rdr_module)
428 -- ToDo: free the string buffer later.
432 myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
434 () <- coreBindsSize tidy_binds `seq` return ()
435 -- TEMP: the above call zaps some space usage allocated by the
436 -- simplifier, which for reasons I don't understand, persists
437 -- thoroughout code generation -- JRS
439 -- This is still necessary. -- SDM (10 Dec 2001)
441 stg_binds <- _scc_ "Core2Stg"
442 coreToStg dflags tidy_binds
444 (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
445 stg2stg dflags this_mod stg_binds
447 let env_rhs :: CgInfoEnv
448 env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
449 | (bind,_) <- stg_binds2,
451 | stgBindHasCafRefs bind = MayHaveCafRefs
452 | otherwise = NoCafRefs,
453 bndr <- stgBinders bind ]
455 return (stg_binds2, cost_centre_info, env_rhs)
459 %************************************************************************
461 \subsection{Compiling a do-statement}
463 %************************************************************************
465 When the UnlinkedBCOExpr is linked you get an HValue of type
467 When you run it you get a list of HValues that should be
468 the same length as the list of names; add them to the ClosureEnv.
470 A naked expression returns a singleton Name [it].
472 What you type The IO [HValue] that hscStmt returns
473 ------------- ------------------------------------
474 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
477 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
480 expr (of IO type) ==> expr >>= \ v -> return [v]
481 [NB: result not printed] bindings: [it]
484 expr (of non-IO type,
485 result showable) ==> let v = expr in print v >> return [v]
488 expr (of non-IO type,
489 result not showable) ==> error
493 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
495 -> PersistentCompilerState -- IN: persistent compiler state
496 -> InteractiveContext -- Context for compiling
497 -> String -- The statement
498 -> IO ( PersistentCompilerState,
499 Maybe (InteractiveContext, [Name], HValue) )
501 hscStmt hsc_env pcs icontext stmt
502 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
503 ; case maybe_stmt of {
504 Nothing -> return (pcs, Nothing) ;
505 Just parsed_stmt -> do {
507 -- Rename and typecheck it
508 (pcs1, maybe_tc_result)
509 <- tcRnStmt hsc_env pcs icontext parsed_stmt
511 ; case maybe_tc_result of {
512 Nothing -> return (pcs1, Nothing) ;
513 Just (new_ic, bound_names, tc_expr) -> do {
515 -- Then desugar, code gen, and link it
516 ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
517 (ic_rn_gbl_env new_ic)
521 ; return (pcs1, Just (new_ic, bound_names, hval))
524 hscTcExpr -- Typecheck an expression (but don't run it)
526 -> PersistentCompilerState -- IN: persistent compiler state
527 -> InteractiveContext -- Context for compiling
528 -> String -- The expression
529 -> IO (PersistentCompilerState, Maybe Type)
531 hscTcExpr hsc_env pcs icontext expr
532 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
533 ; case maybe_stmt of {
534 Just (ExprStmt expr _ _)
535 -> tcRnExpr hsc_env pcs icontext expr ;
536 Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
537 return (pcs, Nothing) } ;
538 Nothing -> return (pcs, Nothing) } }
542 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
543 hscParseStmt dflags str
544 = do showPass dflags "Parser"
547 buf <- stringToStringBuffer str
549 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
550 ffiEF = dopt Opt_FFI dflags,
551 withEF = dopt Opt_With dflags,
552 parrEF = dopt Opt_PArr dflags}
553 loc = mkSrcLoc FSLIT("<interactive>") 1
555 case parseStmt buf (mkPState loc exts) of {
557 PFailed err -> do { hPutStrLn stderr (showSDoc err);
558 -- Not yet implemented in <4.11 freeStringBuffer buf;
561 -- no stmt: the line consisted of just space or comments
562 POk _ Nothing -> return Nothing;
564 POk _ (Just rdr_stmt) -> do {
566 --ToDo: can't free the string buffer until we've finished this
567 -- compilation sweep and all the identifiers have gone away.
568 --freeStringBuffer buf;
569 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
570 return (Just rdr_stmt)
575 %************************************************************************
577 \subsection{Getting information about an identifer}
579 %************************************************************************
583 hscThing -- like hscStmt, but deals with a single identifier
585 -> PersistentCompilerState -- IN: persistent compiler state
586 -> InteractiveContext -- Context for compiling
587 -> String -- The identifier
588 -> IO ( PersistentCompilerState,
591 hscThing hsc_env pcs0 ic str
592 = do let dflags = hsc_dflags hsc_env
594 maybe_rdr_name <- myParseIdentifier dflags str
595 case maybe_rdr_name of {
596 Nothing -> return (pcs0, []);
599 (pcs1, maybe_tc_result) <-
600 tcRnThing hsc_env pcs0 ic rdr_name
602 case maybe_tc_result of {
603 Nothing -> return (pcs1, []) ;
604 Just things -> return (pcs1, things)
607 myParseIdentifier dflags str
608 = do buf <- stringToStringBuffer str
610 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
611 ffiEF = dopt Opt_FFI dflags,
612 withEF = dopt Opt_With dflags,
613 parrEF = dopt Opt_PArr dflags}
614 loc = mkSrcLoc FSLIT("<interactive>") 1
616 case parseIdentifier buf (mkPState loc exts) of
618 PFailed err -> do { hPutStrLn stderr (showSDoc err);
619 freeStringBuffer buf;
622 POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
623 return (Just rdr_name) }
627 %************************************************************************
629 Desugar, simplify, convert to bytecode, and link an expression
631 %************************************************************************
635 compileExpr :: HscEnv
636 -> PersistentCompilerState
637 -> Module -> GlobalRdrEnv -> TypeEnv
641 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
642 = do { let dflags = hsc_dflags hsc_env
645 ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
648 ; flat_expr <- flattenExpr hsc_env pcs ds_expr
651 ; simpl_expr <- simplifyExpr dflags flat_expr
653 -- Tidy it (temporary, until coreSat does cloning)
654 ; tidy_expr <- tidyCoreExpr simpl_expr
656 -- Prepare for codegen
657 ; prepd_expr <- corePrepExpr dflags tidy_expr
660 ; bcos <- coreExprToBCOs dflags prepd_expr
663 ; hval <- linkExpr hsc_env pcs bcos
671 %************************************************************************
673 \subsection{Initial persistent state}
675 %************************************************************************
678 initPersistentCompilerState :: IO PersistentCompilerState
679 initPersistentCompilerState
680 = do nc <- initNameCache
682 PCS { pcs_EPS = initExternalPackageState,
685 initNameCache :: IO NameCache
686 = do us <- mkSplitUniqSupply 'r'
687 return (NameCache { nsUniqs = us,
688 nsNames = initOrigNames,
691 initExternalPackageState :: ExternalPackageState
692 initExternalPackageState
694 eps_decls = (emptyNameEnv, 0),
695 eps_insts = (emptyBag, 0),
696 eps_inst_gates = emptyNameSet,
697 eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
699 eps_PIT = emptyPackageIfaceTable,
700 eps_PTE = wiredInThingEnv,
701 eps_inst_env = emptyInstEnv,
702 eps_rule_base = emptyRuleBase }
705 add_rule (name,rule) (rules, n_slurped)
706 = (gated_decl `consBag` rules, n_slurped)
708 gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
709 mod = nameModule name
710 rdr_name = nameRdrName name
711 gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
713 initOrigNames :: OrigNameCache
715 = insert knownKeyNames $
716 insert (map getName wiredInThings) $
719 insert names env = foldl extendOrigNameCache env names