Add VectInfo to HPT

  I am putting this patch (as the previous VectInfo patch) straight away
  into the head to avoid the kind of merging disaster we had with the FC
  branch.  The patch does not interfere with any other functionality and
  hence should cause no harm in the head.

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index df5bc08..e3193bd 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -242,11 +242,11 @@ mkIface hsc_env maybe_old_iface
                      mg_deps      = deps,
                      mg_rdr_env   = rdr_env,
                      mg_fix_env   = fix_env,
                      mg_deps      = deps,
                      mg_rdr_env   = rdr_env,
                      mg_fix_env   = fix_env,

-                     mg_deprecs   = src_deprecs,
-                      mg_vect_info = vect_info })
+                     mg_deprecs   = src_deprecs})

        (ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
        (ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,

+                      md_vect_info = vect_info,

                      md_types     = type_env,
                      md_exports   = exports })
        
                      md_types     = type_env,
                      md_exports   = exports })
        

@@ -272,6 +272,7 @@ mkIface hsc_env maybe_old_iface
                ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
                ; iface_insts = map instanceToIfaceInst insts
                ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
                ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
                ; iface_insts = map instanceToIfaceInst insts
                ; iface_fam_insts = map famInstToIfaceFamInst fam_insts

+                ; iface_vect_info = flattenVectInfo vect_info

 
                ; intermediate_iface = ModIface { 
                        mi_module   = this_mod,
 
                ; intermediate_iface = ModIface { 
                        mi_module   = this_mod,

@@ -286,6 +287,8 @@ mkIface hsc_env maybe_old_iface
                        mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
                        mi_rules    = sortLe le_rule iface_rules,
 
                        mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
                        mi_rules    = sortLe le_rule iface_rules,
 

+                        mi_vect_info = iface_vect_info,
+

                        mi_fixities = fixities,
                        mi_deprecs  = deprecs,
                        mi_globals  = Just rdr_env,
                        mi_fixities = fixities,
                        mi_deprecs  = deprecs,
                        mi_globals  = Just rdr_env,

@@ -300,8 +303,6 @@ mkIface hsc_env maybe_old_iface
                        mi_decls     = deliberatelyOmitted "decls",
                        mi_ver_fn    = deliberatelyOmitted "ver_fn",
 
                        mi_decls     = deliberatelyOmitted "decls",
                        mi_ver_fn    = deliberatelyOmitted "ver_fn",
 

-                        mi_vect_info = flattenVectInfo vect_info,
-

                        -- And build the cached values
                        mi_dep_fn = mkIfaceDepCache deprecs,
                        mi_fix_fn = mkIfaceFixCache fixities }
                        -- And build the cached values
                        mi_dep_fn = mkIfaceDepCache deprecs,
                        mi_fix_fn = mkIfaceFixCache fixities }

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2e3c8ed..a90d069 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -40,6 +40,7 @@ import Var              ( TyVar )
 import qualified Var
 import Name
 import NameEnv
 import qualified Var
 import Name
 import NameEnv

+import NameSet

 import OccName
 import Module
 import UniqFM
 import OccName
 import Module
 import UniqFM

@@ -198,6 +199,10 @@ typecheckIface iface
        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
 
        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
 

+                -- Vectorisation information
+        ; let vect_info = VectInfo 
+                           (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface)))
+

                -- Exports
        ; exports <- ifaceExportNames (mi_exports iface)
 
                -- Exports
        ; exports <- ifaceExportNames (mi_exports iface)
 

@@ -208,6 +213,7 @@ typecheckIface iface
                              , md_insts     = insts
                              , md_fam_insts = fam_insts
                              , md_rules     = rules
                              , md_insts     = insts
                              , md_fam_insts = fam_insts
                              , md_rules     = rules

+                              , md_vect_info = vect_info

                              , md_exports   = exports
                               , md_modBreaks = emptyModBreaks
                              }
                              , md_exports   = exports
                               , md_modBreaks = emptyModBreaks
                              }

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index b4026e8..282ec0f 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -682,9 +682,14 @@ hscFileCheck hsc_env mod_summary = do {
                                md_insts     = tcg_insts     tc_result,
                                md_fam_insts = tcg_fam_insts tc_result,
                                 md_modBreaks = emptyModBreaks,      
                                md_insts     = tcg_insts     tc_result,
                                md_fam_insts = tcg_fam_insts tc_result,
                                 md_modBreaks = emptyModBreaks,      

-                               md_rules     = [panic "no rules"] }
+                               md_rules     = [panic "no rules"],

                                   -- Rules are CoreRules, not the
                                   -- RuleDecls we get out of the typechecker
                                   -- Rules are CoreRules, not the
                                   -- RuleDecls we get out of the typechecker

