Improved VectInfo

- We need to keep pairs of (f, f_CC) in VectInfo as it is difficult
  to obtain Names from OccNames (of imported modules) in Core passes.
- There is a choice of keeping Names or Vars in VectInfo.  We go with Vars
  for now; mainly to avoid converting between Names and Vars repeatedly for
  the same VectInfo in other than one-shot mode.

  Again goes to the HEAD straight away to avoid conflicts down the road.

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 00e9e7a..1c8b410 100644 (file)
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -19,7 +19,7 @@ module LoadIface (
 #include "HsVersions.h"
 
 import {-# SOURCE #-}  TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, 
-                                tcIfaceFamInst )
+                                tcIfaceFamInst, tcIfaceVectInfo )
 
 import DynFlags
 import IfaceSyn
@@ -239,6 +239,8 @@ loadInterface doc_str mod from
        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) 
+                                               (mi_vect_info iface)
 
        ; let { final_iface = iface {   
                                mi_decls     = panic "No mi_decls in PIT",
@@ -246,11 +248,6 @@ loadInterface doc_str mod from
                                mi_fam_insts = panic "No mi_fam_insts in PIT",
                                mi_rules     = panic "No mi_rules in PIT"
                               }
-              ; new_eps_vect_info =
-                  VectInfo {
-                    vectInfoCCVar = mkNameSet 
-                                     (ifaceVectInfoCCVar . mi_vect_info $ iface)
-                  }     
                }
 
        ; updateEps_  $ \ eps -> 
@@ -587,6 +584,7 @@ pprModIface iface
        , vcat (map ppr (mi_insts iface))
        , vcat (map ppr (mi_fam_insts iface))
        , vcat (map ppr (mi_rules iface))
+        , pprVectInfo (mi_vect_info iface)
        , pprDeprecs (mi_deprecs iface)
        ]
   where
@@ -659,6 +657,10 @@ pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes
                  where
                    pprFix (occ,fix) = ppr fix <+> ppr occ 
 
+pprVectInfo :: IfaceVectInfo -> SDoc
+pprVectInfo (IfaceVectInfo names) = 
+  ptext SLIT("Closured converted:") <+> hsep (map ppr names)
+
 pprDeprecs NoDeprecs       = empty
 pprDeprecs (DeprecAll txt)  = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt)
 pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs)

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index e3193bd..811af49 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -195,6 +195,8 @@ import TcRnMonad
 import HscTypes
 
 import DynFlags
+import VarEnv
+import Var
 import Name
 import NameEnv
 import NameSet
@@ -337,7 +339,8 @@ mkIface hsc_env maybe_old_iface
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 
-     flattenVectInfo (VectInfo ccVar) = IfaceVectInfo (nameSetToList ccVar)
+     flattenVectInfo (VectInfo ccVar) = 
+       IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar]
 
 -----------------------------
 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()

diff --git a/compiler/iface/TcIface.hi-boot-6 b/compiler/iface/TcIface.hi-boot-6
index 3c8ae73..9153c8c 100644 (file)
--- a/compiler/iface/TcIface.hi-boot-6
+++ b/compiler/iface/TcIface.hi-boot-6
@@ -3,6 +3,7 @@ module TcIface where
 tcIfaceDecl  :: GHC.Base.Bool -> IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing
 tcIfaceInst  :: IfaceSyn.IfaceInst -> TcRnTypes.IfL InstEnv.Instance
 tcIfaceRules :: GHC.Base.Bool -> [IfaceSyn.IfaceRule] -> TcRnTypes.IfL [CoreSyn.CoreRule]
+tcIfaceVectInfo :: Module.Module -> HscTypes.TypeEnv -> HscTypes.IfaceVectInfo -> TcRnTypes.IfL VectInfo
 tcIfaceFamInst :: IfaceSyn.IfaceFamInst -> TcRnTypes.IfL FamInstEnv.FamInst
 
 

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index a90d069..6f76ae1 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -8,8 +8,8 @@ Type checking of type signatures in interface files
 \begin{code}
 module TcIface ( 
        tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, 
-       tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal, 
-       tcExtCoreBindings
+       tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+       tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
  ) where
 
 #include "HsVersions.h"
@@ -38,9 +38,9 @@ import DataCon
 import TysWiredIn
 import Var              ( TyVar )
 import qualified Var
+import VarEnv
 import Name
 import NameEnv
-import NameSet
 import OccName
 import Module
 import UniqFM
@@ -200,8 +200,8 @@ typecheckIface iface
        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
 
                 -- Vectorisation information
-        ; let vect_info = VectInfo 
-                           (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface)))
+        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env 
+                                       (mi_vect_info iface)
 
                -- Exports
        ; exports <- ifaceExportNames (mi_exports iface)
