2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
5 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
10 hscMain, newHscEnv, hscCmmFile,
14 hscStmt, hscTcExpr, hscKcType,
19 #include "HsVersions.h"
22 import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
23 import Module ( Module )
24 import CodeOutput ( outputForeignStubs )
25 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
26 import Linker ( HValue, linkExpr )
27 import CoreTidy ( tidyExpr )
28 import CorePrep ( corePrepExpr )
29 import Flattening ( flattenExpr )
30 import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
32 import PrelNames ( iNTERACTIVE )
34 import CoreLint ( lintUnfolding )
35 import DsMeta ( templateHaskellNames )
36 import SrcLoc ( noSrcLoc )
37 import VarEnv ( emptyTidyEnv )
41 import Module ( emptyModuleEnv, ModLocation(..) )
42 import RdrName ( GlobalRdrEnv, RdrName )
43 import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
44 import SrcLoc ( Located(..) )
45 import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
47 import Lexer ( P(..), ParseResult(..), mkPState )
48 import SrcLoc ( mkSrcLoc )
49 import TcRnDriver ( tcRnModule, tcRnExtCore )
50 import TcIface ( typecheckIface )
51 import TcRnMonad ( initIfaceCheck, TcGblEnv(..) )
52 import IfaceEnv ( initNameCache )
53 import LoadIface ( ifaceStats, initExternalPackageState )
54 import PrelInfo ( wiredInThings, basicKnownKeyNames )
55 import MkIface ( checkOldIface, mkIface, writeIfaceFile )
57 import Flattening ( flatten )
59 import TidyPgm ( tidyProgram, mkBootModDetails )
60 import CorePrep ( corePrepPgm )
61 import CoreToStg ( coreToStg )
62 import TyCon ( isDataTyCon )
63 import Packages ( mkHomeModules )
64 import Name ( Name, NamedThing(..) )
65 import SimplStg ( stg2stg )
66 import CodeGen ( codeGen )
67 import CmmParse ( parseCmmFile )
68 import CodeOutput ( codeOutput )
73 import UniqSupply ( mkSplitUniqSupply )
76 import HscStats ( ppSourceStats )
78 import MkExternalCore ( emitExternalCore )
80 import ParserCoreUtils
82 import Maybes ( expectJust )
83 import Bag ( unitBag )
85 import Maybe ( isJust )
87 import DATA_IOREF ( newIORef, readIORef )
91 %************************************************************************
95 %************************************************************************
98 newHscEnv :: DynFlags -> IO HscEnv
100 = do { eps_var <- newIORef initExternalPackageState
101 ; us <- mkSplitUniqSupply 'r'
102 ; nc_var <- newIORef (initNameCache us knownKeyNames)
103 ; fc_var <- newIORef emptyModuleEnv
104 ; return (HscEnv { hsc_dflags = dflags,
107 hsc_IC = emptyInteractiveContext,
108 hsc_HPT = emptyHomePackageTable,
111 hsc_FC = fc_var } ) }
114 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
115 -- where templateHaskellNames are defined
116 knownKeyNames = map getName wiredInThings
117 ++ basicKnownKeyNames
119 ++ templateHaskellNames
124 %************************************************************************
126 The main compiler pipeline
128 %************************************************************************
132 -- Compilation failed
135 -- In IDE mode: we just do the static/dynamic checks
138 (Located (HsModule RdrName))
140 (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
142 (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
144 -- Concluded that it wasn't necessary
145 | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions)
146 ModIface -- new iface (if any compilation was done)
149 | HscRecomp ModDetails -- new details (HomeSymbolTable additions)
150 ModIface -- new iface (if any compilation was done)
151 Bool -- stub_h exists
152 Bool -- stub_c exists
153 (Maybe CompiledByteCode)
156 -- What to do when we have compiler error or warning messages
157 type MessageAction = Messages -> IO ()
160 --------------------------------------------------------------
161 -- Exterimental code start.
162 --------------------------------------------------------------
166 | NewHscRecomp Bool -- Has stub files.
167 -- This is a hack. We can't compile C files here
168 -- since it's done in DriverPipeline. For now we
169 -- just return True if we want the caller to compile
172 data InteractiveStatus
173 = InteractiveNoRecomp
174 | InteractiveRecomp Bool -- Same as HscStatus
177 type NoRecomp result = HscEnv -> ModSummary -> Bool -> ModIface -> Maybe (Int,Int) -> IO result
178 type FrontEnd core = HscEnv -> ModSummary -> Maybe (Int,Int) -> IO (Maybe core)
179 type BackEnd core prepCore = HscEnv -> ModSummary -> Maybe ModIface -> core -> IO prepCore
180 type CodeGen prepCore result = HscEnv -> ModSummary -> prepCore -> IO result
182 type Compiler result = HscEnv
184 -> Bool -- True <=> source unchanged
185 -> Bool -- True <=> have an object file (for msgs only)
186 -> Maybe ModIface -- Old interface, if available
187 -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
191 hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required.
193 -> BackEnd core prepCore
194 -> CodeGen prepCore result
196 hscMkCompiler norecomp frontend backend codegen
197 hsc_env mod_summary source_unchanged
198 have_object mbOldIface mbModIndex
199 = do (recomp_reqd, mbCheckedIface)
200 <- {-# SCC "checkOldIface" #-}
201 checkOldIface hsc_env mod_summary
202 source_unchanged mbOldIface
203 case mbCheckedIface of
204 Just iface | not recomp_reqd
205 -> do result <- norecomp hsc_env mod_summary have_object iface mbModIndex
208 -> do mbCore <- frontend hsc_env mod_summary mbModIndex
213 -> do prepCore <- backend hsc_env mod_summary
215 result <- codegen hsc_env mod_summary prepCore
218 -- Compile Haskell, boot and extCore in OneShot mode.
219 hscCompileOneShot :: Compiler HscStatus
220 hscCompileOneShot hsc_env mod_summary =
221 compiler hsc_env mod_summary
222 where mkComp = hscMkCompiler (norecompOneShot NewHscNoRecomp)
224 = case ms_hsc_src mod_summary of
226 -> mkComp hscCoreFrontEnd hscNewBackEnd hscCodeGenOneShot
229 -> mkComp hscFileFrontEnd hscNewBackEnd hscCodeGenOneShot
231 -> mkComp hscFileFrontEnd hscNewBootBackEnd
232 (hscCodeGenConst (NewHscRecomp False))
234 -- Compile Haskell, boot and extCore in --make mode.
235 hscCompileMake :: Compiler (HscStatus, ModIface, ModDetails)
236 hscCompileMake hsc_env mod_summary
237 = compiler hsc_env mod_summary
238 where mkComp = hscMkCompiler norecompMake
240 = case ms_hsc_src mod_summary of
242 -> mkComp hscCoreFrontEnd hscNewBackEnd hscCodeGenMake
244 -> mkComp hscFileFrontEnd hscNewBackEnd hscCodeGenMake
246 -> mkComp hscFileFrontEnd hscNewBootBackEnd hscCodeGenIdentity
248 -- Same as 'hscCompileMake' but don't generate any actual code.
249 hscCompileMakeNothing :: Compiler (HscStatus, ModIface, ModDetails)
250 hscCompileMakeNothing hsc_env mod_summary
251 = compiler hsc_env mod_summary
252 where mkComp = hscMkCompiler norecompMake
253 codeGen = hscCodeGenSimple (\(i, d, g) -> (NewHscRecomp False, i, d))
255 = case ms_hsc_src mod_summary of
257 -> mkComp hscCoreFrontEnd hscNewBackEnd
260 -> mkComp hscFileFrontEnd hscNewBackEnd
263 -> mkComp hscFileFrontEnd hscNewBootBackEnd
266 -- Compile Haskell, extCore to bytecode.
267 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
268 hscCompileInteractive hsc_env mod_summary =
269 hscMkCompiler norecompInteractive frontend hscNewBackEnd hscCodeGenInteractive
271 where frontend = case ms_hsc_src mod_summary of
272 ExtCoreFile -> hscCoreFrontEnd
273 HsSrcFile -> hscFileFrontEnd
274 HsBootFile -> panic bootErrorMsg
275 bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
276 "Use 'hscCompileMake' instead."
278 norecompOneShot :: a -> NoRecomp a
279 norecompOneShot a hsc_env mod_summary
280 have_object old_iface
282 = do compilationProgressMsg (hsc_dflags hsc_env) $
283 "compilation IS NOT required"
284 dumpIfaceStats hsc_env
287 norecompMake :: NoRecomp (HscStatus, ModIface, ModDetails)
288 norecompMake = norecompWorker NewHscNoRecomp
290 norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
291 norecompInteractive = norecompWorker InteractiveNoRecomp
293 norecompWorker :: a -> NoRecomp (a, ModIface, ModDetails)
294 norecompWorker a hsc_env mod_summary have_object
295 old_iface mb_mod_index
296 = do compilationProgressMsg (hsc_dflags hsc_env) $
297 (showModuleIndex mb_mod_index ++
298 "Skipping " ++ showModMsg have_object mod_summary)
299 new_details <- {-# SCC "tcRnIface" #-}
300 initIfaceCheck hsc_env $
301 typecheckIface old_iface
302 dumpIfaceStats hsc_env
303 return (a, old_iface, new_details)
305 hscNewBootBackEnd :: BackEnd ModGuts (HscStatus, ModIface, ModDetails)
306 hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result
307 = do details <- mkBootModDetails hsc_env ds_result
308 (new_iface, no_change)
309 <- {-# SCC "MkFinalIface" #-}
310 mkIface hsc_env maybe_old_iface ds_result details
311 writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
312 -- And the answer is ...
313 dumpIfaceStats hsc_env
314 return (NewHscRecomp False, new_iface, details)
316 hscNewBackEnd :: BackEnd ModGuts (ModIface, ModDetails, CgGuts)
317 hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result
319 -- ; seqList imported_modules (return ())
321 let dflags = hsc_dflags hsc_env
326 ; flat_result <- {-# SCC "Flattening" #-}
327 flatten hsc_env ds_result
330 {- TEMP: need to review space-leak fixing here
331 NB: even the code generator can force one of the
332 thunks for constructor arguments, for newtypes in particular
334 ; let -- Rule-base accumulated from imported packages
335 pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
337 -- In one-shot mode, ZAP the external package state at
338 -- this point, because we aren't going to need it from
339 -- now on. We keep the name cache, however, because
340 -- tidyCore needs it.
342 | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
345 ; pkg_rule_base `seq` pcs_middle `seq` return ()
348 -- alive at this point:
356 ; simpl_result <- {-# SCC "Core2Core" #-}
357 core2core hsc_env flat_result
362 ; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
363 tidyProgram hsc_env simpl_result
365 -- Alive at this point:
366 -- tidy_result, pcs_final
370 -- BUILD THE NEW ModIface and ModDetails
371 -- and emit external core if necessary
372 -- This has to happen *after* code gen so that the back-end
373 -- info has been set. Not yet clear if it matters waiting
374 -- until after code output
375 ; (new_iface, no_change)
376 <- {-# SCC "MkFinalIface" #-}
377 mkIface hsc_env maybe_old_iface simpl_result details
379 ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
381 -- Emit external core
382 ; emitExternalCore dflags cg_guts
385 -- Return the prepared code.
386 ; return (new_iface, details, cg_guts)
389 -- Don't output any code.
390 hscCodeGenNothing :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
391 hscCodeGenNothing hsc_env mod_summary (iface, details, cgguts)
392 = return (NewHscRecomp False, iface, details)
394 -- Generate code and return both the new ModIface and the ModDetails.
395 hscCodeGenMake :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
396 hscCodeGenMake hsc_env mod_summary (iface, details, cgguts)
397 = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
398 return (NewHscRecomp hasStub, iface, details)
400 -- Here we don't need the ModIface and ModDetails anymore.
401 hscCodeGenOneShot :: CodeGen (ModIface, ModDetails, CgGuts) HscStatus
402 hscCodeGenOneShot hsc_env mod_summary (_, _, cgguts)
403 = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
404 return (NewHscRecomp hasStub)
406 hscCodeGenCompile :: CodeGen CgGuts Bool
407 hscCodeGenCompile hsc_env mod_summary cgguts
408 = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
409 -- From now on, we just use the bits we need.
410 cg_module = this_mod,
411 cg_binds = core_binds,
413 cg_dir_imps = dir_imps,
414 cg_foreign = foreign_stubs,
415 cg_home_mods = home_mods,
416 cg_dep_pkgs = dependencies } = cgguts
417 dflags = hsc_dflags hsc_env
418 location = ms_location mod_summary
419 modName = ms_mod mod_summary
420 data_tycons = filter isDataTyCon tycons
421 -- cg_tycons includes newtypes, for the benefit of External Core,
422 -- but we don't generate any code for newtypes
425 -- PREPARE FOR CODE GENERATION
426 -- Do saturation and convert to A-normal form
427 prepd_binds <- {-# SCC "CorePrep" #-}
428 corePrepPgm dflags core_binds data_tycons ;
429 ----------------- Convert to STG ------------------
430 (stg_binds, cost_centre_info)
431 <- {-# SCC "CoreToStg" #-}
432 myCoreToStg dflags home_mods this_mod prepd_binds
433 ------------------ Code generation ------------------
434 abstractC <- {-# SCC "CodeGen" #-}
435 codeGen dflags home_mods this_mod data_tycons
436 foreign_stubs dir_imps cost_centre_info
438 ------------------ Code output -----------------------
439 (stub_h_exists,stub_c_exists)
440 <- codeOutput dflags this_mod location foreign_stubs
441 dependencies abstractC
444 hscCodeGenIdentity :: CodeGen a a
445 hscCodeGenIdentity hsc_env mod_summary a = return a
447 hscCodeGenSimple :: (a -> b) -> CodeGen a b
448 hscCodeGenSimple fn hsc_env mod_summary a = return (fn a)
450 hscCodeGenConst :: b -> CodeGen a b
451 hscCodeGenConst b hsc_env mod_summary a = return b
453 hscCodeGenInteractive :: CodeGen (ModIface, ModDetails, CgGuts)
454 (InteractiveStatus, ModIface, ModDetails)
455 hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts)
457 = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
458 -- From now on, we just use the bits we need.
459 cg_module = this_mod,
460 cg_binds = core_binds,
462 cg_foreign = foreign_stubs,
463 cg_home_mods = home_mods,
464 cg_dep_pkgs = dependencies } = cgguts
465 dflags = hsc_dflags hsc_env
466 location = ms_location mod_summary
467 modName = ms_mod mod_summary
468 data_tycons = filter isDataTyCon tycons
469 -- cg_tycons includes newtypes, for the benefit of External Core,
470 -- but we don't generate any code for newtypes
473 -- PREPARE FOR CODE GENERATION
474 -- Do saturation and convert to A-normal form
475 prepd_binds <- {-# SCC "CorePrep" #-}
476 corePrepPgm dflags core_binds data_tycons ;
477 ----------------- Generate byte code ------------------
478 comp_bc <- byteCodeGen dflags prepd_binds data_tycons
479 ------------------ Create f-x-dynamic C-side stuff ---
480 (istub_h_exists, istub_c_exists)
481 <- outputForeignStubs dflags this_mod location foreign_stubs
482 return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
484 = panic "GHC not compiled with interpreter"
489 --------------------------------------------------------------
490 -- Exterimental code end.
491 --------------------------------------------------------------
493 -- no errors or warnings; the individual passes
494 -- (parse/rename/typecheck) print messages themselves
499 -> Bool -- True <=> source unchanged
500 -> Bool -- True <=> have an object file (for msgs only)
501 -> Maybe ModIface -- Old interface, if available
502 -> Maybe (Int, Int) -- Just (i,n) <=> module i of n (for msgs)
505 hscMain hsc_env mod_summary
506 source_unchanged have_object maybe_old_iface
509 (recomp_reqd, maybe_checked_iface) <-
510 {-# SCC "checkOldIface" #-}
511 checkOldIface hsc_env mod_summary
512 source_unchanged maybe_old_iface;
514 let no_old_iface = not (isJust maybe_checked_iface)
515 what_next | recomp_reqd || no_old_iface = hscRecomp
516 | otherwise = hscNoRecomp
518 ; what_next hsc_env mod_summary have_object
524 ------------------------------
525 hscNoRecomp hsc_env mod_summary
526 have_object (Just old_iface)
528 | isOneShot (ghcMode (hsc_dflags hsc_env))
530 compilationProgressMsg (hsc_dflags hsc_env) $
531 "compilation IS NOT required";
532 dumpIfaceStats hsc_env ;
534 let { bomb = panic "hscNoRecomp:OneShot" };
535 return (HscNoRecomp bomb bomb)
538 = do { compilationProgressMsg (hsc_dflags hsc_env) $
539 (showModuleIndex mb_mod_index ++
540 "Skipping " ++ showModMsg have_object mod_summary)
542 ; new_details <- {-# SCC "tcRnIface" #-}
543 initIfaceCheck hsc_env $
544 typecheckIface old_iface ;
545 ; dumpIfaceStats hsc_env
547 ; return (HscNoRecomp new_details old_iface)
550 hscNoRecomp hsc_env mod_summary
553 = panic "hscNoRecomp" -- hscNoRecomp definitely expects to
554 -- have the old interface available
556 ------------------------------
557 hscRecomp hsc_env mod_summary
558 have_object maybe_old_iface
560 = case ms_hsc_src mod_summary of
562 front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
563 case ghcMode (hsc_dflags hsc_env) of
564 JustTypecheck -> hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
565 _ -> hscBackEnd hsc_env mod_summary maybe_old_iface front_res
568 front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
569 hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
572 front_res <- hscCoreFrontEnd hsc_env mod_summary mb_mod_index
573 hscBackEnd hsc_env mod_summary maybe_old_iface front_res
575 hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do {
579 ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
580 ; case parseCore inp 1 of
581 FailP s -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
582 OkP rdr_module -> do {
585 -- RENAME and TYPECHECK
587 ; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
588 tcRnExtCore hsc_env rdr_module
589 ; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
590 ; case maybe_tc_result of
591 Nothing -> return Nothing
592 Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
596 hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
598 -- DISPLAY PROGRESS MESSAGE
600 ; let dflags = hsc_dflags hsc_env
601 one_shot = isOneShot (ghcMode dflags)
602 toInterp = hscTarget dflags == HscInterpreted
603 ; when (not one_shot) $
604 compilationProgressMsg dflags $
605 (showModuleIndex mb_mod_index ++
606 "Compiling " ++ showModMsg (not toInterp) mod_summary)
611 ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
612 hspp_buf = ms_hspp_buf mod_summary
614 ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
616 ; case maybe_parsed of {
617 Left err -> do { printBagOfErrors dflags (unitBag err)
619 Right rdr_module -> do {
622 -- RENAME and TYPECHECK
624 (tc_msgs, maybe_tc_result)
625 <- {-# SCC "Typecheck-Rename" #-}
626 tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
628 ; printErrorsAndWarnings dflags tc_msgs
629 ; case maybe_tc_result of {
630 Nothing -> return Nothing ;
631 Just tc_result -> do {
636 ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
637 deSugar hsc_env tc_result
638 ; printBagOfWarnings dflags warns
639 ; return maybe_ds_result
642 ------------------------------
644 hscFileCheck :: HscEnv -> ModSummary -> IO HscResult
645 hscFileCheck hsc_env mod_summary = do {
649 ; let dflags = hsc_dflags hsc_env
650 hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
651 hspp_buf = ms_hspp_buf mod_summary
653 ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
655 ; case maybe_parsed of {
656 Left err -> do { printBagOfErrors dflags (unitBag err)
658 Right rdr_module -> do {
661 -- RENAME and TYPECHECK
663 (tc_msgs, maybe_tc_result)
664 <- _scc_ "Typecheck-Rename"
665 tcRnModule hsc_env (ms_hsc_src mod_summary)
666 True{-save renamed syntax-}
669 ; printErrorsAndWarnings dflags tc_msgs
670 ; case maybe_tc_result of {
671 Nothing -> return (HscChecked rdr_module Nothing Nothing);
673 let md = ModDetails {
674 md_types = tcg_type_env tc_result,
675 md_exports = tcg_exports tc_result,
676 md_insts = tcg_insts tc_result,
677 md_rules = [panic "no rules"] }
678 -- Rules are CoreRules, not the
679 -- RuleDecls we get out of the typechecker
680 rnInfo = do decl <- tcg_rn_decls tc_result
681 imports <- tcg_rn_imports tc_result
682 let exports = tcg_rn_exports tc_result
683 return (decl,imports,exports)
684 return (HscChecked rdr_module
686 (Just (tcg_binds tc_result,
687 tcg_rdr_env tc_result,
691 ------------------------------
692 hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
693 -- For hs-boot files, there's no code generation to do
695 hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing
697 hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
698 = do { details <- mkBootModDetails hsc_env ds_result
700 ; (new_iface, no_change)
701 <- {-# SCC "MkFinalIface" #-}
702 mkIface hsc_env maybe_old_iface ds_result details
704 ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
706 -- And the answer is ...
707 ; dumpIfaceStats hsc_env
709 ; return (HscRecomp details new_iface
713 ------------------------------
714 hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
716 hscBackEnd hsc_env mod_summary maybe_old_iface Nothing
719 hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
721 -- ; seqList imported_modules (return ())
723 let one_shot = isOneShot (ghcMode dflags)
724 dflags = hsc_dflags hsc_env
729 ; flat_result <- {-# SCC "Flattening" #-}
730 flatten hsc_env ds_result
733 {- TEMP: need to review space-leak fixing here
734 NB: even the code generator can force one of the
735 thunks for constructor arguments, for newtypes in particular
737 ; let -- Rule-base accumulated from imported packages
738 pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
740 -- In one-shot mode, ZAP the external package state at
741 -- this point, because we aren't going to need it from
742 -- now on. We keep the name cache, however, because
743 -- tidyCore needs it.
745 | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
748 ; pkg_rule_base `seq` pcs_middle `seq` return ()
751 -- alive at this point:
759 ; simpl_result <- {-# SCC "Core2Core" #-}
760 core2core hsc_env flat_result
765 ; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
766 tidyProgram hsc_env simpl_result
768 -- Alive at this point:
769 -- tidy_result, pcs_final
773 -- BUILD THE NEW ModIface and ModDetails
774 -- and emit external core if necessary
775 -- This has to happen *after* code gen so that the back-end
776 -- info has been set. Not yet clear if it matters waiting
777 -- until after code output
778 ; (new_iface, no_change)
779 <- {-# SCC "MkFinalIface" #-}
780 mkIface hsc_env maybe_old_iface simpl_result details
782 ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
784 -- Space leak reduction: throw away the new interface if
785 -- we're in one-shot mode; we won't be needing it any
787 ; final_iface <- if one_shot then return (error "no final iface")
788 else return new_iface
790 -- Build the final ModDetails (except in one-shot mode, where
791 -- we won't need this information after compilation).
792 ; final_details <- if one_shot then return (error "no final details")
793 else return $! details
795 -- Emit external core
796 ; emitExternalCore dflags cg_guts
799 -- CONVERT TO STG and COMPLETE CODE GENERATION
800 ; (stub_h_exists, stub_c_exists, maybe_bcos)
801 <- hscCodeGen dflags (ms_location mod_summary) cg_guts
803 -- And the answer is ...
804 ; dumpIfaceStats hsc_env
806 ; return (HscRecomp final_details
808 stub_h_exists stub_c_exists
814 hscCodeGen dflags location
815 CgGuts{ -- This is the last use of the ModGuts in a compilation.
816 -- From now on, we just use the bits we need.
817 cg_module = this_mod,
818 cg_binds = core_binds,
820 cg_dir_imps = dir_imps,
821 cg_foreign = foreign_stubs,
822 cg_home_mods = home_mods,
823 cg_dep_pkgs = dependencies } = do {
825 let { data_tycons = filter isDataTyCon tycons } ;
826 -- cg_tycons includes newtypes, for the benefit of External Core,
827 -- but we don't generate any code for newtypes
830 -- PREPARE FOR CODE GENERATION
831 -- Do saturation and convert to A-normal form
832 prepd_binds <- {-# SCC "CorePrep" #-}
833 corePrepPgm dflags core_binds data_tycons ;
835 case hscTarget dflags of
836 HscNothing -> return (False, False, Nothing)
840 do ----------------- Generate byte code ------------------
841 comp_bc <- byteCodeGen dflags prepd_binds data_tycons
843 ------------------ Create f-x-dynamic C-side stuff ---
844 (istub_h_exists, istub_c_exists)
845 <- outputForeignStubs dflags this_mod location foreign_stubs
847 return ( istub_h_exists, istub_c_exists, Just comp_bc )
849 panic "GHC not compiled with interpreter"
854 ----------------- Convert to STG ------------------
855 (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-}
856 myCoreToStg dflags home_mods this_mod prepd_binds
858 ------------------ Code generation ------------------
859 abstractC <- {-# SCC "CodeGen" #-}
860 codeGen dflags home_mods this_mod data_tycons
861 foreign_stubs dir_imps cost_centre_info
864 ------------------ Code output -----------------------
865 (stub_h_exists, stub_c_exists)
866 <- codeOutput dflags this_mod location foreign_stubs
867 dependencies abstractC
869 return (stub_h_exists, stub_c_exists, Nothing)
873 hscCmmFile :: DynFlags -> FilePath -> IO Bool
874 hscCmmFile dflags filename = do
875 maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
877 Nothing -> return False
879 codeOutput dflags no_mod no_loc NoStubs [] [cmm]
882 no_mod = panic "hscCmmFile: no_mod"
883 no_loc = ModLocation{ ml_hs_file = Just filename,
884 ml_hi_file = panic "hscCmmFile: no hi file",
885 ml_obj_file = panic "hscCmmFile: no obj file" }
888 myParseModule dflags src_filename maybe_src_buf
889 = -------------------------- Parser ----------------
890 showPass dflags "Parser" >>
891 {-# SCC "Parser" #-} do
893 -- sometimes we already have the buffer in memory, perhaps
894 -- because we needed to parse the imports out of it, or get the
896 buf <- case maybe_src_buf of
898 Nothing -> hGetStringBuffer src_filename
900 let loc = mkSrcLoc (mkFastString src_filename) 1 0
902 case unP parseModule (mkPState buf loc dflags) of {
904 PFailed span err -> return (Left (mkPlainErrMsg span err));
906 POk _ rdr_module -> do {
908 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
910 dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
911 (ppSourceStats False rdr_module) ;
913 return (Right rdr_module)
914 -- ToDo: free the string buffer later.
918 myCoreToStg dflags home_mods this_mod prepd_binds
920 stg_binds <- {-# SCC "Core2Stg" #-}
921 coreToStg home_mods prepd_binds
923 (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
924 stg2stg dflags home_mods this_mod stg_binds
926 return (stg_binds2, cost_centre_info)
930 %************************************************************************
932 \subsection{Compiling a do-statement}
934 %************************************************************************
936 When the UnlinkedBCOExpr is linked you get an HValue of type
938 When you run it you get a list of HValues that should be
939 the same length as the list of names; add them to the ClosureEnv.
941 A naked expression returns a singleton Name [it].
943 What you type The IO [HValue] that hscStmt returns
944 ------------- ------------------------------------
945 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
948 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
951 expr (of IO type) ==> expr >>= \ v -> return [v]
952 [NB: result not printed] bindings: [it]
955 expr (of non-IO type,
956 result showable) ==> let v = expr in print v >> return [v]
959 expr (of non-IO type,
960 result not showable) ==> error
964 hscStmt -- Compile a stmt all the way to an HValue, but don't run it
966 -> String -- The statement
967 -> IO (Maybe (HscEnv, [Name], HValue))
970 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
971 ; case maybe_stmt of {
972 Nothing -> return Nothing ; -- Parse error
973 Just Nothing -> return Nothing ; -- Empty line
974 Just (Just parsed_stmt) -> do { -- The real stuff
976 -- Rename and typecheck it
977 let icontext = hsc_IC hsc_env
978 ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
980 ; case maybe_tc_result of {
981 Nothing -> return Nothing ;
982 Just (new_ic, bound_names, tc_expr) -> do {
984 -- Then desugar, code gen, and link it
985 ; hval <- compileExpr hsc_env iNTERACTIVE
986 (ic_rn_gbl_env new_ic)
990 ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
993 hscTcExpr -- Typecheck an expression (but don't run it)
995 -> String -- The expression
998 hscTcExpr hsc_env expr
999 = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
1000 ; let icontext = hsc_IC hsc_env
1001 ; case maybe_stmt of {
1002 Nothing -> return Nothing ; -- Parse error
1003 Just (Just (L _ (ExprStmt expr _ _)))
1004 -> tcRnExpr hsc_env icontext expr ;
1005 Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
1009 hscKcType -- Find the kind of a type
1011 -> String -- The type
1014 hscKcType hsc_env str
1015 = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
1016 ; let icontext = hsc_IC hsc_env
1017 ; case maybe_type of {
1018 Just ty -> tcRnType hsc_env icontext ty ;
1019 Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
1021 Nothing -> return Nothing } }
1027 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
1028 hscParseStmt = hscParseThing parseStmt
1030 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
1031 hscParseType = hscParseThing parseType
1034 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
1035 hscParseIdentifier = hscParseThing parseIdentifier
1037 hscParseThing :: Outputable thing
1039 -> DynFlags -> String
1041 -- Nothing => Parse error (message already printed)
1042 -- Just x => success
1043 hscParseThing parser dflags str
1044 = showPass dflags "Parser" >>
1045 {-# SCC "Parser" #-} do
1047 buf <- stringToStringBuffer str
1049 let loc = mkSrcLoc FSLIT("<interactive>") 1 0
1051 case unP parser (mkPState buf loc dflags) of {
1053 PFailed span err -> do { printError span err;
1058 --ToDo: can't free the string buffer until we've finished this
1059 -- compilation sweep and all the identifiers have gone away.
1060 dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
1065 %************************************************************************
1067 Desugar, simplify, convert to bytecode, and link an expression
1069 %************************************************************************
1073 compileExpr :: HscEnv
1074 -> Module -> GlobalRdrEnv -> TypeEnv
1078 compileExpr hsc_env this_mod rdr_env type_env tc_expr
1079 = do { let { dflags = hsc_dflags hsc_env ;
1080 lint_on = dopt Opt_DoCoreLinting dflags }
1083 ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
1086 ; flat_expr <- flattenExpr hsc_env ds_expr
1089 ; simpl_expr <- simplifyExpr dflags flat_expr
1091 -- Tidy it (temporary, until coreSat does cloning)
1092 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1094 -- Prepare for codegen
1095 ; prepd_expr <- corePrepExpr dflags tidy_expr
1097 -- Lint if necessary
1098 -- ToDo: improve SrcLoc
1100 case lintUnfolding noSrcLoc [] prepd_expr of
1101 Just err -> pprPanic "compileExpr" err
1102 Nothing -> return ()
1107 ; bcos <- coreExprToBCOs dflags prepd_expr
1110 ; hval <- linkExpr hsc_env bcos
1118 %************************************************************************
1120 Statistics on reading interfaces
1122 %************************************************************************
1125 dumpIfaceStats :: HscEnv -> IO ()
1126 dumpIfaceStats hsc_env
1127 = do { eps <- readIORef (hsc_EPS hsc_env)
1128 ; dumpIfSet (dump_if_trace || dump_rn_stats)
1129 "Interface statistics"
1132 dflags = hsc_dflags hsc_env
1133 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1134 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1137 %************************************************************************
1139 Progress Messages: Module i of n
1141 %************************************************************************
1144 showModuleIndex Nothing = ""
1145 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1149 padded = replicate (length n_str - length i_str) ' ' ++ i_str