+                                md_vect_info = 
+                                  panic "HscMain.hscFileCheck: no VectInfo"
+                                   -- VectInfo is added by the Core 
+                                   -- vectorisation pass
+                          }

                     rnInfo = do decl <- tcg_rn_decls tc_result
                                 imports <- tcg_rn_imports tc_result
                                 let exports = tcg_rn_exports tc_result
                     rnInfo = do decl <- tcg_rn_decls tc_result
                                 imports <- tcg_rn_imports tc_result
                                 let exports = tcg_rn_exports tc_result

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index eeea9d9..bf7d676 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -21,7 +21,7 @@ module HscTypes (
        HscSource(..), isHsBoot, hscSourceString,       -- Re-exported from DriverPhases
        
        HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
        HscSource(..), isHsBoot, hscSourceString,       -- Re-exported from DriverPhases
        
        HomePackageTable, HomeModInfo(..), emptyHomePackageTable,

-       hptInstances, hptRules,
+       hptInstances, hptRules, hptVectInfo,

 
        ExternalPackageState(..), EpsStats(..), addEpsInStats,
        PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
 
        ExternalPackageState(..), EpsStats(..), addEpsInStats,
        PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,

@@ -330,6 +330,15 @@ hptRules hsc_env deps
 
        -- And get its dfuns
     , rule <- rules ]
 
        -- And get its dfuns
     , rule <- rules ]

+
+hptVectInfo :: HscEnv -> VectInfo
+-- Get the combined VectInfo of all modules in the home package table.  In
+-- contrast to instances and rules, we don't care whether the modules are
+-- "below" or us.  The VectInfo of those modules not "below" us does not
+-- affect the compilation of the current module.
+hptVectInfo hsc_env 
+  = foldr plusVectInfo noVectInfo [ md_vect_info (hm_details mod_info)
+                                  | mod_info <- eltsUFM (hsc_HPT hsc_env)]

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

@@ -475,10 +484,11 @@ data ModDetails
        -- The next two fields are created by the typechecker
        md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,
        -- The next two fields are created by the typechecker
        md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,

-        md_insts     :: ![Instance],   -- Dfun-ids for the instances in this module
+        md_insts     :: ![Instance],  -- Dfun-ids for the instances in this module

         md_fam_insts :: ![FamInst],
         md_fam_insts :: ![FamInst],

-        md_rules     :: ![CoreRule],   -- Domain may include Ids from other modules
-        md_modBreaks :: !ModBreaks  -- breakpoint information for this module 
+        md_rules     :: ![CoreRule],  -- Domain may include Ids from other modules
+        md_modBreaks :: !ModBreaks,   -- Breakpoint information for this module 
+        md_vect_info :: !VectInfo     -- Vectorisation information

      }
 
 emptyModDetails = ModDetails { md_types = emptyTypeEnv,
      }
 
 emptyModDetails = ModDetails { md_types = emptyTypeEnv,

@@ -486,7 +496,9 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
                               md_insts     = [],
                               md_rules     = [],
                               md_fam_insts = [],
                               md_insts     = [],
                               md_rules     = [],
                               md_fam_insts = [],

-                               md_modBreaks = emptyModBreaks } 
+                               md_modBreaks = emptyModBreaks,
+                               md_vect_info = noVectInfo
+                             } 

 
 -- A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
 
 -- A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b001e1d..6b89b33 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
                        )
                          localiseName, isExternalName, nameSrcLoc,
                          isWiredInName, getName
                        )

-import NameSet         ( NameSet, elemNameSet )
+import NameSet         ( NameSet, elemNameSet, filterNameSet )

 import IfaceEnv                ( allocateGlobalBinder )
 import NameEnv         ( filterNameEnv, mapNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import IfaceEnv                ( allocateGlobalBinder )
 import NameEnv         ( filterNameEnv, mapNameEnv )
 import OccName         ( TidyOccEnv, initTidyOccEnv, tidyOccName )

@@ -142,6 +142,7 @@ mkBootModDetails hsc_env (ModGuts { mg_module    = mod
                             , md_rules     = []
                             , md_exports   = exports
                              , md_modBreaks = modBreaks 
                             , md_rules     = []
                             , md_exports   = exports
                              , md_modBreaks = modBreaks 

+                             , md_vect_info = noVectInfo

                              })
        }
   where
                              })
        }
   where

@@ -243,6 +244,7 @@ tidyProgram hsc_env
                                mg_insts = insts, mg_fam_insts = fam_insts,
                                mg_binds = binds, 
                                mg_rules = imp_rules,
                                mg_insts = insts, mg_fam_insts = fam_insts,
                                mg_binds = binds, 
                                mg_rules = imp_rules,

+                                mg_vect_info = vect_info,

                                mg_dir_imps = dir_imps, mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,
                                mg_dir_imps = dir_imps, mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,

@@ -285,6 +287,12 @@ tidyProgram hsc_env
              ; implicit_binds = getImplicitBinds type_env
              ; all_tidy_binds = implicit_binds ++ tidy_binds
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_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
              }
 
        ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds

@@ -305,8 +313,9 @@ tidyProgram hsc_env
                                md_insts     = tidy_insts,
                                md_fam_insts = fam_insts,
                                md_exports   = exports,
                                md_insts     = tidy_insts,
                                md_fam_insts = fam_insts,
                                md_exports   = exports,

-                                md_modBreaks = modBreaks })
-
+                                md_modBreaks = modBreaks,
+                                md_vect_info = tidy_vect_info
+                              })

        }
 
 lookup_dfun type_env dfun_id
        }
 
 lookup_dfun type_env dfun_id

@@ -314,6 +323,11 @@ lookup_dfun type_env dfun_id
        Just (AnId dfun_id') -> dfun_id'
        other -> pprPanic "lookup_dfun" (ppr 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
 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
 
 -- The competed type environment is gotten from