X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=b174e5e419b37854a69c0349dd48c63c8902b6a0;hb=de1d4a16d94fa13e9d40a1ac755eae6249595e66;hp=5267fbae58305e14d4136337724366e6da106f20;hpb=10fcd78ccde892feccda3f5eacd221c1de75feea;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 5267fba..b174e5e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -5,7 +5,7 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( HscResult(..), hscMain, +module HscMain ( HscResult(..), hscMain, #ifdef GHCI hscStmt, hscThing, hscModuleContents, #endif @@ -16,9 +16,9 @@ module HscMain ( HscResult(..), hscMain, #ifdef GHCI import Interpreter import ByteCodeGen ( byteCodeGen ) -import CoreTidy ( tidyCoreExpr ) +import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import Rename ( renameStmt, renameRdrName, slurpIface ) +import Rename ( renameStmt, renameRdrName, slurpIface ) import RdrName ( rdrNameOcc, setRdrNameOcc ) import RdrHsSyn ( RdrNameStmt ) import OccName ( dataName, tcClsName, @@ -26,13 +26,12 @@ import OccName ( dataName, tcClsName, import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) -import Name ( isLocalName ) +import Name ( isInternalName ) import NameEnv ( lookupNameEnv ) import Module ( lookupModuleEnv ) import RdrName ( rdrEnvElts ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) -import FastString ( mkFastString ) import Maybes ( catMaybes ) import List ( nub ) @@ -45,14 +44,15 @@ import Id ( idName ) import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) import StringBuffer ( hGetStringBuffer, freeStringBuffer ) import Parser -import Lex ( PState(..), ParseResult(..), ExtFlags(..), mkPState ) +import Lex ( ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) import Finder ( findModule ) -import Rename ( checkOldIface, renameModule, closeIfaceDecls ) +import Rename ( checkOldIface, renameModule, renameExtCore, + closeIfaceDecls, RnResult(..) ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelRules ( builtinRules ) -import PrelNames ( knownKeyNames ) +import PrelNames ( knownKeyNames, gHC_PRIM_Name ) import MkIface ( mkFinalIface ) import TcModule import InstEnv ( emptyInstEnv ) @@ -60,19 +60,19 @@ import Desugar import Flattening ( flatten, flattenExpr ) import SimplCore import CoreUtils ( coreBindsSize ) -import CoreTidy ( tidyCorePgm ) +import TidyPgm ( tidyCorePgm ) import CorePrep ( corePrepPgm ) import StgSyn import CoreToStg ( coreToStg ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) -import CodeOutput ( codeOutput ) +import CodeOutput ( codeOutput, outputForeignStubs ) import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import DriverState ( v_HCHeader ) +import DriverPhases ( isExtCore_file ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) -import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( consBag, emptyBag ) @@ -81,9 +81,12 @@ import HscStats ( ppSourceStats ) import HscTypes import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) -import Name ( Name, nameModule, nameOccName, getName, isGlobalName ) +import Name ( Name, nameModule, nameOccName, getName ) import NameEnv ( emptyNameEnv, mkNameEnv ) import Module ( Module ) +import FastString +import Maybes ( expectJust ) +import Util ( seqList ) import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) @@ -93,6 +96,9 @@ import Maybe ( isJust, fromJust ) import IO import MkExternalCore ( emitExternalCore ) +import ParserCore +import ParserCoreUtils + \end{code} @@ -202,49 +208,36 @@ hscRecomp ghci_mode dflags have_object mod location maybe_checked_iface hst hit pcs_ch = do { -- what target are we shooting for? - ; let toInterp = dopt_HscLang dflags == HscInterpreted + ; let toInterp = dopt_HscLang dflags == HscInterpreted ; let toNothing = dopt_HscLang dflags == HscNothing + ; let toCore = isJust (ml_hs_file location) && + isExtCore_file (fromJust (ml_hs_file location)) ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ showModMsg (not toInterp) mod location); - - ------------------- - -- PARSE - ------------------- - ; maybe_parsed <- myParseModule dflags - (unJust "hscRecomp:hspp" (ml_hspp_file location)) - ; case maybe_parsed of { - Nothing -> return (HscFail pcs_ch); - Just rdr_module -> do { - ; let this_mod = mkHomeModule (hsModuleName rdr_module) - - ------------------- - -- RENAME - ------------------- - ; (pcs_rn, print_unqual, maybe_rn_result) - <- _scc_ "Rename" - renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module - ; case maybe_rn_result of { - Nothing -> return (HscFail pcs_ch); - Just (dont_discard, new_iface, rn_result) -> do { - - ------------------- - -- TYPECHECK - ------------------- - ; maybe_tc_result - <- _scc_ "TypeCheck" - typecheckModule dflags pcs_rn hst print_unqual rn_result - ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_ch); - Just (pcs_tc, tc_result) -> do { - - ------------------- - -- DESUGAR - ------------------- - ; (ds_details, foreign_stuff) - <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqual tc_result + + ; front_res <- + (if toCore then hscCoreFrontEnd else hscFrontEnd) + ghci_mode dflags location hst hit pcs_ch + ; case front_res of + Left flure -> return flure; + Right (this_mod, rdr_module, + dont_discard, new_iface, + pcs_tc, ds_details, foreign_stuff) -> do { + + let { + imported_module_names = + filter (/= gHC_PRIM_Name) $ + map ideclName (hsModuleImports rdr_module); + + imported_modules = + map (moduleNameToModule hit (pcs_PIT pcs_tc)) + imported_module_names; + } + + -- force this out now, so we don't keep a hold of rdr_module or pcs_tc + ; seqList imported_modules (return ()) ------------------- -- FLATTENING @@ -268,11 +261,20 @@ hscRecomp ghci_mode dflags have_object pcs_rules = rules } else return pcs_tc +-- Should we remove bits of flat_details at this point? +-- ; flat_details <- case flat_details of +-- ModDetails { md_binds = binds } -> +-- return ModDetails { md_binds = binds, +-- md_rules = [], +-- md_types = emptyTypeEnv, +-- md_insts = [] } + -- alive at this point: -- pcs_middle -- foreign_stuff - -- ds_details - -- new_iface + -- flat_details + -- imported_modules (seq'd) + -- new_iface ------------------- -- SIMPLIFY @@ -327,11 +329,6 @@ hscRecomp ghci_mode dflags have_object local_tycons = typeEnvTyCons env_tc local_classes = typeEnvClasses env_tc - imported_module_names = map ideclName (hsModuleImports rdr_module) - - mod_name_to_Module nm - = do m <- findModule nm ; return (fst (fromJust m)) - (h_code, c_code, headers, fe_binders) = foreign_stuff -- turn the list of headers requested in foreign import @@ -340,7 +337,7 @@ hscRecomp ghci_mode dflags have_object -- foreign_headers = unlines - . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"") + . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"") . reverse $ headers @@ -350,8 +347,6 @@ hscRecomp ghci_mode dflags have_object ; fhdrs <- readIORef v_HCHeader ; writeIORef v_HCHeader (fhdrs ++ foreign_headers) - ; imported_modules <- mapM mod_name_to_Module imported_module_names - ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface ) <- if toInterp #ifdef GHCI @@ -368,7 +363,12 @@ hscRecomp ghci_mode dflags have_object mkFinalIface ghci_mode dflags location maybe_checked_iface new_iface tidy_details - return ( False, False, Just (bcos,itbl_env), final_iface ) + ------------------ Create f-x-dynamic C-side stuff --- + (istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags c_code h_code + + return ( istub_h_exists, istub_c_exists, + Just (bcos,itbl_env), final_iface ) #else then error "GHC not compiled with interpreter" #endif @@ -410,18 +410,99 @@ hscRecomp ghci_mode dflags have_object final_iface stub_h_exists stub_c_exists maybe_bcos) - }}}}}}} + }} + +hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do { + ------------------- + -- PARSE + ------------------- + ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) + ; case parseCore inp 1 of + FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); + OkP rdr_module -> do { + ; let this_mod = mkHomeModule (hsModuleName rdr_module) + + ------------------- + -- RENAME + ------------------- + ; (pcs_rn, print_unqual, maybe_rn_result) + <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module + ; case maybe_rn_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (dont_discard, new_iface, rn_decls) -> do { + + ------------------- + -- TYPECHECK + ------------------- + ; maybe_tc_result + <- _scc_ "TypeCheck" + typecheckCoreModule dflags pcs_rn hst new_iface rn_decls + ; case maybe_tc_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (pcs_tc, tc_result) -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (ds_details, foreign_stuff) <- deSugarCore tc_result + ; return (Right (this_mod, rdr_module, dont_discard, new_iface, + pcs_tc, ds_details, foreign_stuff)) + }}}}}} + + +hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do { + ------------------- + -- PARSE + ------------------- + ; maybe_parsed <- myParseModule dflags + (expectJust "hscRecomp:hspp" (ml_hspp_file location)) + ; case maybe_parsed of { + Nothing -> return (Left (HscFail pcs_ch)); + Just rdr_module -> do { + ; let this_mod = mkHomeModule (hsModuleName rdr_module) + + ------------------- + -- RENAME + ------------------- + ; (pcs_rn, print_unqual, maybe_rn_result) + <- _scc_ "Rename" + renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module + ; case maybe_rn_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (dont_discard, new_iface, rn_result) -> do { + + ------------------- + -- TYPECHECK + ------------------- + ; maybe_tc_result + <- _scc_ "TypeCheck" + typecheckModule dflags pcs_rn hst print_unqual rn_result + ; case maybe_tc_result of { + Nothing -> return (Left (HscFail pcs_ch)); + Just (pcs_tc, tc_result) -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (ds_details, foreign_stuff) + <- _scc_ "DeSugar" + deSugar dflags pcs_tc hst this_mod print_unqual tc_result + ; return (Right (this_mod, rdr_module, dont_discard, new_iface, + pcs_tc, ds_details, foreign_stuff)) + }}}}}}} + myParseModule dflags src_filename = do -------------------------- Parser ---------------- showPass dflags "Parser" _scc_ "Parser" do - - buf <- hGetStringBuffer True{-expand tabs-} src_filename + buf <- hGetStringBuffer src_filename let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + ffiEF = dopt Opt_FFI dflags, + withEF = dopt Opt_With dflags, parrEF = dopt Opt_PArr dflags} - loc = mkSrcLoc (_PK_ src_filename) 1 + loc = mkSrcLoc (mkFastString src_filename) 1 case parseModule buf (mkPState loc exts) of { @@ -593,8 +674,10 @@ hscParseStmt dflags str buf <- stringToStringBuffer str let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + ffiEF = dopt Opt_FFI dflags, + withEF = dopt Opt_With dflags, parrEF = dopt Opt_PArr dflags} - loc = mkSrcLoc SLIT("") 1 + loc = mkSrcLoc FSLIT("") 1 case parseStmt buf (mkPState loc exts) of { @@ -665,7 +748,7 @@ hscThing dflags hst hit pcs0 ic str Nothing -> return (pcs, []); Just pcs -> let do_lookup n - | isLocalName n = lookupNameEnv (ic_type_env ic) n + | isInternalName n = lookupNameEnv (ic_type_env ic) n | otherwise = lookupType hst (pcs_PTE pcs) n maybe_ty_things = map do_lookup names @@ -677,8 +760,10 @@ myParseIdentifier dflags str = do buf <- stringToStringBuffer str let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + ffiEF = dopt Opt_FFI dflags, + withEF = dopt Opt_With dflags, parrEF = dopt Opt_PArr dflags} - loc = mkSrcLoc SLIT("") 1 + loc = mkSrcLoc FSLIT("") 1 case parseIdentifier buf (mkPState loc exts) of