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 )
35 import RdrName ( nameRdrName )
37 import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
38 import StringBuffer ( hGetStringBuffer, freeStringBuffer )
40 import Lex ( ParseResult(..), ExtFlags(..), mkPState )
41 import SrcLoc ( mkSrcLoc )
42 import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
43 import Rules ( emptyRuleBase )
44 import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
45 import PrelRules ( builtinRules )
46 import MkIface ( mkIface )
47 import InstEnv ( emptyInstEnv )
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 ( ModuleName, moduleName )
62 import DriverPhases ( isExtCore_file )
63 import ErrUtils ( dumpIfSet_dyn, showPass, printError )
64 import UniqSupply ( mkSplitUniqSupply )
66 import Bag ( consBag, emptyBag )
68 import HscStats ( ppSourceStats )
70 import MkExternalCore ( emitExternalCore )
72 import ParserCoreUtils
73 import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
74 import OccName ( OccName )
75 import Name ( Name, nameModule, nameOccName, getName )
76 import NameEnv ( emptyNameEnv, mkNameEnv )
77 import NameSet ( emptyNameSet )
78 import Module ( Module, ModLocation(..), showModMsg )
80 import Maybes ( expectJust )
82 import DATA_IOREF ( newIORef, readIORef, writeIORef )
83 import UNSAFE_IO ( unsafePerformIO )
86 import Maybe ( isJust, fromJust )
91 %************************************************************************
93 \subsection{The main compiler pipeline}
95 %************************************************************************
100 = HscFail PersistentCompilerState -- updated PCS
101 -- concluded that it wasn't necessary
102 | HscNoRecomp PersistentCompilerState -- updated PCS
103 ModDetails -- new details (HomeSymbolTable additions)
104 ModIface -- new iface (if any compilation was done)
106 | HscRecomp PersistentCompilerState -- updated PCS
107 ModDetails -- new details (HomeSymbolTable additions)
108 ModIface -- new iface (if any compilation was done)
109 Bool -- stub_h exists
110 Bool -- stub_c exists
111 (Maybe CompiledByteCode)
113 -- no errors or warnings; the individual passes
114 -- (parse/rename/typecheck) print messages themselves
118 -> PersistentCompilerState -- IN: persistent compiler state
120 -> ModLocation -- location info
121 -> Bool -- True <=> source unchanged
122 -> Bool -- True <=> have an object file (for msgs only)
123 -> Maybe ModIface -- old interface, if available
126 hscMain hsc_env pcs mod location
127 source_unchanged have_object maybe_old_iface
129 (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
130 checkOldIface hsc_env pcs mod
131 (ml_hi_file location)
132 source_unchanged maybe_old_iface;
133 case maybe_chk_result of {
134 Nothing -> return (HscFail pcs_ch) ;
135 Just (recomp_reqd, maybe_checked_iface) -> do {
137 let no_old_iface = not (isJust maybe_checked_iface)
138 what_next | recomp_reqd || no_old_iface = hscRecomp
139 | otherwise = hscNoRecomp
141 ; what_next hsc_env pcs_ch have_object
142 mod location maybe_checked_iface
146 -- hscNoRecomp definitely expects to have the old interface available
147 hscNoRecomp hsc_env pcs_ch have_object
148 mod location (Just old_iface)
149 | hsc_mode hsc_env == OneShot
151 when (verbosity (hsc_dflags hsc_env) > 0) $
152 hPutStrLn stderr "compilation IS NOT required";
153 let { bomb = panic "hscNoRecomp:OneShot" };
154 return (HscNoRecomp pcs_ch bomb bomb)
158 when (verbosity (hsc_dflags hsc_env) >= 1) $
159 hPutStrLn stderr ("Skipping " ++
160 showModMsg have_object mod location);
163 (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
165 case maybe_tc_result of {
166 Nothing -> return (HscFail pcs_tc);
169 return (HscNoRecomp pcs_tc new_details old_iface)
172 hscRecomp hsc_env pcs_ch have_object
173 mod location maybe_checked_iface
175 -- what target are we shooting for?
176 ; let one_shot = hsc_mode hsc_env == OneShot
177 ; let dflags = hsc_dflags hsc_env
178 ; let toInterp = dopt_HscLang dflags == HscInterpreted
179 ; let toCore = isJust (ml_hs_file location) &&
180 isExtCore_file (fromJust (ml_hs_file location))
182 ; when (not one_shot && verbosity dflags >= 1) $
183 hPutStrLn stderr ("Compiling " ++
184 showModMsg (not toInterp) mod location);
186 ; front_res <- if toCore then
187 hscCoreFrontEnd hsc_env pcs_ch location
189 hscFrontEnd hsc_env pcs_ch location
192 Left flure -> return flure;
193 Right (pcs_tc, ds_result) -> do {
197 -- ; seqList imported_modules (return ())
202 ; flat_result <- _scc_ "Flattening"
203 flatten hsc_env pcs_tc ds_result
205 ; let pcs_middle = pcs_tc
207 {- Again, omit this because it loses the usage info
208 which is needed in mkIface. Maybe we should compute
212 <- _scc_ "pcs_middle"
214 do init_pcs <- initPersistentCompilerState
215 init_prs <- initPersistentRenamerState
217 rules = pcs_rules pcs_tc
218 orig_tc = prsOrig (pcs_PRS pcs_tc)
219 new_prs = init_prs{ prsOrig=orig_tc }
221 orig_tc `seq` rules `seq` new_prs `seq`
222 return init_pcs{ pcs_PRS = new_prs,
227 -- Should we remove bits of flat_result at this point?
228 -- ; flat_result <- case flat_result of
229 -- ModResult { md_binds = binds } ->
230 -- return ModDetails { md_binds = binds,
232 -- md_types = emptyTypeEnv,
235 -- alive at this point:
242 ; simpl_result <- _scc_ "Core2Core"
243 core2core hsc_env pcs_middle flat_result
248 ; cg_info_ref <- newIORef Nothing ;
249 ; let cg_info :: CgInfoEnv
250 cg_info = unsafePerformIO $ do {
251 maybe_cg_env <- readIORef cg_info_ref ;
253 Just env -> return env
254 Nothing -> do { printError "Urk! Looked at CgInfo too early!";
255 return emptyNameEnv } }
256 -- cg_info_ref will be filled in just after restOfCodeGeneration
257 -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
259 ; (pcs_simpl, tidy_result)
261 tidyCorePgm dflags pcs_middle cg_info simpl_result
263 -- Space-saving ploy doesn't work so well now
264 -- because mkIface needs the populated PIT to
265 -- generate usage info. Maybe we should re-visit this.
266 -- ; pcs_final <- if one_shot then initPersistentCompilerState
267 -- else return pcs_simpl
268 ; let pcs_final = pcs_simpl
270 -- Alive at this point:
271 -- tidy_result, pcs_final
274 -- PREPARE FOR CODE GENERATION
275 -- Do saturation and convert to A-normal form
276 ; prepd_result <- _scc_ "CorePrep"
277 corePrepPgm dflags tidy_result
280 -- CONVERT TO STG and COMPLETE CODE GENERATION
281 ; (stub_h_exists, stub_c_exists, maybe_bcos)
282 <- hscBackEnd dflags cg_info_ref prepd_result
285 -- BUILD THE NEW ModIface and ModDetails
286 -- and emit external core if necessary
287 -- This has to happen *after* code gen so that the back-end
288 -- info has been set. Not yet clear if it matters waiting
289 -- until after code output
290 ; final_iface <- _scc_ "MkFinalIface"
291 mkIface hsc_env location
292 maybe_checked_iface tidy_result
293 ; let final_details = ModDetails { md_types = mg_types tidy_result,
294 md_insts = mg_insts tidy_result,
295 md_rules = mg_rules tidy_result }
296 ; emitExternalCore dflags tidy_result
298 -- and the answer is ...
299 ; return (HscRecomp pcs_final
302 stub_h_exists stub_c_exists
306 hscCoreFrontEnd hsc_env pcs_ch location = do {
310 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
311 ; case parseCore inp 1 of
312 FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
313 OkP rdr_module -> do {
316 -- RENAME and TYPECHECK
318 ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
319 tcRnExtCore hsc_env pcs_ch rdr_module
320 ; case maybe_tc_result of {
321 Nothing -> return (Left (HscFail pcs_tc));
322 Just mod_guts -> return (Right (pcs_tc, mod_guts))
323 -- No desugaring to do!
327 hscFrontEnd hsc_env pcs_ch location = do {
331 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
332 (expectJust "hscRecomp:hspp" (ml_hspp_file location))
334 ; case maybe_parsed of {
335 Nothing -> return (Left (HscFail pcs_ch));
336 Just rdr_module -> do {
339 -- RENAME and TYPECHECK
341 ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
342 tcRnModule hsc_env pcs_ch rdr_module
343 ; case maybe_tc_result of {
344 Nothing -> return (Left (HscFail pcs_ch));
345 Just tc_result -> do {
350 ; ds_result <- _scc_ "DeSugar"
351 deSugar hsc_env pcs_tc tc_result
352 ; return (Right (pcs_tc, ds_result))
356 hscBackEnd dflags cg_info_ref prepd_result
357 = case dopt_HscLang dflags of
358 HscNothing -> return (False, False, Nothing)
362 do ----------------- Generate byte code ------------------
363 comp_bc <- byteCodeGen dflags prepd_result
365 -- Fill in the code-gen info
366 writeIORef cg_info_ref (Just emptyNameEnv)
368 ------------------ Create f-x-dynamic C-side stuff ---
369 (istub_h_exists, istub_c_exists)
370 <- outputForeignStubs dflags (mg_foreign prepd_result)
372 return ( istub_h_exists, istub_c_exists,
375 panic "GHC not compiled with interpreter"
380 ----------------- Convert to STG ------------------
381 (stg_binds, cost_centre_info, stg_back_end_info)
383 myCoreToStg dflags prepd_result
385 -- Fill in the code-gen info for the earlier tidyCorePgm
386 writeIORef cg_info_ref (Just stg_back_end_info)
388 ------------------ Code generation ------------------
389 abstractC <- _scc_ "CodeGen"
390 codeGen dflags prepd_result
391 cost_centre_info stg_binds
393 ------------------ Code output -----------------------
394 (stub_h_exists, stub_c_exists)
395 <- codeOutput dflags prepd_result
398 return (stub_h_exists, stub_c_exists, Nothing)
401 myParseModule dflags src_filename
402 = do -------------------------- Parser ----------------
403 showPass dflags "Parser"
405 buf <- hGetStringBuffer src_filename
407 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
408 ffiEF = dopt Opt_FFI dflags,
409 withEF = dopt Opt_With dflags,
410 parrEF = dopt Opt_PArr dflags}
411 loc = mkSrcLoc (mkFastString src_filename) 1
413 case parseModule buf (mkPState loc exts) of {
415 PFailed err -> do { hPutStrLn stderr (showSDoc err);
416 freeStringBuffer buf;
419 POk _ rdr_module -> do {
421 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
423 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
424 (ppSourceStats False rdr_module) ;
426 return (Just rdr_module)
427 -- ToDo: free the string buffer later.
431 myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
433 () <- coreBindsSize tidy_binds `seq` return ()
434 -- TEMP: the above call zaps some space usage allocated by the
435 -- simplifier, which for reasons I don't understand, persists
436 -- thoroughout code generation -- JRS
438 -- This is still necessary. -- SDM (10 Dec 2001)
440 stg_binds <- _scc_ "Core2Stg"
441 coreToStg dflags tidy_binds
443 (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
444 stg2stg dflags this_mod stg_binds
446 let env_rhs :: CgInfoEnv
447 env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
448 | (bind,_) <- stg_binds2,
450 | stgBindHasCafRefs bind = MayHaveCafRefs
451 | otherwise = NoCafRefs,
452 bndr <- stgBinders bind ]
454 return (stg_binds2, cost_centre_info, env_rhs)
458 %************************************************************************
460 \subsection{Compiling a do-statement}
462 %************************************************************************
464 When the UnlinkedBCOExpr is linked you get an HValue of type
466 When you run it you get a list of HValues that should be
467 the same length as the list of names; add them to the ClosureEnv.
469 A naked expression returns a singleton Name [it].
471 What you type The IO [HValue] that hscStmt returns
472 ------------- ------------------------------------
473 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
476 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
479 expr (of IO type) ==> expr >>= \ v -> return [v]
480 [NB: result not printed] bindings: [it]
483 expr (of non-IO type,
484 result showable) ==> let v = expr in print v >> return [v]
487 expr (of non-IO type,
488 result not showable) ==> error
492 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
494 -> PersistentCompilerState -- IN: persistent compiler state
495 -> InteractiveContext -- Context for compiling
496 -> String -- The statement
497 -> IO ( PersistentCompilerState,
498 Maybe (InteractiveContext, [Name], HValue) )
500 hscStmt hsc_env pcs icontext stmt
501 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
502 ; case maybe_stmt of {
503 Nothing -> return (pcs, Nothing) ;
504 Just parsed_stmt -> do {
506 -- Rename and typecheck it
507 (pcs1, maybe_tc_result)
508 <- tcRnStmt hsc_env pcs icontext parsed_stmt
510 ; case maybe_tc_result of {
511 Nothing -> return (pcs1, Nothing) ;
512 Just (new_ic, bound_names, tc_expr) -> do {
514 -- Then desugar, code gen, and link it
515 ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
516 (icPrintUnqual new_ic) tc_expr
518 ; return (pcs1, Just (new_ic, bound_names, hval))
521 hscTcExpr -- Typecheck an expression (but don't run it)
523 -> PersistentCompilerState -- IN: persistent compiler state
524 -> InteractiveContext -- Context for compiling
525 -> String -- The expression
526 -> IO (PersistentCompilerState, Maybe Type)
528 hscTcExpr hsc_env pcs icontext expr
529 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
530 ; case maybe_stmt of {
531 Just (ExprStmt expr _ _)
532 -> tcRnExpr hsc_env pcs icontext expr ;
533 Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
534 return (pcs, Nothing) } ;
535 Nothing -> return (pcs, Nothing) } }
539 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
540 hscParseStmt dflags str
541 = do showPass dflags "Parser"
544 buf <- stringToStringBuffer str
546 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
547 ffiEF = dopt Opt_FFI dflags,
548 withEF = dopt Opt_With dflags,
549 parrEF = dopt Opt_PArr dflags}
550 loc = mkSrcLoc FSLIT("<interactive>") 1
552 case parseStmt buf (mkPState loc exts) of {
554 PFailed err -> do { hPutStrLn stderr (showSDoc err);
555 -- Not yet implemented in <4.11 freeStringBuffer buf;
558 -- no stmt: the line consisted of just space or comments
559 POk _ Nothing -> return Nothing;
561 POk _ (Just rdr_stmt) -> do {
563 --ToDo: can't free the string buffer until we've finished this
564 -- compilation sweep and all the identifiers have gone away.
565 --freeStringBuffer buf;
566 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
567 return (Just rdr_stmt)
572 %************************************************************************
574 \subsection{Getting information about an identifer}
576 %************************************************************************
580 hscThing -- like hscStmt, but deals with a single identifier
582 -> PersistentCompilerState -- IN: persistent compiler state
583 -> InteractiveContext -- Context for compiling
584 -> String -- The identifier
585 -> IO ( PersistentCompilerState,
588 hscThing hsc_env pcs0 ic str
589 = do let dflags = hsc_dflags hsc_env
591 maybe_rdr_name <- myParseIdentifier dflags str
592 case maybe_rdr_name of {
593 Nothing -> return (pcs0, []);
596 (pcs1, maybe_tc_result) <-
597 tcRnThing hsc_env pcs0 ic rdr_name
599 case maybe_tc_result of {
600 Nothing -> return (pcs1, []) ;
601 Just things -> return (pcs1, things)
604 myParseIdentifier dflags str
605 = do buf <- stringToStringBuffer str
607 let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
608 ffiEF = dopt Opt_FFI dflags,
609 withEF = dopt Opt_With dflags,
610 parrEF = dopt Opt_PArr dflags}
611 loc = mkSrcLoc FSLIT("<interactive>") 1
613 case parseIdentifier buf (mkPState loc exts) of
615 PFailed err -> do { hPutStrLn stderr (showSDoc err);
616 freeStringBuffer buf;
619 POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
620 return (Just rdr_name) }
624 %************************************************************************
626 Desugar, simplify, convert to bytecode, and link an expression
628 %************************************************************************
632 compileExpr :: HscEnv
633 -> PersistentCompilerState
634 -> Module -> PrintUnqualified
638 compileExpr hsc_env pcs this_mod print_unqual tc_expr
639 = do { let dflags = hsc_dflags hsc_env
642 ; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr
645 ; flat_expr <- flattenExpr hsc_env pcs ds_expr
648 ; simpl_expr <- simplifyExpr dflags flat_expr
650 -- Tidy it (temporary, until coreSat does cloning)
651 ; tidy_expr <- tidyCoreExpr simpl_expr
653 -- Prepare for codegen
654 ; prepd_expr <- corePrepExpr dflags tidy_expr
657 ; bcos <- coreExprToBCOs dflags prepd_expr
660 ; hval <- linkExpr hsc_env pcs bcos
668 %************************************************************************
670 \subsection{Initial persistent state}
672 %************************************************************************
675 initPersistentCompilerState :: IO PersistentCompilerState
676 initPersistentCompilerState
677 = do nc <- initNameCache
679 PCS { pcs_EPS = initExternalPackageState,
682 initNameCache :: IO NameCache
683 = do us <- mkSplitUniqSupply 'r'
684 return (NameCache { nsUniqs = us,
685 nsNames = initOrigNames,
688 initExternalPackageState :: ExternalPackageState
689 initExternalPackageState
691 eps_decls = (emptyNameEnv, 0),
692 eps_insts = (emptyBag, 0),
693 eps_inst_gates = emptyNameSet,
694 eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
695 eps_imp_mods = emptyFM,
697 eps_PIT = emptyPackageIfaceTable,
698 eps_PTE = wiredInThingEnv,
699 eps_inst_env = emptyInstEnv,
700 eps_rule_base = emptyRuleBase }
703 add_rule (name,rule) (rules, n_slurped)
704 = (gated_decl `consBag` rules, n_slurped)
706 gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
707 mod = nameModule name
708 rdr_name = nameRdrName name
709 gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
711 initOrigNames :: FiniteMap (ModuleName,OccName) Name
713 = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
715 grab names = foldl add emptyFM names
717 = addToFM env (moduleName (nameModule name), nameOccName name) name