Ticky is an RTS-only way; also fix collateral damage to other ways

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 966976b..52212d6 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -82,11 +82,12 @@ module GHC (
        RunResult(..),
        runStmt,
        showModule,
+        isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,
        lookupName,
 
         getBreakpointHandler, setBreakpointHandler, 
-        obtainTerm,  
+        obtainTerm, obtainTerm1,
 #endif
 
        -- * Abstract syntax elements
@@ -142,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,
@@ -189,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# )
 
@@ -218,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,
@@ -336,9 +339,8 @@ defaultErrorHandler dflags inner =
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
     -- make sure we clean up after ourselves
-    later (unless (dopt Opt_KeepTmpFiles dflags) $
-               do cleanTempFiles dflags
-                  cleanTempDirs dflags
+    later (do cleanTempFiles dflags
+              cleanTempDirs dflags
           )
           -- exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
@@ -2206,17 +2208,26 @@ foreign import "rts_evalStableIO"  {- safe -}
   -- more informative than the C type!
 -}
 
+
 -----------------------------------------------------------------------------
 -- 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))
 
+-----------------------------------------------------------------------------
+-- Breakpoint handlers
+
 getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
 getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
  
@@ -2244,6 +2255,9 @@ reinstallBreakpointHandlers session = do
     initDynLinker dflags 
     extendLinkEnv linkEnv
 
+-----------------------------------------------------------------------
+-- Jump functions
+
 type SiteInfo = (String, String, SiteNumber)
 jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> Int -> [Opaque] 
                                 -> SiteInfo -> String -> b -> b
@@ -2263,8 +2277,7 @@ jumpFunction session handler ptr hValues siteInfo locmsg b
 jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = 
       do 
          ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
-         ASSERT (length ids == length wrapped_hValues) return ()
-         let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues]
+         let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
          handleBreakpoint handler session (zip ids hValues) site locmsg b
 
 jumpAutoFunction session handler ptr hValues siteInfo locmsg b 
@@ -2284,6 +2297,9 @@ 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 -> do
               mb_v <- getHValue (varName id)