@@ -578,6 +578,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
 
 %************************************************************************
 %*                                                                     *
+               Vectorisation information
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+tcIfaceVectInfo :: Module -> TypeEnv  -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo mod typeEnv (IfaceVectInfo names)
+  = do { ccVars <- mapM ccMapping names
+       ; return $ VectInfo (mkVarEnv ccVars)
+       }
+  where
+    ccMapping name 
+      = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name))
+           ; let { var   = lookup name
+                 ; ccVar = lookup ccName
+                 }
+           ; return (var, (var, ccVar))
+           }
+    lookup name = case lookupTypeEnv typeEnv name of
+                    Just (AnId var) -> var
+                    Just _          -> 
+                      panic "TcIface.tcIfaceVectInfo: wrong TyThing"
+                    Nothing         ->
+                      panic "TcIface.tcIfaceVectInfo: unknown name"
+\end{code}
+
+%************************************************************************
+%*                                                                     *
                        Types
 %*                                                                     *
 %************************************************************************

diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
index ac3e880..51ab255 100644 (file)
--- a/compiler/iface/TcIface.lhs-boot
+++ b/compiler/iface/TcIface.lhs-boot
@@ -6,9 +6,12 @@ import TcRnTypes  ( IfL )
 import InstEnv   ( Instance )
 import FamInstEnv ( FamInst )
 import CoreSyn   ( CoreRule )
+import HscTypes   ( TypeEnv, VectInfo, IfaceVectInfo )
+import Module     ( Module )
 
 tcIfaceDecl    :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules   :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
 tcIfaceInst    :: IfaceInst -> IfL Instance
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 \end{code}

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index bf7d676..956d10d 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -90,7 +90,9 @@ import InstEnv                ( InstEnv, Instance )
 import FamInstEnv      ( FamInstEnv, FamInst )
 import Rules           ( RuleBase )
 import CoreSyn         ( CoreBind )
+import VarEnv
 import VarSet
+import Var
 import Id
 import Type            ( TyThing(..) )
 
@@ -1244,23 +1246,34 @@ The following information is generated and consumed by the vectorisation
 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
+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
+on just the OccName easily in a Core pass.
+
 \begin{code}
--- ModGuts version
-data VectInfo      = VectInfo {
-                       vectInfoCCVar :: NameSet
-                     }
+-- ModGuts/ModDetails/EPS version
+data VectInfo      
+  = VectInfo {
+      vectInfoCCVar :: VarEnv (Var, Var)        -- (f, f_CC) keyed on f
+                                                -- always tidy, even in ModGuts
+    }
 
 -- ModIface version
-data IfaceVectInfo = IfaceVectInfo {
-                       ifaceVectInfoCCVar :: [Name]
-                     }
+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'
+    }
 
 noVectInfo :: VectInfo
-noVectInfo = VectInfo emptyNameSet
+noVectInfo = VectInfo emptyVarEnv
 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 = 
-  VectInfo (vectInfoCCVar vi1 `unionNameSets` vectInfoCCVar vi2)
+  VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2)
 
 noIfaceVectInfo :: IfaceVectInfo
 noIfaceVectInfo = IfaceVectInfo []

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 6b89b33..7405d14 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -32,7 +32,7 @@ import Name           ( Name, getOccName, nameOccName, mkInternalName,
                          localiseName, isExternalName, nameSrcLoc,
                          isWiredInName, getName
                        )
-import NameSet         ( NameSet, elemNameSet, filterNameSet )
+import NameSet         ( NameSet, elemNameSet )
 import IfaceEnv                ( allocateGlobalBinder )
 import NameEnv         ( filterNameEnv, mapNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
@@ -287,12 +287,6 @@ tidyProgram hsc_env
              ; implicit_binds = getImplicitBinds type_env
              ; all_tidy_binds = implicit_binds ++ tidy_binds
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
-
-              ; tidy_vect_info = VectInfo 
-                                   (filterNameSet (isElemId type_env) 
-                                                  (vectInfoCCVar vect_info))
-                -- filter against `type_env', not `tidy_type_env', as we must
-                -- keep all implicit names
              }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
@@ -314,7 +308,7 @@ tidyProgram hsc_env
                                md_fam_insts = fam_insts,
                                md_exports   = exports,
                                 md_modBreaks = modBreaks,
-                                md_vect_info = tidy_vect_info
+                                md_vect_info = vect_info    -- is already tidy
                               })
        }
 
@@ -323,11 +317,6 @@ lookup_dfun type_env dfun_id
        Just (AnId dfun_id') -> dfun_id'
        other -> pprPanic "lookup_dfun" (ppr dfun_id)
 
-isElemId type_env name
-  = case lookupTypeEnv type_env name of
-       Just (AnId _) -> True
-       _             -> False
-
 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
 
 -- The competed type environment is gotten from