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 )
32 import CoreLint ( lintUnfolding )
37 import RdrName ( nameRdrName )
39 import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
40 import StringBuffer ( hGetStringBuffer, freeStringBuffer )
42 import Lex ( ParseResult(..), ExtFlags(..), mkPState )
43 import SrcLoc ( mkSrcLoc, noSrcLoc )
44 import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
45 import RnEnv ( extendOrigNameCache )
46 import Rules ( emptyRuleBase )
47 import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
48 import PrelRules ( builtinRules )
49 import MkIface ( mkIface )
50 import InstEnv ( emptyInstEnv )
52 import Flattening ( flatten )
54 import CoreUtils ( coreBindsSize )
55 import TidyPgm ( tidyCorePgm )
56 import CorePrep ( corePrepPgm )
58 import CoreToStg ( coreToStg )
59 import SimplStg ( stg2stg )
60 import CodeGen ( codeGen )
61 import CodeOutput ( codeOutput )
63 import Module ( emptyModuleEnv )
65 import DriverPhases ( isExtCore_file )
66 import ErrUtils ( dumpIfSet_dyn, showPass, printError )
67 import UniqSupply ( mkSplitUniqSupply )
69 import Bag ( consBag, emptyBag )
71 import HscStats ( ppSourceStats )
73 import MkExternalCore ( emitExternalCore )
75 import ParserCoreUtils
76 import FiniteMap ( emptyFM )
77 import Name ( nameModule, getName )
78 import NameEnv ( emptyNameEnv, mkNameEnv )
79 import NameSet ( emptyNameSet )
80 import Module ( Module, ModLocation(..), showModMsg )
82 import Maybes ( expectJust )
84 import DATA_IOREF ( newIORef, readIORef, writeIORef )
85 import UNSAFE_IO ( unsafePerformIO )
88 import Maybe ( isJust, fromJust )
93 %************************************************************************
95 \subsection{The main compiler pipeline}
97 %************************************************************************
101 -- compilation failed
102 = HscFail PersistentCompilerState -- updated PCS
103 -- concluded that it wasn't necessary
104 | HscNoRecomp PersistentCompilerState -- updated PCS
105 ModDetails -- new details (HomeSymbolTable additions)
106 ModIface -- new iface (if any compilation was done)
108 | HscRecomp PersistentCompilerState -- updated PCS
109 ModDetails -- new details (HomeSymbolTable additions)
110 ModIface -- new iface (if any compilation was done)
111 Bool -- stub_h exists
112 Bool -- stub_c exists
113 (Maybe CompiledByteCode)
115 -- no errors or warnings; the individual passes
116 -- (parse/rename/typecheck) print messages themselves
120 -> PersistentCompilerState -- IN: persistent compiler state
122 -> ModLocation -- location info
123 -> Bool -- True <=> source unchanged
124 -> Bool -- True <=> have an object file (for msgs only)
125 -> Maybe ModIface -- old interface, if available
128 hscMain hsc_env pcs mod location
129 source_unchanged have_object maybe_old_iface
131 (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
132 checkOldIface hsc_env pcs mod
133 (ml_hi_file location)
134 source_unchanged maybe_old_iface;
135 case maybe_chk_result of {
136 Nothing -> return (HscFail pcs_ch) ;
137 Just (recomp_reqd, maybe_checked_iface) -> do {
139 let no_old_iface = not (isJust maybe_checked_iface)
140 what_next | recomp_reqd || no_old_iface = hscRecomp
141 | otherwise = hscNoRecomp
143 ; what_next hsc_env pcs_ch have_object
144 mod location maybe_checked_iface
148 -- hscNoRecomp definitely expects to have the old interface available
149 hscNoRecomp hsc_env pcs_ch have_object
150 mod location (Just old_iface)
151 | hsc_mode hsc_env == OneShot
153 when (verbosity (hsc_dflags hsc_env) > 0) $
154 hPutStrLn stderr "compilation IS NOT required";
155 let { bomb = panic "hscNoRecomp:OneShot" };
156 return (HscNoRecomp pcs_ch bomb bomb)
160 when (verbosity (hsc_dflags hsc_env) >= 1) $
161 hPutStrLn stderr ("Skipping " ++
162 showModMsg have_object mod location);
165 (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
167 case maybe_tc_result of {
168 Nothing -> return (HscFail pcs_tc);
171 return (HscNoRecomp pcs_tc new_details old_iface)
174 hscRecomp hsc_env pcs_ch have_object
175 mod location maybe_checked_iface
177 -- what target are we shooting for?
178 ; let one_shot = hsc_mode hsc_env == OneShot
179 ; let dflags = hsc_dflags hsc_env
180 ; let toInterp = dopt_HscLang dflags == HscInterpreted
181 ; let toCore = isJust (ml_hs_file location) &&
182 isExtCore_file (fromJust (ml_hs_file location))
184 ; when (not one_shot && verbosity dflags >= 1) $
185 hPutStrLn stderr ("Compiling " ++
186 showModMsg (not toInterp) mod location);
188 ; front_res <- if toCore then
189 hscCoreFrontEnd hsc_env pcs_ch location
191 hscFrontEnd hsc_env pcs_ch location
194 Left flure -> return flure;
195 Right (pcs_tc, ds_result) -> do {
199 -- ; seqList imported_modules (return ())
204 ; flat_result <- _scc_ "Flattening"
205 flatten hsc_env pcs_tc ds_result
207 ; let pcs_middle = pcs_tc
209 {- Again, omit this because it loses the usage info
210 which is needed in mkIface. Maybe we should compute
214 <- _scc_ "pcs_middle"
216 do init_pcs <- initPersistentCompilerState
217 init_prs <- initPersistentRenamerState
219 rules = pcs_rules pcs_tc
220 orig_tc = prsOrig (pcs_PRS pcs_tc)
221 new_prs = init_prs{ prsOrig=orig_tc }
223 orig_tc `seq` rules `seq` new_prs `seq`
224 return init_pcs{ pcs_PRS = new_prs,
229 -- Should we remove bits of flat_result at this point?
230 -- ; flat_result <- case flat_result of
231 -- ModResult { md_binds = binds } ->
232 -- return ModDetails { md_binds = binds,
234 -- md_types = emptyTypeEnv,
237 -- alive at this point:
244 ; simpl_result <- _scc_ "Core2Core"
245 core2core hsc_env pcs_middle flat_result
250 ; cg_info_ref <- newIORef Nothing ;
251 ; let cg_info :: CgInfoEnv
252 cg_info = unsafePerformIO $ do {
253 maybe_cg_env <- readIORef cg_info_ref ;
255 Just env -> return env
256 Nothing -> do { printError "Urk! Looked at CgInfo too early!";
257 return emptyNameEnv } }
258 -- cg_info_ref will be filled in just after restOfCodeGeneration
259 -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
261 ; (pcs_simpl, tidy_result)
263 tidyCorePgm dflags pcs_middle cg_info simpl_result
265 -- Space-saving ploy doesn't work so well now
266 -- because mkIface needs the populated PIT to
267 -- generate usage info. Maybe we should re-visit this.
268 -- ; pcs_final <- if one_shot then initPersistentCompilerState
269 -- else return pcs_simpl
270 ; let pcs_final = pcs_simpl
272 -- Alive at this point:
273 -- tidy_result, pcs_final
276 -- PREPARE FOR CODE GENERATION
277 -- Do saturation and convert to A-normal form
278 ; prepd_result <- _scc_ "CorePrep"
279 corePrepPgm dflags tidy_result
282 -- CONVERT TO STG and COMPLETE CODE GENERATION
283 ; (stub_h_exists, stub_c_exists, maybe_bcos)
284 <- hscBackEnd dflags cg_info_ref prepd_result
287 -- BUILD THE NEW ModIface and ModDetails
288 -- and emit external core if necessary
289 -- This has to happen *after* code gen so that the back-end
290 -- info has been set. Not yet clear if it matters waiting
291 -- until after code output
292 ; final_iface <- _scc_ "MkFinalIface"
293 mkIface hsc_env location
294 maybe_checked_iface tidy_result
295 ; let final_details = ModDetails { md_types = mg_types tidy_result,
296 md_insts = mg_insts tidy_result,
297 md_rules = mg_rules tidy_result }
298 ; emitExternalCore dflags tidy_result
300 -- and the answer is ...
301 ; return (HscRecomp pcs_final
304 stub_h_exists stub_c_exists
308 hscCoreFrontEnd hsc_env pcs_ch location = do {
312 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
313 ; case parseCore inp 1 of
314 FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
315 OkP rdr_module -> do {
318 -- RENAME and TYPECHECK
320 ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
321 tcRnExtCore hsc_env pcs_ch rdr_module
322 ; case maybe_tc_result of {
323 Nothing -> return (Left (HscFail pcs_tc));
324 Just mod_guts -> return (Right (pcs_tc, mod_guts))
325 -- No desugaring to do!
329 hscFrontEnd hsc_env pcs_ch location = do {
333 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
334 (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
336 ; case maybe_parsed of {
337 Nothing -> return (Left (HscFail pcs_ch));
338 Just rdr_module -> do {
341 -- RENAME and TYPECHECK
343 ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
344 tcRnModule hsc_env pcs_ch rdr_module
345 ; case maybe_tc_result of {
346 Nothing -> return (Left (HscFail pcs_ch));
347 Just tc_result -> do {
352 ; ds_result <- _scc_ "DeSugar"
353 deSugar hsc_env pcs_tc tc_result
354 ; return (Right (pcs_tc, ds_result))
358 hscBackEnd dflags cg_info_ref prepd_result
359 = case dopt_HscLang dflags of
360 HscNothing -> return (False, False, Nothing)
364 do ----------------- Generate byte code ------------------
365 comp_bc <- byteCodeGen dflags prepd_result
367 -- Fill in the code-gen info
368 writeIORef cg_info_ref (Just emptyNameEnv)
370 ------------------ Create f-x-dynamic C-side stuff ---
371 (istub_h_exists, istub_c_exists)
372 <- outputForeignStubs dflags (mg_foreign prepd_result)
374 return ( istub_h_exists, istub_c_exists,
377 panic "GHC not compiled with interpreter"
382 ----------------- Convert to STG ------------------
383 (stg_binds, cost_centre_info, stg_back_end_info)
385 myCoreToStg dflags prepd_result
387 -- Fill in the code-gen info for the earlier tidyCorePgm
388 writeIORef cg_info_ref (Just stg_back_end_info)
390 ------------------ Code generation ------------------
391 abstractC <- _scc_ "CodeGen"
392 codeGen dflags prepd_result
393 cost_centre_info stg_binds
395 ------------------ Code output -----------------------
396 (stub_h_exists, stub_c_exists)
397 <- codeOutput dflags prepd_result abstractC
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 ;
643 lint_on = dopt Opt_DoCoreLinting dflags }
646 ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
649 ; flat_expr <- flattenExpr hsc_env pcs ds_expr
652 ; simpl_expr <- simplifyExpr dflags flat_expr
654 -- Tidy it (temporary, until coreSat does cloning)
655 ; tidy_expr <- tidyCoreExpr simpl_expr
657 -- Prepare for codegen
658 ; prepd_expr <- corePrepExpr dflags tidy_expr
661 -- ToDo: improve SrcLoc
663 case lintUnfolding noSrcLoc [] prepd_expr of
664 Just err -> pprPanic "compileExpr" err
670 ; bcos <- coreExprToBCOs dflags prepd_expr
673 ; hval <- linkExpr hsc_env pcs bcos
681 %************************************************************************
683 \subsection{Initial persistent state}
685 %************************************************************************
688 initPersistentCompilerState :: IO PersistentCompilerState
689 initPersistentCompilerState
690 = do nc <- initNameCache
692 PCS { pcs_EPS = initExternalPackageState,
695 initNameCache :: IO NameCache
696 = do us <- mkSplitUniqSupply 'r'
697 return (NameCache { nsUniqs = us,
698 nsNames = initOrigNames,
701 initExternalPackageState :: ExternalPackageState
702 initExternalPackageState
704 eps_decls = (emptyNameEnv, 0),
705 eps_insts = (emptyBag, 0),
706 eps_inst_gates = emptyNameSet,
707 eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
709 eps_PIT = emptyPackageIfaceTable,
710 eps_PTE = wiredInThingEnv,
711 eps_inst_env = emptyInstEnv,
712 eps_rule_base = emptyRuleBase }
715 add_rule (name,rule) (rules, n_slurped)
716 = (gated_decl `consBag` rules, n_slurped)
718 gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
719 mod = nameModule name
720 rdr_name = nameRdrName name
721 gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
723 initOrigNames :: OrigNameCache
725 = insert knownKeyNames $
726 insert (map getName wiredInThings) $
729 insert names env = foldl extendOrigNameCache env names