X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=72abafb6b8de36fd65b7194ffc5331a03a420752;hb=241306953f42fa067a9b503ea1f418e75c32c484;hp=f0fd95da23a1516537390eb89895923443b09aaf;hpb=d31dfb32ea936c22628b508c28a36c12e631430a;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index f0fd95d..72abafb 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -5,6 +5,13 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module HscMain ( newHscEnv, hscCmmFile , hscFileCheck @@ -53,7 +60,7 @@ import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, HaddockModInfo ) import CoreSyn import SrcLoc ( Located(..) ) -import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) +import StringBuffer import Parser import Lexer import SrcLoc ( mkSrcLoc ) @@ -203,6 +210,7 @@ data InteractiveStatus = InteractiveNoRecomp | InteractiveRecomp Bool -- Same as HscStatus CompiledByteCode + ModBreaks -- I want Control.Monad.State! --Lemmih 03/07/2006 @@ -239,7 +247,6 @@ liftIO ioA = Comp $ \s -> do a <- ioA return (a,s) type NoRecomp result = ModIface -> Comp result -type FrontEnd core = Comp (Maybe core) -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. @@ -255,8 +262,8 @@ type Compiler result = HscEnv -- then combines the FrontEnd and BackEnd to a working compiler. hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required. -> (Maybe (Int,Int) -> Bool -> Comp ()) - -> FrontEnd core - -> (core -> Comp result) -- Backend. + -> Comp (Maybe ModGuts) -- Front end + -> (ModGuts -> Comp result) -- Backend. -> Compiler result hscMkCompiler norecomp messenger frontend backend hsc_env mod_summary source_unchanged @@ -289,67 +296,52 @@ hscMkCompiler norecomp messenger frontend backend -- Compilers -------------------------------------------------------------- --- 1 2 3 4 5 6 7 8 9 -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False)) +hscCompileOneShot + = hscCompiler norecompOneShot oneShotMsg backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (HscRecomp False) -- Compile Haskell, boot and extCore in batch mode. hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing - --- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch. -hscCompileHardCode :: NoRecomp result -- No recomp necessary - -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback - -> ((ModIface, ModDetails, CgGuts) -> Comp result) -- Compile normal file - -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file - -> Compiler result -hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary = - compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecomp msg - -- How to compile nonBoot files. - nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= compNormal - -- How to compile boot files. - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd nonBootComp - HsSrcFile - -> mkComp hscFileFrontEnd nonBootComp - HsBootFile - -> mkComp hscFileFrontEnd bootComp +hscCompileBatch + = hscCompiler norecompBatch batchMsg backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing -- Type-check Haskell, boot and extCore. -- Does it make sense to compile extCore to nothing? hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileNothing hsc_env mod_summary - = compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompBatch batchMsg - pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd pipeline - HsSrcFile - -> mkComp hscFileFrontEnd pipeline - HsBootFile - -> mkComp hscFileFrontEnd pipeline +hscCompileNothing + = hscCompiler norecompBatch batchMsg backend backend + where + backend inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing -- Compile Haskell, extCore to bytecode. hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) -hscCompileInteractive hsc_env mod_summary = - hscMkCompiler norecompInteractive batchMsg - frontend backend - hsc_env mod_summary - where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive - frontend = case ms_hsc_src mod_summary of - ExtCoreFile -> hscCoreFrontEnd - HsSrcFile -> hscFileFrontEnd - HsBootFile -> panic bootErrorMsg - bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++ - "Use 'hscCompileBatch' instead." +hscCompileInteractive + = hscCompiler norecompInteractive batchMsg backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive + boot_backend = panic "hscCompileInteractive: can't do boot files here" + +hscCompiler + :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> (ModGuts -> Comp result) -- Compile normal file + -> (ModGuts -> Comp result) -- Compile boot file + -> Compiler result +hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary = + hscMkCompiler norecomp msg frontend backend hsc_env mod_summary + where + (frontend,backend) + = case ms_hsc_src mod_summary of + ExtCoreFile -> (hscCoreFrontEnd, nonBootComp) + HsSrcFile -> (hscFileFrontEnd, nonBootComp) + HsBootFile -> (hscFileFrontEnd, bootComp) -------------------------------------------------------------- -- NoRecomp handlers @@ -410,7 +402,7 @@ batchMsg mb_mod_index recomp -- FrontEnds -------------------------------------------------------------- -hscCoreFrontEnd :: FrontEnd ModGuts +hscCoreFrontEnd :: Comp (Maybe ModGuts) hscCoreFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -435,7 +427,7 @@ hscCoreFrontEnd = Just mod_guts -> return (Just mod_guts) -- No desugaring to do! -hscFileFrontEnd :: FrontEnd ModGuts +hscFileFrontEnd :: Comp (Maybe ModGuts) hscFileFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -476,13 +468,11 @@ hscSimplify :: ModGuts -> Comp ModGuts hscSimplify ds_result = do hsc_env <- gets compHscEnv liftIO $ do - flat_result <- {-# SCC "Flattening" #-} - flatten hsc_env ds_result ------------------- -- SIMPLIFY ------------------- simpl_result <- {-# SCC "Core2Core" #-} - core2core hsc_env flat_result + core2core hsc_env ds_result return simpl_result -------------------------------------------------------------- @@ -603,10 +593,10 @@ hscCompile cgguts ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - foreign_stubs dir_imps cost_centre_info + dir_imps cost_centre_info stg_binds hpc_info ------------------ Convert to CPS -------------------- - --continuationC <- cmmCPS dflags abstractC + --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm continuationC <- cmmToRawCmm abstractC ------------------ Code output ----------------------- (stub_h_exists,stub_c_exists) @@ -629,7 +619,8 @@ hscInteractive (iface, details, cgguts) cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_foreign = foreign_stubs } = cgguts + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary data_tycons = filter isDataTyCon tycons @@ -642,11 +633,11 @@ hscInteractive (iface, details, cgguts) prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details) + comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (InteractiveRecomp istub_c_exists comp_bc, iface, details) + return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details) #else = panic "GHC not compiled with interpreter" #endif @@ -673,7 +664,7 @@ hscFileCheck hsc_env mod_summary compileToCore = do { -- RENAME and TYPECHECK ------------------- (tc_msgs, maybe_tc_result) - <- _scc_ "Typecheck-Rename" + <- {-# SCC "Typecheck-Rename" #-} tcRnModule hsc_env (ms_hsc_src mod_summary) True{-save renamed syntax-} rdr_module @@ -688,12 +679,10 @@ hscFileCheck hsc_env mod_summary compileToCore = do { md_exports = tcg_exports tc_result, md_insts = tcg_insts tc_result, md_fam_insts = tcg_fam_insts tc_result, - md_modBreaks = emptyModBreaks, md_rules = [panic "no rules"], -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker - md_vect_info = - panic "HscMain.hscFileCheck: no VectInfo" + md_vect_info = noVectInfo -- VectInfo is added by the Core -- vectorisation pass } @@ -723,7 +712,7 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - --continuationC <- cmmCPS dflags [cmm] + --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm continuationC <- cmmToRawCmm [cmm] codeOutput dflags no_mod no_loc NoStubs [] continuationC return True @@ -734,6 +723,8 @@ hscCmmFile dflags filename = do ml_obj_file = panic "hscCmmFile: no obj file" } +myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) myParseModule dflags src_filename maybe_src_buf = -------------------------- Parser ---------------- showPass dflags "Parser" >>