Adding pushing of hpc translation status through hi files.

[ghc-hetmet.git] / compiler / main / HscTypes.lhs

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 956d10d..85cf73e 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -29,6 +29,7 @@ module HscTypes (
 
        InteractiveContext(..), emptyInteractiveContext, 
        icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
 
        InteractiveContext(..), emptyInteractiveContext, 
        icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,

+        substInteractiveContext,

 
        ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
        emptyIfaceDepCache,
 
        ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
        emptyIfaceDepCache,

@@ -60,7 +61,7 @@ module HscTypes (
        Linkable(..), isObjectLinkable,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,
        Linkable(..), isObjectLinkable,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,

-        HpcInfo(..), noHpcInfo,
+        HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,

 
         -- Breakpoints
         ModBreaks (..), BreakIndex, emptyModBreaks,
 
         -- Breakpoints
         ModBreaks (..), BreakIndex, emptyModBreaks,

@@ -78,8 +79,8 @@ import {-# SOURCE #-}  InteractiveEval ( Resume )
 #endif
 
 import RdrName         ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), 
 #endif
 
 import RdrName         ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), 

-                          unQualOK, ImpDeclSpec(..), Provenance(..),
-                          ImportSpec(..), lookupGlobalRdrEnv )
+                          mkRdrUnqual, ImpDeclSpec(..), Provenance(..),
+                          ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName )

 import Name            ( Name, NamedThing, getName, nameOccName, nameModule )
 import NameEnv
 import NameSet 
 import Name            ( Name, NamedThing, getName, nameOccName, nameModule )
 import NameEnv
 import NameSet 

@@ -92,9 +93,9 @@ import Rules          ( RuleBase )
 import CoreSyn         ( CoreBind )
 import VarEnv
 import VarSet
 import CoreSyn         ( CoreBind )
 import VarEnv
 import VarSet

-import Var
+import Var       hiding ( setIdType )

 import Id
 import Id

-import Type            ( TyThing(..) )
+import Type            

 
 import Class           ( Class, classSelIds, classATs, classTyCon )
 import TyCon
 
 import Class           ( Class, classSelIds, classATs, classTyCon )
 import TyCon

@@ -115,12 +116,12 @@ import SrcLoc             ( SrcSpan, Located )
 import UniqFM          ( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply      ( UniqSupply )
 import FastString      ( FastString )
 import UniqFM          ( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply      ( UniqSupply )
 import FastString      ( FastString )

-

 import StringBuffer    ( StringBuffer )
 
 import System.Time     ( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
 import StringBuffer    ( StringBuffer )
 
 import System.Time     ( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )

+import Data.List

 \end{code}
 
 
 \end{code}
 
 

@@ -472,12 +473,14 @@ data ModIface
                -- and are not put into the interface file
        mi_dep_fn  :: Name -> Maybe DeprecTxt,  -- Cached lookup for mi_deprecs
        mi_fix_fn  :: OccName -> Fixity,        -- Cached lookup for mi_fixities
                -- and are not put into the interface file
        mi_dep_fn  :: Name -> Maybe DeprecTxt,  -- Cached lookup for mi_deprecs
        mi_fix_fn  :: OccName -> Fixity,        -- Cached lookup for mi_fixities

-       mi_ver_fn  :: OccName -> Maybe (OccName, Version)
+       mi_ver_fn  :: OccName -> Maybe (OccName, Version),

                         -- Cached lookup for mi_decls
                        -- The Nothing in mi_ver_fn means that the thing
                        -- isn't in decls. It's useful to know that when
                        -- seeing if we are up to date wrt the old interface
                         -- The 'OccName' is the parent of the name, if it has one.
                         -- Cached lookup for mi_decls
                        -- The Nothing in mi_ver_fn means that the thing
                        -- isn't in decls. It's useful to know that when
                        -- seeing if we are up to date wrt the old interface
                         -- The 'OccName' is the parent of the name, if it has one.

+       mi_hpc    :: !AnyHpcUsage
+         -- True if this program uses Hpc at any point in the program.

      }
 
 -- Should be able to construct ModDetails from mi_decls in ModIface
      }
 
 -- Should be able to construct ModDetails from mi_decls in ModIface

@@ -522,9 +525,12 @@ data ModGuts
        mg_fix_env   :: !FixityEnv,      -- Fixity env, for things declared in
                                         --   this module 
 
        mg_fix_env   :: !FixityEnv,      -- Fixity env, for things declared in
                                         --   this module 
 

+       mg_inst_env     :: InstEnv,      -- Class instance enviroment fro
+                                        -- *home-package* modules (including
+                                        -- this one); c.f. tcg_inst_env

        mg_fam_inst_env :: FamInstEnv,   -- Type-family instance enviroment
                                         -- for *home-package* modules (including
        mg_fam_inst_env :: FamInstEnv,   -- Type-family instance enviroment
                                         -- for *home-package* modules (including

-                                        -- this one).  c.f. tcg_fam_inst_env
+                                        -- this one); c.f. tcg_fam_inst_env

 
        mg_types     :: !TypeEnv,
        mg_insts     :: ![Instance],     -- Instances 
 
        mg_types     :: !TypeEnv,
        mg_insts     :: ![Instance],     -- Instances 

@@ -625,7 +631,8 @@ emptyModIface mod
                mi_vect_info = noIfaceVectInfo,
               mi_dep_fn = emptyIfaceDepCache,
               mi_fix_fn = emptyIfaceFixCache,
                mi_vect_info = noIfaceVectInfo,
               mi_dep_fn = emptyIfaceDepCache,
               mi_fix_fn = emptyIfaceFixCache,

-              mi_ver_fn = emptyIfaceVerCache
+              mi_ver_fn = emptyIfaceVerCache,
+              mi_hpc    = False

     }          
 \end{code}
 
     }          
 \end{code}
 

