2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
5 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
9 HscResult(..), hscMain, newHscEnv
11 , hscStmt, hscTcExpr, hscThing,
16 #include "HsVersions.h"
19 import HsSyn ( Stmt(..), LStmt, LHsExpr )
20 import IfaceSyn ( IfaceDecl )
21 import CodeOutput ( outputForeignStubs )
22 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
23 import Linker ( HValue, linkExpr )
24 import TidyPgm ( tidyCoreExpr )
25 import CorePrep ( corePrepExpr )
26 import Flattening ( flattenExpr )
27 import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing )
28 import RdrName ( RdrName, GlobalRdrEnv )
30 import PrelNames ( iNTERACTIVE )
31 import StringBuffer ( stringToStringBuffer )
32 import SrcLoc ( noSrcLoc, Located(..) )
35 import CoreLint ( lintUnfolding )
36 import DsMeta ( templateHaskellNames )
37 import BasicTypes ( Fixity )
40 import StringBuffer ( hGetStringBuffer )
42 import Lexer ( P(..), ParseResult(..), mkPState )
43 import SrcLoc ( mkSrcLoc )
44 import TcRnDriver ( tcRnModule, tcRnExtCore )
45 import TcIface ( typecheckIface )
46 import IfaceEnv ( initNameCache )
47 import LoadIface ( ifaceStats, initExternalPackageState )
48 import PrelInfo ( wiredInThings, basicKnownKeyNames )
49 import RdrName ( GlobalRdrEnv )
50 import MkIface ( checkOldIface, mkIface )
52 import Flattening ( flatten )
54 import TidyPgm ( tidyCorePgm )
55 import CorePrep ( corePrepPgm )
56 import CoreToStg ( coreToStg )
57 import Name ( Name, NamedThing(..) )
58 import SimplStg ( stg2stg )
59 import CodeGen ( codeGen )
60 import CodeOutput ( codeOutput )
63 import DriverPhases ( isExtCoreFilename )
64 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printError )
65 import UniqSupply ( mkSplitUniqSupply )
68 import HscStats ( ppSourceStats )
70 import MkExternalCore ( emitExternalCore )
72 import ParserCoreUtils
73 import Module ( Module, ModLocation(..), showModMsg )
75 import Maybes ( expectJust )
78 import Maybe ( isJust, fromJust )
80 import DATA_IOREF ( newIORef, readIORef )
84 %************************************************************************
88 %************************************************************************
91 newHscEnv :: GhciMode -> DynFlags -> IO HscEnv
92 newHscEnv ghci_mode dflags
93 = do { eps_var <- newIORef initExternalPackageState
94 ; us <- mkSplitUniqSupply 'r'
95 ; nc_var <- newIORef (initNameCache us knownKeyNames)
96 ; return (HscEnv { hsc_mode = ghci_mode,
98 hsc_HPT = emptyHomePackageTable,
100 hsc_NC = nc_var } ) }
103 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
104 -- where templateHaskellNames are defined
105 knownKeyNames = map getName wiredInThings
106 ++ basicKnownKeyNames
108 ++ templateHaskellNames
113 %************************************************************************
115 The main compiler pipeline
117 %************************************************************************
121 -- Compilation failed
124 -- Concluded that it wasn't necessary
125 | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions)
126 ModIface -- new iface (if any compilation was done)
129 | HscRecomp ModDetails -- new details (HomeSymbolTable additions)
131 ModIface -- new iface (if any compilation was done)
132 Bool -- stub_h exists
133 Bool -- stub_c exists
134 (Maybe CompiledByteCode)
136 -- no errors or warnings; the individual passes
137 -- (parse/rename/typecheck) print messages themselves
142 -> ModLocation -- location info
143 -> Bool -- True <=> source unchanged
144 -> Bool -- True <=> have an object file (for msgs only)
145 -> Maybe ModIface -- old interface, if available
148 hscMain hsc_env mod location
149 source_unchanged have_object maybe_old_iface
151 (recomp_reqd, maybe_checked_iface) <-
152 _scc_ "checkOldIface"
153 checkOldIface hsc_env mod
154 (ml_hi_file location)
155 source_unchanged maybe_old_iface;
157 let no_old_iface = not (isJust maybe_checked_iface)
158 what_next | recomp_reqd || no_old_iface = hscRecomp
159 | otherwise = hscNoRecomp
161 ; what_next hsc_env have_object
162 mod location maybe_checked_iface
166 -- hscNoRecomp definitely expects to have the old interface available
167 hscNoRecomp hsc_env have_object
168 mod location (Just old_iface)
169 | hsc_mode hsc_env == OneShot
171 when (verbosity (hsc_dflags hsc_env) > 0) $
172 hPutStrLn stderr "compilation IS NOT required";
173 dumpIfaceStats hsc_env ;
175 let { bomb = panic "hscNoRecomp:OneShot" };
176 return (HscNoRecomp bomb bomb)
180 when (verbosity (hsc_dflags hsc_env) >= 1) $
181 hPutStrLn stderr ("Skipping " ++
182 showModMsg have_object mod location);
184 new_details <- _scc_ "tcRnIface"
185 typecheckIface hsc_env old_iface ;
186 dumpIfaceStats hsc_env ;
188 return (HscNoRecomp new_details old_iface)
191 hscRecomp hsc_env have_object
192 mod location maybe_checked_iface
194 -- what target are we shooting for?
195 ; let one_shot = hsc_mode hsc_env == OneShot
196 ; let dflags = hsc_dflags hsc_env
197 ; let toInterp = dopt_HscLang dflags == HscInterpreted
198 ; let toCore = isJust (ml_hs_file location) &&
199 isExtCoreFilename (fromJust (ml_hs_file location))
201 ; when (not one_shot && verbosity dflags >= 1) $
202 hPutStrLn stderr ("Compiling " ++
203 showModMsg (not toInterp) mod location);
205 ; front_res <- if toCore then
206 hscCoreFrontEnd hsc_env location
208 hscFrontEnd hsc_env location
211 Left flure -> return flure;
212 Right ds_result -> do {
216 -- ; seqList imported_modules (return ())
221 ; flat_result <- _scc_ "Flattening"
222 flatten hsc_env ds_result
225 {- TEMP: need to review space-leak fixing here
226 NB: even the code generator can force one of the
227 thunks for constructor arguments, for newtypes in particular
229 ; let -- Rule-base accumulated from imported packages
230 pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
232 -- In one-shot mode, ZAP the external package state at
233 -- this point, because we aren't going to need it from
234 -- now on. We keep the name cache, however, because
235 -- tidyCore needs it.
237 | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
240 ; pkg_rule_base `seq` pcs_middle `seq` return ()
243 -- alive at this point:
251 ; simpl_result <- _scc_ "Core2Core"
252 core2core hsc_env flat_result
257 ; tidy_result <- _scc_ "CoreTidy"
258 tidyCorePgm hsc_env simpl_result
260 -- Emit external core
261 ; emitExternalCore dflags tidy_result
263 -- Alive at this point:
264 -- tidy_result, pcs_final
268 -- BUILD THE NEW ModIface and ModDetails
269 -- and emit external core if necessary
270 -- This has to happen *after* code gen so that the back-end
271 -- info has been set. Not yet clear if it matters waiting
272 -- until after code output
273 ; new_iface <- _scc_ "MkFinalIface"
274 mkIface hsc_env location
275 maybe_checked_iface tidy_result
278 -- Space leak reduction: throw away the new interface if
279 -- we're in one-shot mode; we won't be needing it any
282 if one_shot then return (error "no final iface")
283 else return new_iface
284 ; let { final_globals | one_shot = Nothing
285 | otherwise = Just $! (mg_rdr_env tidy_result) }
286 ; final_globals `seq` return ()
288 -- Build the final ModDetails (except in one-shot mode, where
289 -- we won't need this information after compilation).
291 if one_shot then return (error "no final details")
292 else return $! ModDetails {
293 md_types = mg_types tidy_result,
294 md_insts = mg_insts tidy_result,
295 md_rules = mg_rules tidy_result }
298 -- CONVERT TO STG and COMPLETE CODE GENERATION
299 ; (stub_h_exists, stub_c_exists, maybe_bcos)
300 <- hscBackEnd dflags tidy_result
302 -- And the answer is ...
303 ; dumpIfaceStats hsc_env
305 ; return (HscRecomp final_details
308 stub_h_exists stub_c_exists
312 hscCoreFrontEnd hsc_env location = do {
316 ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
317 ; case parseCore inp 1 of
318 FailP s -> hPutStrLn stderr s >> return (Left HscFail);
319 OkP rdr_module -> do {
322 -- RENAME and TYPECHECK
324 ; maybe_tc_result <- _scc_ "TypeCheck"
325 tcRnExtCore hsc_env rdr_module
326 ; case maybe_tc_result of {
327 Nothing -> return (Left HscFail);
328 Just mod_guts -> return (Right mod_guts)
329 -- No desugaring to do!
333 hscFrontEnd hsc_env location = do {
337 ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
338 (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
340 ; case maybe_parsed of {
341 Nothing -> return (Left HscFail);
342 Just rdr_module -> do {
345 -- RENAME and TYPECHECK
347 ; maybe_tc_result <- _scc_ "Typecheck-Rename"
348 tcRnModule hsc_env rdr_module
349 ; case maybe_tc_result of {
350 Nothing -> return (Left HscFail);
351 Just tc_result -> do {
356 ; maybe_ds_result <- _scc_ "DeSugar"
357 deSugar hsc_env tc_result
358 ; case maybe_ds_result of
359 Nothing -> return (Left HscFail);
360 Just ds_result -> return (Right ds_result);
365 ModGuts{ -- This is the last use of the ModGuts in a compilation.
366 -- From now on, we just use the bits we need.
367 mg_module = this_mod,
368 mg_binds = core_binds,
370 mg_dir_imps = dir_imps,
371 mg_foreign = foreign_stubs,
372 mg_deps = dependencies } = do {
375 -- PREPARE FOR CODE GENERATION
376 -- Do saturation and convert to A-normal form
377 prepd_binds <- _scc_ "CorePrep"
378 corePrepPgm dflags core_binds type_env;
380 case dopt_HscLang dflags of
381 HscNothing -> return (False, False, Nothing)
385 do ----------------- Generate byte code ------------------
386 comp_bc <- byteCodeGen dflags prepd_binds type_env
388 ------------------ Create f-x-dynamic C-side stuff ---
389 (istub_h_exists, istub_c_exists)
390 <- outputForeignStubs dflags foreign_stubs
392 return ( istub_h_exists, istub_c_exists, Just comp_bc )
394 panic "GHC not compiled with interpreter"
399 ----------------- Convert to STG ------------------
400 (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
401 myCoreToStg dflags this_mod prepd_binds
403 ------------------ Code generation ------------------
404 abstractC <- _scc_ "CodeGen"
405 codeGen dflags this_mod type_env foreign_stubs
406 dir_imps cost_centre_info stg_binds
408 ------------------ Code output -----------------------
409 (stub_h_exists, stub_c_exists)
410 <- codeOutput dflags this_mod foreign_stubs
411 dependencies abstractC
413 return (stub_h_exists, stub_c_exists, Nothing)
417 myParseModule dflags src_filename
418 = do -------------------------- Parser ----------------
419 showPass dflags "Parser"
421 buf <- hGetStringBuffer src_filename
423 let loc = mkSrcLoc (mkFastString src_filename) 1 0
425 case unP parseModule (mkPState buf loc dflags) of {
427 PFailed span err -> do { printError span err ;
430 POk _ rdr_module -> do {
432 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
434 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
435 (ppSourceStats False rdr_module) ;
437 return (Just rdr_module)
438 -- ToDo: free the string buffer later.
442 myCoreToStg dflags this_mod prepd_binds
444 stg_binds <- _scc_ "Core2Stg"
445 coreToStg dflags prepd_binds
447 (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
448 stg2stg dflags this_mod stg_binds
450 return (stg_binds2, cost_centre_info)
454 %************************************************************************
456 \subsection{Compiling a do-statement}
458 %************************************************************************
460 When the UnlinkedBCOExpr is linked you get an HValue of type
462 When you run it you get a list of HValues that should be
463 the same length as the list of names; add them to the ClosureEnv.
465 A naked expression returns a singleton Name [it].
467 What you type The IO [HValue] that hscStmt returns
468 ------------- ------------------------------------
469 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
472 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
475 expr (of IO type) ==> expr >>= \ v -> return [v]
476 [NB: result not printed] bindings: [it]
479 expr (of non-IO type,
480 result showable) ==> let v = expr in print v >> return [v]
483 expr (of non-IO type,
484 result not showable) ==> error
488 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
490 -> InteractiveContext -- Context for compiling
491 -> String -- The statement
492 -> IO (Maybe (InteractiveContext, [Name], HValue))
494 hscStmt hsc_env icontext stmt
495 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
496 ; case maybe_stmt of {
497 Nothing -> return Nothing ;
498 Just parsed_stmt -> do {
500 -- Rename and typecheck it
502 <- tcRnStmt hsc_env icontext parsed_stmt
504 ; case maybe_tc_result of {
505 Nothing -> return Nothing ;
506 Just (new_ic, bound_names, tc_expr) -> do {
508 -- Then desugar, code gen, and link it
509 ; hval <- compileExpr hsc_env iNTERACTIVE
510 (ic_rn_gbl_env new_ic)
514 ; return (Just (new_ic, bound_names, hval))
517 hscTcExpr -- Typecheck an expression (but don't run it)
519 -> InteractiveContext -- Context for compiling
520 -> String -- The expression
523 hscTcExpr hsc_env icontext expr
524 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
525 ; case maybe_stmt of {
526 Just (L _ (ExprStmt expr _))
527 -> tcRnExpr hsc_env icontext expr ;
528 Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
530 Nothing -> return Nothing } }
534 hscParseStmt :: DynFlags -> String -> IO (Maybe (LStmt RdrName))
535 hscParseStmt dflags str
536 = do showPass dflags "Parser"
539 buf <- stringToStringBuffer str
541 let loc = mkSrcLoc FSLIT("<interactive>") 1 0
543 case unP parseStmt (mkPState buf loc dflags) of {
545 PFailed span err -> do { printError span err;
548 -- no stmt: the line consisted of just space or comments
549 POk _ Nothing -> return Nothing;
551 POk _ (Just rdr_stmt) -> do {
553 --ToDo: can't free the string buffer until we've finished this
554 -- compilation sweep and all the identifiers have gone away.
555 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
556 return (Just rdr_stmt)
561 %************************************************************************
563 \subsection{Getting information about an identifer}
565 %************************************************************************
569 hscThing -- like hscStmt, but deals with a single identifier
571 -> InteractiveContext -- Context for compiling
572 -> String -- The identifier
573 -> IO [(IfaceDecl, Fixity)]
575 hscThing hsc_env ic str
576 = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str
577 case maybe_rdr_name of {
578 Nothing -> return [];
579 Just (L _ rdr_name) -> do
581 maybe_tc_result <- tcRnThing hsc_env ic rdr_name
583 case maybe_tc_result of {
584 Nothing -> return [] ;
585 Just things -> return things
588 myParseIdentifier dflags str
589 = do buf <- stringToStringBuffer str
591 let loc = mkSrcLoc FSLIT("<interactive>") 1 0
592 case unP parseIdentifier (mkPState buf loc dflags) of
594 PFailed span err -> do { printError span err;
597 POk _ rdr_name -> return (Just rdr_name)
601 %************************************************************************
603 Desugar, simplify, convert to bytecode, and link an expression
605 %************************************************************************
609 compileExpr :: HscEnv
610 -> Module -> GlobalRdrEnv -> TypeEnv
614 compileExpr hsc_env this_mod rdr_env type_env tc_expr
615 = do { let { dflags = hsc_dflags hsc_env ;
616 lint_on = dopt Opt_DoCoreLinting dflags }
619 ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
622 ; flat_expr <- flattenExpr hsc_env ds_expr
625 ; simpl_expr <- simplifyExpr dflags flat_expr
627 -- Tidy it (temporary, until coreSat does cloning)
628 ; tidy_expr <- tidyCoreExpr simpl_expr
630 -- Prepare for codegen
631 ; prepd_expr <- corePrepExpr dflags tidy_expr
634 -- ToDo: improve SrcLoc
636 case lintUnfolding noSrcLoc [] prepd_expr of
637 Just err -> pprPanic "compileExpr" err
643 ; bcos <- coreExprToBCOs dflags prepd_expr
646 ; hval <- linkExpr hsc_env bcos
654 %************************************************************************
656 Statistics on reading interfaces
658 %************************************************************************
661 dumpIfaceStats :: HscEnv -> IO ()
662 dumpIfaceStats hsc_env
663 = do { eps <- readIORef (hsc_EPS hsc_env)
664 ; dumpIfSet (dump_if_trace || dump_rn_stats)
665 "Interface statistics"
668 dflags = hsc_dflags hsc_env
669 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
670 dump_if_trace = dopt Opt_D_dump_if_trace dflags