X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=b174e5e419b37854a69c0349dd48c63c8902b6a0;hb=de1d4a16d94fa13e9d40a1ac755eae6249595e66;hp=5d09d7b67c6976f843d5bfaa29839ac4ce1d9e30;hpb=c66f666e3ac615be4b58eb44667b9a0830d29253;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 5d09d7b..b174e5e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -5,81 +5,100 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( HscResult(..), hscMain, +module HscMain ( HscResult(..), hscMain, #ifdef GHCI - hscStmt, + hscStmt, hscThing, hscModuleContents, #endif initPersistentCompilerState ) where #include "HsVersions.h" #ifdef GHCI +import Interpreter import ByteCodeGen ( byteCodeGen ) -import CoreTidy ( tidyCoreExpr ) +import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import Rename ( renameStmt ) +import Rename ( renameStmt, renameRdrName, slurpIface ) +import RdrName ( rdrNameOcc, setRdrNameOcc ) import RdrHsSyn ( RdrNameStmt ) +import OccName ( dataName, tcClsName, + occNameSpace, setOccNameSpace ) import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) -import HscTypes ( InteractiveContext(..) ) +import Name ( isInternalName ) +import NameEnv ( lookupNameEnv ) +import Module ( lookupModuleEnv ) +import RdrName ( rdrEnvElts ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) +import Maybes ( catMaybes ) + +import List ( nub ) #endif import HsSyn +import RdrName ( mkRdrOrig ) 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 ) +import Rename ( checkOldIface, renameModule, renameExtCore, + closeIfaceDecls, RnResult(..) ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) -import PrelNames ( vanillaSyntaxMap, knownKeyNames ) +import PrelRules ( builtinRules ) +import PrelNames ( knownKeyNames, gHC_PRIM_Name ) import MkIface ( mkFinalIface ) import TcModule import InstEnv ( emptyInstEnv ) 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, - moduleUserString ) +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 ( emptyBag ) +import Bag ( consBag, emptyBag ) import Outputable -import Interpreter -import CmStaticInfo ( GhciMode(..) ) 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 ) +import IOExts ( newIORef, readIORef, writeIORef, + unsafePerformIO ) import Monad ( when ) import Maybe ( isJust, fromJust ) import IO import MkExternalCore ( emitExternalCore ) +import ParserCore +import ParserCoreUtils + \end{code} @@ -103,8 +122,11 @@ data HscResult ModIface -- new iface (if any compilation was done) Bool -- stub_h exists Bool -- stub_c exists +#ifdef GHCI (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any - +#else + (Maybe ()) -- no interpreted code whatsoever +#endif -- no errors or warnings; the individual passes -- (parse/rename/typecheck) print messages themselves @@ -124,14 +146,15 @@ hscMain hscMain ghci_mode dflags mod location source_unchanged have_object maybe_old_iface hst hit pcs - = do { + = {-# SCC "hscMain" #-} + do { showPass dflags ("Checking old interface for hs = " ++ show (ml_hs_file location) ++ ", hspp = " ++ show (ml_hspp_file location)); (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 @@ -152,7 +175,8 @@ hscNoRecomp ghci_mode dflags have_object mod location (Just old_iface) hst hit pcs_ch | ghci_mode == OneShot = do { - hPutStrLn stderr "compilation IS NOT required"; + when (verbosity dflags > 0) $ + hPutStrLn stderr "compilation IS NOT required"; let { bomb = panic "hscNoRecomp:OneShot" }; return (HscNoRecomp pcs_ch bomb bomb) } @@ -160,7 +184,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) @@ -171,7 +195,7 @@ hscNoRecomp ghci_mode dflags have_object -- TYPECHECK maybe_tc_result - <- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls); + <- typecheckIface dflags pcs_cl hst old_iface cl_hs_decls; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); @@ -180,74 +204,51 @@ hscNoRecomp ghci_mode dflags have_object return (HscNoRecomp pcs_tc new_details old_iface) }}} -compMsg use_object mod location = - mod_str ++ take (max 0 (16 - length mod_str)) (repeat ' ') - ++" ( " ++ 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 { -- 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 (verbosity dflags >= 1) $ + ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ - compMsg (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_unqualified, maybe_rn_result) - <- _scc_ "Rename" - renameModule dflags 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 + showModMsg (not toInterp) mod location); + + ; 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 ()) ------------------- - -- TYPECHECK - ------------------- - ; maybe_tc_result - <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface - print_unqualified rn_hs_decls - ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); - Just (pcs_tc, tc_result) -> do { - + -- FLATTENING ------------------- - -- DESUGAR - ------------------- - ; (ds_details, foreign_stuff) - <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqualified tc_result + ; flat_details + <- _scc_ "Flattening" + flatten dflags pcs_tc hst ds_details ; pcs_middle - <- if ghci_mode == OneShot + <- _scc_ "pcs_middle" + if ghci_mode == OneShot then do init_pcs <- initPersistentCompilerState init_prs <- initPersistentRenamerState let @@ -260,12 +261,27 @@ 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 + -- flat_details + -- imported_modules (seq'd) + -- new_iface + ------------------- -- SIMPLIFY ------------------- ; simpl_details <- _scc_ "Core2Core" - core2core dflags pcs_middle hst dont_discard ds_details + core2core dflags pcs_middle hst dont_discard flat_details ------------------- -- TIDY @@ -293,11 +309,16 @@ hscRecomp ghci_mode dflags have_object -- new_iface ; emitExternalCore dflags new_iface tidy_details + + ; let final_details = tidy_details {md_binds = []} + ; final_details `seq` return () + ------------------- -- PREPARE FOR CODE GENERATION ------------------- -- Do saturation and convert to A-normal form - ; prepd_details <- _scc_ "CorePrep" corePrepPgm dflags tidy_details + ; prepd_details <- _scc_ "CorePrep" + corePrepPgm dflags tidy_details ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION @@ -308,17 +329,27 @@ hscRecomp ghci_mode dflags have_object local_tycons = typeEnvTyCons env_tc local_classes = typeEnvClasses env_tc - imported_module_names = map ideclName (hsModuleImports rdr_module) + (h_code, c_code, headers, fe_binders) = foreign_stuff - mod_name_to_Module nm - = do m <- findModule nm ; return (fst (fromJust m)) - - (h_code,c_code,fe_binders) = foreign_stuff - - ; imported_modules <- mapM mod_name_to_Module imported_module_names + -- 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 \"" ++ unpackFS 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) ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface ) <- if toInterp +#ifdef GHCI then do ----------------- Generate byte code ------------------ (bcos,itbl_env) <- byteCodeGen dflags binds @@ -332,13 +363,21 @@ 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 else do ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info, stg_back_end_info) <- _scc_ "CoreToStg" - myCoreToStg dflags this_mod binds + myCoreToStg dflags this_mod binds -- Fill in the code-gen info for the earlier tidyCorePgm writeIORef cg_info_ref (Just stg_back_end_info) @@ -347,23 +386,23 @@ hscRecomp ghci_mode dflags have_object final_iface <- _scc_ "MkFinalIface" mkFinalIface ghci_mode dflags location maybe_checked_iface new_iface tidy_details - - ------------------ Code generation ------------------ - abstractC <- _scc_ "CodeGen" - codeGen dflags this_mod imported_modules - cost_centre_info fe_binders - local_tycons stg_binds - - ------------------ Code output ----------------------- - (stub_h_exists, stub_c_exists) - <- codeOutput dflags this_mod local_tycons - binds stg_binds - c_code h_code abstractC - - return (stub_h_exists, stub_c_exists, Nothing, final_iface) - - ; let final_details = tidy_details {md_binds = []} - + if toNothing + then do + return (False, False, Nothing, final_iface) + else do + ------------------ Code generation ------------------ + abstractC <- _scc_ "CodeGen" + codeGen dflags this_mod imported_modules + cost_centre_info fe_binders + local_tycons stg_binds + + ------------------ Code output ----------------------- + (stub_h_exists, stub_c_exists) + <- codeOutput dflags this_mod [] --local_tycons + binds stg_binds + c_code h_code abstractC + + return (stub_h_exists, stub_c_exists, Nothing, final_iface) -- and the answer is ... ; return (HscRecomp pcs_final @@ -371,21 +410,101 @@ 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 src_filename - buf <- hGetStringBuffer True{-expand tabs-} 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 (mkFastString src_filename) 1 - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# - - 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; @@ -408,27 +527,25 @@ 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 + stg_binds <- _scc_ "Core2Stg" + coreToStg dflags tidy_binds - (stg_binds2, cost_centre_info) - <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds + (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg" + stg2stg dflags this_mod stg_binds let env_rhs :: CgInfoEnv - env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info) + env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info) | (bind,_) <- stg_binds2, let caf_info | stgBindHasCafRefs bind = MayHaveCafRefs - | otherwise = NoCafRefs, - (bndr,rhs) <- stgBindPairs bind ] + | otherwise = NoCafRefs, + bndr <- stgBinders bind ] return (stg_binds2, cost_centre_info, env_rhs) - where - stgBindPairs (StgNonRec _ b r) = [(b,r)] - stgBindPairs (StgRec _ prs) = prs - - \end{code} @@ -482,19 +599,13 @@ A naked expression returns a singleton Name [it]. \begin{code} hscStmt dflags hst hit pcs0 icontext stmt just_expr - = let - InteractiveContext { - ic_rn_env = rn_env, - ic_type_env = type_env, - ic_module = scope_mod } = icontext - in - do { maybe_stmt <- hscParseStmt dflags stmt + = do { maybe_stmt <- hscParseStmt dflags stmt ; case maybe_stmt of Nothing -> return (pcs0, Nothing) Just parsed_stmt -> do { - let { notExprStmt (ExprStmt _ _) = False; - notExprStmt _ = True + let { notExprStmt (ExprStmt _ _ _) = False; + notExprStmt _ = True }; if (just_expr && notExprStmt parsed_stmt) @@ -504,8 +615,7 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Rename it (pcs1, print_unqual, maybe_renamed_stmt) - <- renameStmt dflags hit hst pcs0 scope_mod - iNTERACTIVE rn_env parsed_stmt + <- renameStmt dflags hit hst pcs0 icontext parsed_stmt ; case maybe_renamed_stmt of Nothing -> return (pcs0, Nothing) @@ -514,10 +624,10 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Typecheck it maybe_tc_return <- if just_expr - then case rn_stmt of { (syn, ExprStmt e _, decls) -> - typecheckExpr dflags pcs1 hst type_env - print_unqual iNTERACTIVE (syn,e,decls) } - else typecheckStmt dflags pcs1 hst type_env + then case rn_stmt of { (ExprStmt e _ _, decls) -> + typecheckExpr dflags pcs1 hst (ic_type_env icontext) + print_unqual iNTERACTIVE (e,decls) } + else typecheckStmt dflags pcs1 hst (ic_type_env icontext) print_unqual iNTERACTIVE bound_names rn_stmt ; case maybe_tc_return of @@ -527,8 +637,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 @@ -556,16 +669,17 @@ hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) hscParseStmt dflags str = do -------------------------- Parser ---------------- showPass dflags "Parser" - _scc_ "Parser" do + _scc_ "Parser" do buf <- stringToStringBuffer str - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + 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 FSLIT("") 1 - case parseStmt buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc SLIT("") 0 } of { + case parseStmt buf (mkPState loc exts) of { PFailed err -> do { hPutStrLn stderr (showSDoc err); -- Not yet implemented in <4.11 freeStringBuffer buf; @@ -587,6 +701,139 @@ hscParseStmt dflags str %************************************************************************ %* * +\subsection{Getting information about an identifer} +%* * +%************************************************************************ + +\begin{code} +#ifdef GHCI +hscThing -- like hscStmt, but deals with a single identifier + :: DynFlags + -> HomeSymbolTable + -> HomeIfaceTable + -> PersistentCompilerState -- IN: persistent compiler state + -> InteractiveContext -- Context for compiling + -> String -- The identifier + -> IO ( PersistentCompilerState, + [TyThing] ) + +hscThing dflags hst hit pcs0 ic str + = do maybe_rdr_name <- myParseIdentifier dflags str + case maybe_rdr_name of { + Nothing -> return (pcs0, []); + Just rdr_name -> do + + -- if the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names + | occNameSpace occ == dataName = [ rdr_name, tccls_name ] + | otherwise = [ rdr_name ] + where + occ = rdrNameOcc rdr_name + tccls_occ = setOccNameSpace occ tcClsName + tccls_name = setRdrNameOcc rdr_name tccls_occ + + (pcs, unqual, maybe_rn_result) <- + renameRdrName dflags hit hst pcs0 ic rdr_names + + case maybe_rn_result of { + Nothing -> return (pcs, []); + Just (names, decls) -> do { + + maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual + iNTERACTIVE decls; + + case maybe_pcs of { + Nothing -> return (pcs, []); + Just pcs -> + let do_lookup n + | isInternalName 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) } + }}} + +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 FSLIT("") 1 + + case parseIdentifier buf (mkPState loc exts) of + + PFailed err -> do { hPutStrLn stderr (showSDoc err); + freeStringBuffer buf; + return Nothing } + + POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf; + return (Just rdr_name) } +#endif +\end{code} + +%************************************************************************ +%* * +\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} %* * %************************************************************************ @@ -612,10 +859,18 @@ initPersistentRenamerState :: IO PersistentRenamerState nsIPs = emptyFM }, prsDecls = (emptyNameEnv, 0), prsInsts = (emptyBag, 0), - prsRules = (emptyBag, 0), + prsRules = foldr add_rule (emptyBag, 0) builtinRules, prsImpMods = emptyFM } ) + where + add_rule (name,rule) (rules, n_rules) + = (gated_decl `consBag` rules, n_rules+1) + where + gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) + mod = nameModule name + rdr_name = mkRdrOrig (moduleName mod) (nameOccName name) + gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible initOrigNames :: FiniteMap (ModuleName,OccName) Name initOrigNames