@@ -689,6 +696,22 @@ extendInteractiveContext ictxt ids tyvars
                           -- NB. must be this way around, because we want
                           -- new ids to shadow existing bindings.
             ic_tyvars   = ic_tyvars ictxt `unionVarSet` tyvars }
                           -- NB. must be this way around, because we want
                           -- new ids to shadow existing bindings.
             ic_tyvars   = ic_tyvars ictxt `unionVarSet` tyvars }

+
+
+substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
+substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
+substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst =
+   let ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
+       subst_dom= varEnvKeys$ getTvSubstEnv subst
+       subst_ran= varEnvElts$ getTvSubstEnv subst
+       new_tvs  = [ tv | Just tv <- map getTyVar_maybe subst_ran]  
+       ic_tyvars'= (`delVarSetListByKey` subst_dom) 
+                 . (`extendVarSetList`   new_tvs)
+                   $ ic_tyvars ictxt
+    in ictxt { ic_tmp_ids = ids'
+             , ic_tyvars   = ic_tyvars' }
+
+          where delVarSetListByKey = foldl' delVarSetByKey

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -701,19 +724,28 @@ extendInteractiveContext ictxt ids tyvars
 mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified
 mkPrintUnqualified env = (qual_name, qual_mod)
   where
 mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified
 mkPrintUnqualified env = (qual_name, qual_mod)
   where

-  qual_name mod occ
-        | null gres = Just (moduleName mod)
+  qual_name mod occ    -- The (mod,occ) pair is the original name of the thing
+        | [gre] <- unqual_gres, right_name gre = Nothing
+               -- If there's a unique entity that's in scope unqualified with 'occ'
+               -- AND that entity is the right one, then we can use the unqualified name
+
+        | [gre] <- qual_gres = Just (get_qual_mod (gre_prov gre))
+
+        | null qual_gres = Just (moduleName mod)

                 -- it isn't in scope at all, this probably shouldn't happen,
                 -- but we'll qualify it by the original module anyway.
                 -- it isn't in scope at all, this probably shouldn't happen,
                 -- but we'll qualify it by the original module anyway.

-        | any unQualOK gres = Nothing
-        | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is
-          = Just (is_as (is_decl idecl))
-        | otherwise = panic "mkPrintUnqualified" 
+
+       | otherwise = panic "mkPrintUnqualified"

       where
       where

-        gres  = [ gre | gre <- lookupGlobalRdrEnv env occ,
-                       nameModule (gre_name gre) == mod ]
+       right_name gre = nameModule (gre_name gre) == mod

 
 

-  qual_mod mod = Nothing       -- For now...
+        unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
+        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)
+
+       get_qual_mod LocalDef      = moduleName mod
+       get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is))
+
+  qual_mod mod = Nothing       -- For now, we never qualify module names with their packages

 \end{code}
 
 
 \end{code}
 
 

@@ -1226,14 +1258,26 @@ showModMsg target recomp mod_summary
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-data HpcInfo = HpcInfo 
+data HpcInfo 
+  = HpcInfo 

      { hpcInfoTickCount :: Int 
      , hpcInfoHash      :: Int  
      }
      { hpcInfoTickCount :: Int 
      , hpcInfoHash      :: Int  
      }

