X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=2b9ae6c09f28d0fc7f382afd330c1b8f05999647;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=187f6442f38d2623b7bfcfb3c34f19c8443cea4a;hpb=2ba65cebbeade2f35d60fd3b58a7b5650bcb3b8e;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 187f644..2b9ae6c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -38,7 +38,7 @@ import VarEnv ( emptyTidyEnv ) #endif import Var ( Id ) -import Module ( emptyModuleEnv ) +import Module ( emptyModuleEnv, ModLocation(..) ) import RdrName ( GlobalRdrEnv, RdrName ) import HsSyn ( HsModule, LHsBinds, HsGroup ) import SrcLoc ( Located(..) ) @@ -79,7 +79,7 @@ import ParserCore import ParserCoreUtils import FastString import Maybes ( expectJust ) -import Bag ( unitBag, emptyBag ) +import Bag ( unitBag ) import Monad ( when ) import Maybe ( isJust ) import IO @@ -157,7 +157,6 @@ type MessageAction = Messages -> IO () hscMain :: HscEnv - -> MessageAction -- What to do with errors/warnings -> ModSummary -> Bool -- True <=> source unchanged -> Bool -- True <=> have an object file (for msgs only) @@ -165,7 +164,7 @@ hscMain -> Maybe (Int, Int) -- Just (i,n) <=> module i of n (for msgs) -> IO HscResult -hscMain hsc_env msg_act mod_summary +hscMain hsc_env mod_summary source_unchanged have_object maybe_old_iface mb_mod_index = do { @@ -178,14 +177,14 @@ hscMain hsc_env msg_act mod_summary what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env msg_act mod_summary have_object + ; what_next hsc_env mod_summary have_object maybe_checked_iface mb_mod_index } ------------------------------ -hscNoRecomp hsc_env msg_act mod_summary +hscNoRecomp hsc_env mod_summary have_object (Just old_iface) mb_mod_index | isOneShot (ghcMode (hsc_dflags hsc_env)) @@ -210,36 +209,38 @@ hscNoRecomp hsc_env msg_act mod_summary ; return (HscNoRecomp new_details old_iface) } -hscNoRecomp hsc_env msg_act mod_summary +hscNoRecomp hsc_env mod_summary have_object Nothing mb_mod_index = panic "hscNoRecomp" -- hscNoRecomp definitely expects to -- have the old interface available ------------------------------ -hscRecomp hsc_env msg_act mod_summary +hscRecomp hsc_env mod_summary have_object maybe_old_iface mb_mod_index = case ms_hsc_src mod_summary of - HsSrcFile -> do - front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index - hscBackEnd hsc_env mod_summary maybe_old_iface front_res + HsSrcFile -> do + front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index + case ghcMode (hsc_dflags hsc_env) of + JustTypecheck -> hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res + _ -> hscBackEnd hsc_env mod_summary maybe_old_iface front_res HsBootFile -> do - front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index + front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res ExtCoreFile -> do - front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary + front_res <- hscCoreFrontEnd hsc_env mod_summary hscBackEnd hsc_env mod_summary maybe_old_iface front_res -hscCoreFrontEnd hsc_env msg_act mod_summary = do { +hscCoreFrontEnd hsc_env mod_summary = do { ------------------- -- PARSE ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary)) ; case parseCore inp 1 of - FailP s -> putMsg s{-ToDo: wrong-} >> return Nothing + FailP s -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing OkP rdr_module -> do { ------------------- @@ -247,20 +248,20 @@ hscCoreFrontEnd hsc_env msg_act mod_summary = do { ------------------- ; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} tcRnExtCore hsc_env rdr_module - ; msg_act tc_msgs + ; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs ; case maybe_tc_result of Nothing -> return Nothing Just mod_guts -> return (Just mod_guts) -- No desugaring to do! }} -hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do { +hscFileFrontEnd hsc_env mod_summary mb_mod_index = do { ------------------- -- DISPLAY PROGRESS MESSAGE ------------------- - let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env)) - ; let dflags = hsc_dflags hsc_env - ; let toInterp = hscTarget dflags == HscInterpreted + ; let dflags = hsc_dflags hsc_env + one_shot = isOneShot (ghcMode dflags) + toInterp = hscTarget dflags == HscInterpreted ; when (not one_shot) $ compilationProgressMsg dflags $ (showModuleIndex mb_mod_index ++ @@ -272,10 +273,10 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do { ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) hspp_buf = ms_hspp_buf mod_summary - ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf + ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf ; case maybe_parsed of { - Left err -> do { msg_act (unitBag err, emptyBag) + Left err -> do { printBagOfErrors dflags (unitBag err) ; return Nothing } ; Right rdr_module -> do { @@ -286,7 +287,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do { <- {-# SCC "Typecheck-Rename" #-} tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - ; msg_act tc_msgs + ; printErrorsAndWarnings dflags tc_msgs ; case maybe_tc_result of { Nothing -> return Nothing ; Just tc_result -> do { @@ -296,24 +297,25 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do { ------------------- ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} deSugar hsc_env tc_result - ; msg_act (warns, emptyBag) + ; printBagOfWarnings dflags warns ; return maybe_ds_result }}}}} ------------------------------ -hscFileCheck :: HscEnv -> MessageAction -> ModSummary -> IO HscResult -hscFileCheck hsc_env msg_act mod_summary = do { +hscFileCheck :: HscEnv -> ModSummary -> IO HscResult +hscFileCheck hsc_env mod_summary = do { ------------------- -- PARSE ------------------- - ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) + ; let dflags = hsc_dflags hsc_env + hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) hspp_buf = ms_hspp_buf mod_summary - ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf + ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf ; case maybe_parsed of { - Left err -> do { msg_act (unitBag err, emptyBag) + Left err -> do { printBagOfErrors dflags (unitBag err) ; return HscFail } ; Right rdr_module -> do { @@ -326,7 +328,7 @@ hscFileCheck hsc_env msg_act mod_summary = do { True{-save renamed syntax-} rdr_module - ; msg_act tc_msgs + ; printErrorsAndWarnings dflags tc_msgs ; case maybe_tc_result of { Nothing -> return (HscChecked rdr_module Nothing Nothing); Just tc_result -> do @@ -454,7 +456,7 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ; (stub_h_exists, stub_c_exists, maybe_bcos) - <- hscCodeGen dflags cg_guts + <- hscCodeGen dflags (ms_location mod_summary) cg_guts -- And the answer is ... ; dumpIfaceStats hsc_env @@ -467,7 +469,7 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) -hscCodeGen dflags +hscCodeGen dflags location CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -498,7 +500,7 @@ hscCodeGen dflags ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags foreign_stubs + <- outputForeignStubs dflags this_mod location foreign_stubs return ( istub_h_exists, istub_c_exists, Just comp_bc ) #else @@ -519,7 +521,7 @@ hscCodeGen dflags ------------------ Code output ----------------------- (stub_h_exists, stub_c_exists) - <- codeOutput dflags this_mod foreign_stubs + <- codeOutput dflags this_mod location foreign_stubs dependencies abstractC return (stub_h_exists, stub_c_exists, Nothing) @@ -532,10 +534,13 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - codeOutput dflags no_mod NoStubs [] [cmm] + codeOutput dflags no_mod no_loc NoStubs [] [cmm] return True where no_mod = panic "hscCmmFile: no_mod" + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCmmFile: no hi file", + ml_obj_file = panic "hscCmmFile: no obj file" } myParseModule dflags src_filename maybe_src_buf @@ -655,7 +660,7 @@ hscTcExpr hsc_env expr Nothing -> return Nothing ; -- Parse error Just (Just (L _ (ExprStmt expr _ _))) -> tcRnExpr hsc_env icontext expr ; - Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ; + Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; return Nothing } ; } } @@ -669,7 +674,7 @@ hscKcType hsc_env str ; let icontext = hsc_IC hsc_env ; case maybe_type of { Just ty -> tcRnType hsc_env icontext ty ; - Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ; + Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ; return Nothing } ; Nothing -> return Nothing } } #endif