X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=8c41409244dd95405549f0ef84a68dc0118ea8da;hb=027168af50b6eee2ee043caf7a030d490b40967e;hp=58c41f73a7f3314f62a4bd948070a9c196ccb542;hpb=d0d6d1865396d0079783c28fc2bdedc9b0a0dd2e;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 58c41f7..8c41409 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -7,7 +7,7 @@ \begin{code} module HscMain ( HscResult(..), hscMain, #ifdef GHCI - hscStmt, hscThing, + hscStmt, hscThing, hscModuleContents, #endif initPersistentCompilerState ) where @@ -18,7 +18,7 @@ import Interpreter import ByteCodeGen ( byteCodeGen ) import CoreTidy ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import Rename ( renameStmt, renameRdrName ) +import Rename ( renameStmt, renameRdrName, slurpIface ) import RdrName ( rdrNameOcc, setRdrNameOcc ) import RdrHsSyn ( RdrNameStmt ) import OccName ( dataName, tcClsName, @@ -26,11 +26,16 @@ import OccName ( dataName, tcClsName, import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) -import HscTypes ( InteractiveContext(..) ) +import Name ( isLocalName ) +import NameEnv ( lookupNameEnv ) +import Module ( lookupModuleEnv ) +import RdrName ( rdrEnvElts ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import FastString ( mkFastString ) import Maybes ( catMaybes ) + +import List ( nub ) #endif import HsSyn @@ -40,7 +45,7 @@ import Id ( idName ) import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) import StringBuffer ( hGetStringBuffer, freeStringBuffer ) import Parser -import Lex ( PState(..), ParseResult(..) ) +import Lex ( ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) import Finder ( findModule ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) @@ -52,6 +57,7 @@ import MkIface ( mkFinalIface ) import TcModule import InstEnv ( emptyInstEnv ) import Desugar +import Flattening ( flatten, flattenExpr ) import SimplCore import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) @@ -60,11 +66,11 @@ import StgSyn import CoreToStg ( coreToStg ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) -import CodeOutput ( codeOutput ) +import CodeOutput ( codeOutput, outputForeignStubs ) -import Module ( ModuleName, moduleName, mkHomeModule, - moduleUserString ) +import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts +import DriverState ( v_HCHeader ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) @@ -75,11 +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 IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) +import IOExts ( newIORef, readIORef, writeIORef, + unsafePerformIO ) import Monad ( when ) import Maybe ( isJust, fromJust ) @@ -141,7 +148,7 @@ hscMain ghci_mode dflags mod location source_unchanged have_object (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface)) <- _scc_ "checkOldIface" - checkOldIface ghci_mode dflags hit hst pcs (ml_hi_file location) + checkOldIface ghci_mode dflags hit hst pcs mod (ml_hi_file location) source_unchanged maybe_old_iface; if errs_found then @@ -171,7 +178,7 @@ hscNoRecomp ghci_mode dflags have_object = do { when (verbosity dflags >= 1) $ hPutStrLn stderr ("Skipping " ++ - compMsg have_object mod location); + showModMsg have_object mod location); -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -191,16 +198,6 @@ hscNoRecomp ghci_mode dflags have_object return (HscNoRecomp pcs_tc new_details old_iface) }}} -compMsg use_object mod location = - mod_str ++ replicate (max 0 (16 - length mod_str)) ' ' - ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", " - ++ (if use_object - then unJust "hscRecomp" (ml_obj_file location) - else "interpreted") - ++ " )" - where mod_str = moduleUserString mod - - hscRecomp ghci_mode dflags have_object mod location maybe_checked_iface hst hit pcs_ch = do { @@ -210,7 +207,7 @@ hscRecomp ghci_mode dflags have_object ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ - compMsg (not toInterp) mod location); + showModMsg (not toInterp) mod location); ------------------- -- PARSE @@ -225,33 +222,21 @@ hscRecomp ghci_mode dflags have_object ------------------- -- RENAME ------------------- - ; (pcs_rn, print_unqualified, maybe_rn_result) + ; (pcs_rn, print_unqual, maybe_rn_result) <- _scc_ "Rename" - renameModule dflags hit hst pcs_ch this_mod rdr_module + renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { - Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); - Just (is_exported, new_iface, rn_hs_decls) -> do { - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isGlobalName separates the user-defined top-level names from those - -- introduced by the type checker. - - ; let dont_discard | ghci_mode == Interactive = isGlobalName - | otherwise = is_exported + Nothing -> return (HscFail pcs_ch); + Just (dont_discard, new_iface, rn_result) -> do { ------------------- -- TYPECHECK ------------------- ; maybe_tc_result <- _scc_ "TypeCheck" - typecheckModule dflags pcs_rn hst new_iface - print_unqualified rn_hs_decls + typecheckModule dflags pcs_rn hst print_unqual rn_result ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); + Nothing -> return (HscFail pcs_ch); Just (pcs_tc, tc_result) -> do { ------------------- @@ -259,7 +244,14 @@ hscRecomp ghci_mode dflags have_object ------------------- ; (ds_details, foreign_stuff) <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqualified tc_result + deSugar dflags pcs_tc hst this_mod print_unqual tc_result + + ------------------- + -- FLATTENING + ------------------- + ; flat_details + <- _scc_ "Flattening" + flatten dflags pcs_tc hst ds_details ; pcs_middle <- _scc_ "pcs_middle" @@ -287,7 +279,7 @@ hscRecomp ghci_mode dflags have_object ------------------- ; simpl_details <- _scc_ "Core2Core" - core2core dflags pcs_middle hst dont_discard ds_details + core2core dflags pcs_middle hst dont_discard flat_details ------------------- -- TIDY @@ -340,7 +332,23 @@ hscRecomp ghci_mode dflags have_object mod_name_to_Module nm = do m <- findModule nm ; return (fst (fromJust m)) - (h_code,c_code,fe_binders) = foreign_stuff + (h_code, c_code, headers, fe_binders) = foreign_stuff + + -- turn the list of headers requested in foreign import + -- declarations into a string suitable for emission into generated + -- C code... + -- + foreign_headers = + unlines + . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"") + . reverse + $ headers + + -- ...and add the string to the headers requested via command line + -- options + -- + ; fhdrs <- readIORef v_HCHeader + ; writeIORef v_HCHeader (fhdrs ++ foreign_headers) ; imported_modules <- mapM mod_name_to_Module imported_module_names @@ -360,7 +368,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 @@ -411,12 +424,11 @@ myParseModule dflags src_filename buf <- hGetStringBuffer True{-expand tabs-} src_filename - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc (_PK_ src_filename) 1 - case parseModule buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc (_PK_ src_filename) 1 } of { + case parseModule buf (mkPState loc exts) of { PFailed err -> do { hPutStrLn stderr (showSDoc err); freeStringBuffer buf; @@ -439,7 +451,9 @@ myCoreToStg dflags this_mod tidy_binds () <- coreBindsSize tidy_binds `seq` return () -- TEMP: the above call zaps some space usage allocated by the -- simplifier, which for reasons I don't understand, persists - -- thoroughout code generation + -- thoroughout code generation -- JRS + -- + -- This is still necessary. -- SDM (10 Dec 2001) stg_binds <- _scc_ "Core2Stg" coreToStg dflags tidy_binds @@ -525,8 +539,7 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Rename it (pcs1, print_unqual, maybe_renamed_stmt) - <- renameStmt dflags hit hst pcs0 - iNTERACTIVE icontext parsed_stmt + <- renameStmt dflags hit hst pcs0 icontext parsed_stmt ; case maybe_renamed_stmt of Nothing -> return (pcs0, Nothing) @@ -548,8 +561,11 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Desugar it ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr + -- Flatten it + ; flat_expr <- flattenExpr dflags pcs2 hst ds_expr + -- Simplify it - ; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr + ; simpl_expr <- simplifyExpr dflags pcs2 hst flat_expr -- Tidy it (temporary, until coreSat does cloning) ; tidy_expr <- tidyCoreExpr simpl_expr @@ -581,12 +597,11 @@ hscParseStmt dflags str buf <- stringToStringBuffer str - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc SLIT("") 1 - case parseStmt buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc SLIT("") 1 } of { + case parseStmt buf (mkPState loc exts) of { PFailed err -> do { hPutStrLn stderr (showSDoc err); -- Not yet implemented in <4.11 freeStringBuffer buf; @@ -624,7 +639,7 @@ hscThing -- like hscStmt, but deals with a single identifier -> IO ( PersistentCompilerState, [TyThing] ) -hscThing dflags hst hit pcs0 icontext str +hscThing dflags hst hit pcs0 ic str = do maybe_rdr_name <- myParseIdentifier dflags str case maybe_rdr_name of { Nothing -> return (pcs0, []); @@ -642,7 +657,7 @@ hscThing dflags hst hit pcs0 icontext str tccls_name = setRdrNameOcc rdr_name tccls_occ (pcs, unqual, maybe_rn_result) <- - renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext rdr_names + renameRdrName dflags hit hst pcs0 ic rdr_names case maybe_rn_result of { Nothing -> return (pcs, []); @@ -654,7 +669,11 @@ hscThing dflags hst hit pcs0 icontext str case maybe_pcs of { Nothing -> return (pcs, []); Just pcs -> - let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names + let do_lookup n + | isLocalName n = lookupNameEnv (ic_type_env ic) n + | otherwise = lookupType hst (pcs_PTE pcs) n + + maybe_ty_things = map do_lookup names in return (pcs, catMaybes maybe_ty_things) } }}} @@ -662,13 +681,11 @@ hscThing dflags hst hit pcs0 icontext str myParseIdentifier dflags str = do buf <- stringToStringBuffer str - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc SLIT("") 1 - case parseIdentifier buf - PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc SLIT("") 1 } of + case parseIdentifier buf (mkPState loc exts) of PFailed err -> do { hPutStrLn stderr (showSDoc err); freeStringBuffer buf; @@ -681,6 +698,62 @@ myParseIdentifier dflags str %************************************************************************ %* * +\subsection{Find all the things defined in a module} +%* * +%************************************************************************ + +\begin{code} +#ifdef GHCI +hscModuleContents + :: DynFlags + -> HomeSymbolTable + -> HomeIfaceTable + -> PersistentCompilerState -- IN: persistent compiler state + -> Module -- module to inspect + -> Bool -- grab just the exports, or the whole toplev + -> IO (PersistentCompilerState, Maybe [TyThing]) + +hscModuleContents dflags hst hit pcs0 mod exports_only = do { + + -- slurp the interface if necessary + (pcs1, print_unqual, maybe_rn_stuff) + <- slurpIface dflags hit hst pcs0 mod; + + case maybe_rn_stuff of { + Nothing -> return (pcs0, Nothing); + Just (names, rn_decls) -> do { + + -- Typecheck the declarations + maybe_pcs <- + typecheckExtraDecls dflags pcs1 hst print_unqual iNTERACTIVE rn_decls; + + case maybe_pcs of { + Nothing -> return (pcs1, Nothing); + Just pcs2 -> + + let { all_names + | exports_only = names + | otherwise = + let { iface = fromJust (lookupModuleEnv hit mod); + env = fromJust (mi_globals iface); + range = rdrEnvElts env; + } in + -- grab all the things from the global env that are locally def'd + nub [ n | elts <- range, GRE n LocalDef _ <- elts ]; + + pte = pcs_PTE pcs2; + + ty_things = map (fromJust . lookupType hst pte) all_names; + + } in + + return (pcs2, Just ty_things) + }}}} +#endif +\end{code} + +%************************************************************************ +%* * \subsection{Initial persistent state} %* * %************************************************************************