-     | NoHpcInfo
+  | NoHpcInfo 
+     { hpcUsed          :: AnyHpcUsage  -- is hpc used anywhere on the module tree?
+     }
+
+-- This is used to mean there is no module-local hpc usage,
+-- but one of my imports used hpc instrumentation.
+
+type AnyHpcUsage = Bool
+
+emptyHpcInfo :: AnyHpcUsage -> HpcInfo
+emptyHpcInfo = NoHpcInfo 

 
 

-noHpcInfo :: HpcInfo
-noHpcInfo = NoHpcInfo
+isHpcUsed :: HpcInfo -> AnyHpcUsage
+isHpcUsed (HpcInfo {})                  = True
+isHpcUsed (NoHpcInfo { hpcUsed = used }) = used

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1246,37 +1290,52 @@ The following information is generated and consumed by the vectorisation
 subsystem.  It communicates the vectorisation status of declarations from one
 module to another.
 
 subsystem.  It communicates the vectorisation status of declarations from one
 module to another.
 

-Why do we need both f and f_CC in the ModGuts/ModDetails/EPS version VectInfo
+Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo

 below?  We need to know `f' when converting to IfaceVectInfo.  However, during
 below?  We need to know `f' when converting to IfaceVectInfo.  However, during

-closure conversion, we need to know `f_CC', whose `Var' we cannot lookup based
+vectorisation, we need to know `f_v', whose `Var' we cannot lookup based

 on just the OccName easily in a Core pass.
 
 \begin{code}
 -- ModGuts/ModDetails/EPS version
 data VectInfo      
   = VectInfo {
 on just the OccName easily in a Core pass.
 
 \begin{code}
 -- ModGuts/ModDetails/EPS version
 data VectInfo      
   = VectInfo {

-      vectInfoCCVar :: VarEnv (Var, Var)        -- (f, f_CC) keyed on f
-                                                -- always tidy, even in ModGuts
+      vectInfoVar     :: VarEnv  (Var    , Var  ),   -- (f, f_v) keyed on f
+      vectInfoTyCon   :: NameEnv (TyCon  , TyCon),   -- (T, T_v) keyed on T
+      vectInfoDataCon :: NameEnv (DataCon, DataCon), -- (C, C_v) keyed on C
+      vectInfoIso     :: NameEnv (TyCon  , Var)      -- (T, isoT) keyed on T

     }
     }

+    -- all of this is always tidy, even in ModGuts

 
 -- ModIface version
 data IfaceVectInfo 
   = IfaceVectInfo {
 
 -- ModIface version
 data IfaceVectInfo 
   = IfaceVectInfo {

-      ifaceVectInfoCCVar :: [Name]              -- all variables in here have
-                                                -- a closure-converted variant
-                                                -- the name of the CC'ed variant
-                                                -- is determined by `mkCloOcc'
+      ifaceVectInfoVar        :: [Name],
+        -- all variables in here have a vectorised variant;
+        -- the name of the vectorised variant is determined by `mkCloVect'
+      ifaceVectInfoTyCon      :: [Name],
+        -- all tycons in here have a vectorised variant;
+        -- the name of the vectorised variant and those of its
+        -- data constructors are determined by `mkVectTyConOcc'
+        -- and `mkVectDataConOcc'; the names of
+        -- the isomorphisms is determined by `mkVectIsoOcc'
+      ifaceVectInfoTyConReuse :: [Name]              
+        -- the vectorised form of all the tycons in here coincids with
+        -- the unconverted from; the names of the isomorphisms is determined
+        -- by `mkVectIsoOcc'

     }
 
 noVectInfo :: VectInfo
     }
 
 noVectInfo :: VectInfo

-noVectInfo = VectInfo emptyVarEnv
+noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv

 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 = 
 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 = 

-  VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2)
+  VectInfo (vectInfoVar     vi1 `plusVarEnv`  vectInfoVar     vi2)
+           (vectInfoTyCon   vi1 `plusNameEnv` vectInfoTyCon   vi2)
+           (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
+           (vectInfoIso     vi1 `plusNameEnv` vectInfoIso     vi2)

 
 noIfaceVectInfo :: IfaceVectInfo
 
 noIfaceVectInfo :: IfaceVectInfo

-noIfaceVectInfo = IfaceVectInfo []
+noIfaceVectInfo = IfaceVectInfo [] [] []

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************