X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=6855f94ccf00a232f2fb22a85e6b51804eda4927;hb=9a37b33443be07667867dabb5b67b1319231e648;hp=c292cf013d2abd1ce253507642215d68486a197d;hpb=ead424357937b23f30295608b467aacbc3a8a8bc;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index c292cf0..6855f94 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -59,6 +59,9 @@ module GHC (
 	modInfoInstances,
 	modInfoIsExportedName,
 	modInfoLookupName,
+#if defined(GHCI)
+        modInfoBkptSites,
+#endif
 	lookupGlobalName,
 
 	-- * Printing
@@ -79,11 +82,12 @@ module GHC (
 	RunResult(..),
 	runStmt,
 	showModule,
+        isModuleInterpreted,
 	compileExpr, HValue, dynCompileExpr,
 	lookupName,
 
         getBreakpointHandler, setBreakpointHandler, 
-        obtainTerm,  
+        obtainTerm, obtainTerm1,
 #endif
 
 	-- * Abstract syntax elements
@@ -139,7 +143,8 @@ module GHC (
 	instanceDFunId, pprInstance, pprInstanceHdr,
 
 	-- ** Types and Kinds
-	Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+	Type, dropForAlls, splitForAllTys, funResultTy, 
+	pprParendType, pprTypeApp,
 	Kind,
 	PredType,
 	ThetaType, pprThetaArrow,
@@ -177,6 +182,7 @@ module GHC (
 #include "HsVersions.h"
 
 #ifdef GHCI
+import RtClosureInspect ( cvObtainTerm, Term )
 import TcRnDriver	( tcRnLookupRdrName, tcRnGetInfo,
 			  tcRnLookupName, getModuleExports )
 import RdrName		( plusGlobalRdrEnv, Provenance(..), 
@@ -185,6 +191,7 @@ import RdrName		( plusGlobalRdrEnv, Provenance(..),
 import HscMain		( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 import Name		( nameOccName )
 import Type		( tidyType )
+import Var		( varName )
 import VarEnv		( emptyTidyEnv )
 import GHC.Exts         ( unsafeCoerce# )
 
@@ -203,7 +210,6 @@ import Data.Maybe       ( fromMaybe)
 import qualified Linker
 
 import Data.Dynamic     ( Dynamic )
-import RtClosureInspect ( cvObtainTerm, Term )
 import Linker		( HValue, getHValue, extendLinkEnv )
 #endif
 
@@ -215,14 +221,14 @@ import RdrName		( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
 import HsSyn 
 import Type		( Kind, Type, dropForAlls, PredType, ThetaType,
 			  pprThetaArrow, pprParendType, splitForAllTys,
-			  funResultTy )
+			  pprTypeApp, funResultTy )
 import Id		( Id, idType, isImplicitId, isDeadBinder,
                           isExportedId, isLocalId, isGlobalId,
                           isRecordSelector, recordSelectorFieldLabel,
                           isPrimOpId, isFCallId, isClassOpId_maybe,
                           isDataConWorkId, idDataCon,
                           isBottomingId )
-import Var		( TyVar, varName )
+import Var		( TyVar )
 import TysPrim		( alphaTyVars )
 import TyCon		( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 			  isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
@@ -277,7 +283,6 @@ import System.Exit	( exitWith, ExitCode(..) )
 import System.Time	( ClockTime )
 import Control.Exception as Exception hiding (handle)
 import Data.IORef
-import Data.Traversable ( traverse )
 import System.IO
 import System.IO.Error	( isDoesNotExistError )
 import Prelude hiding (init)
@@ -849,6 +854,9 @@ checkModule session@(Session ref) mod = do
                                                      md_exports details,
 				minf_rdr_env   = Just rdr_env,
 				minf_instances = md_insts details
+#ifdef GHCI
+                               ,minf_dbg_sites = noDbgSites
+#endif
 			      }
 		   return (Just (CheckedModule {
 					parsedSource = parsed,
@@ -1758,6 +1766,9 @@ data ModuleInfo = ModuleInfo {
 	minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
 	minf_rdr_env   :: Maybe GlobalRdrEnv,	-- Nothing for a compiled/package mod
 	minf_instances :: [Instance]
+#ifdef GHCI
+        ,minf_dbg_sites :: [(SiteNumber,Coord)] 
+#endif
 	-- ToDo: this should really contain the ModIface too
   }
 	-- We don't want HomeModInfo here, because a ModuleInfo applies
@@ -1796,7 +1807,8 @@ getPackageModuleInfo hsc_env mdl = do
 			minf_type_env  = mkTypeEnv tys,
 			minf_exports   = names,
 			minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
-			minf_instances = error "getModuleInfo: instances for package module unimplemented"
+			minf_instances = error "getModuleInfo: instances for package module unimplemented",
+                        minf_dbg_sites = noDbgSites
 		}))
 #else
   -- bogusly different for non-GHCI (ToDo)
@@ -1813,6 +1825,9 @@ getHomeModuleInfo hsc_env mdl =
 			minf_exports   = availsToNameSet (md_exports details),
 			minf_rdr_env   = mi_globals $! hm_iface hmi,
 			minf_instances = md_insts details
+#ifdef GHCI
+                       ,minf_dbg_sites = md_dbg_sites details
+#endif
 			}))
 
 -- | The list of top-level entities defined in a module
@@ -1846,6 +1861,10 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do
        return $! lookupType (hsc_dflags hsc_env) 
 			    (hsc_HPT hsc_env) (eps_PTE eps) name
 
+#ifdef GHCI
+modInfoBkptSites = minf_dbg_sites
+#endif
+
 isDictonaryId :: Id -> Bool
 isDictonaryId id
   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
@@ -2194,10 +2213,15 @@ foreign import "rts_evalStableIO"  {- safe -}
 -- show a module and it's source/object filenames
 
 showModule :: Session -> ModSummary -> IO String
-showModule s mod_summary = withSession s $ \hsc_env -> do
+showModule s mod_summary = withSession s $                        \hsc_env -> 
+                           isModuleInterpreted s mod_summary >>=  \interpreted -> 
+                           return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
+
+isModuleInterpreted :: Session -> ModSummary -> IO Bool
+isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> 
   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 	Nothing	      -> panic "missing linkable"
-	Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
+	Just mod_info -> return (not obj_linkable)
 		      where
 			 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
@@ -2268,8 +2292,14 @@ mkSite :: SiteInfo -> BkptLocation Module
 mkSite (pkgName, modName, sitenum) =
   (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum)
 
+obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+
 obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
-obtainTerm sess force id = withSession sess $ \hsc_env -> 
-              getHValue (varName id) >>= traverse (cvObtainTerm hsc_env force Nothing)
+obtainTerm sess force id = withSession sess $ \hsc_env -> do
+              mb_v <- getHValue (varName id) 
+              case mb_v of
+                Just v  -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
+                Nothing -> return Nothing
 
 #endif /* GHCI */