Hooked the C-- CPS pass into the compilation pipeline

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

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 4797770..b353caa 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,

@@ -78,8 +78,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 

@@ -90,7 +90,9 @@ import InstEnv                ( InstEnv, Instance )
 import FamInstEnv      ( FamInstEnv, FamInst )
 import Rules           ( RuleBase )
 import CoreSyn         ( CoreBind )
 import FamInstEnv      ( FamInstEnv, FamInst )
 import Rules           ( RuleBase )
 import CoreSyn         ( CoreBind )

+import VarEnv

 import VarSet
 import VarSet

+import Var

 import Id
 import Type            ( TyThing(..) )
 
 import Id
 import Type            ( TyThing(..) )
 

@@ -113,7 +115,6 @@ 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 StringBuffer    ( StringBuffer )
 
 import System.Time     ( ClockTime )

@@ -286,16 +287,19 @@ lookupIfaceByModule dflags hpt pit mod
 
 
 \begin{code}
 
 
 \begin{code}

-hptInstances :: HscEnv -> (ModuleName -> Bool) -> [Instance]
--- Find all the instance declarations that are in modules imported 
--- by this one, directly or indirectly, and are in the Home Package Table
--- This ensures that we don't see instances from modules --make compiled 
--- before this one, but which are not below this one
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst])
+-- Find all the instance declarations (of classes and families) that are in
+-- modules imported by this one, directly or indirectly, and are in the Home
+-- Package Table.  This ensures that we don't see instances from modules --make
+-- compiled before this one, but which are not below this one.

 hptInstances hsc_env want_this_module
 hptInstances hsc_env want_this_module

-  = [ ispec 
-    | mod_info <- eltsUFM (hsc_HPT hsc_env)
-    , want_this_module (moduleName (mi_module (hm_iface mod_info)))
-    , ispec <- md_insts (hm_details mod_info) ]
+  = let (insts, famInsts) = unzip
+          [ (md_insts details, md_fam_insts details)
+          | mod_info <- eltsUFM (hsc_HPT hsc_env)
+          , want_this_module (moduleName (mi_module (hm_iface mod_info)))
+          , let details = hm_details mod_info ]
+    in
+    (concat insts, concat famInsts)

 
 hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
 -- Get rules from modules "below" this one (in the dependency sense)
 
 hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
 -- Get rules from modules "below" this one (in the dependency sense)

@@ -327,6 +331,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}
 
 %************************************************************************

@@ -472,10 +485,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,

@@ -483,7 +497,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

@@ -684,19 +700,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}
 
 

@@ -1229,26 +1254,51 @@ 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
+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}
 \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
+      vectInfoCCTyCon   :: NameEnv (TyCon  , TyCon),   -- (T, T_CC) keyed on T
+      vectInfoCCDataCon :: NameEnv (DataCon, DataCon), -- (C, C_CC) keyed on C
+      vectInfoCCIso     :: NameEnv (TyCon  , Var)      -- (T, isoT) keyed on T
+    }
+    -- all of this is always tidy, even in ModGuts

 
 -- ModIface version
 
 -- 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'
+      ifaceVectInfoCCTyCon      :: [Name],
+        -- all tycons in here have a closure-converted variant;
+        -- the name of the CC'ed variant and those of its data constructors are
+        -- determined by `mkCloTyConOcc' and `mkCloDataConOcc'; the names of
+        -- the isomorphisms is determined by `mkCloIsoOcc'
+      ifaceVectInfoCCTyConReuse :: [Name]              
+        -- the closure-converted form of all the tycons in here coincids with
+        -- the unconverted from; the names of the isomorphisms is determined
+        -- by `mkCloIsoOcc'
+    }

 
 noVectInfo :: VectInfo
 
 noVectInfo :: VectInfo

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

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

-  VectInfo (vectInfoCCVar vi1 `unionNameSets` vectInfoCCVar vi2)
+  VectInfo (vectInfoCCVar     vi1 `plusVarEnv`  vectInfoCCVar     vi2)
+           (vectInfoCCTyCon   vi1 `plusNameEnv` vectInfoCCTyCon   vi2)
+           (vectInfoCCDataCon vi1 `plusNameEnv` vectInfoCCDataCon vi2)
+           (vectInfoCCIso     vi1 `plusNameEnv` vectInfoCCIso     vi2)

 
 noIfaceVectInfo :: IfaceVectInfo
 
 noIfaceVectInfo :: IfaceVectInfo

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

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