Tidy VectInfo in tidyProgram

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

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index ebe196b..88a3059 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -29,7 +29,7 @@ import IdInfo
 import InstEnv
 import NewDemand
 import BasicTypes
 import InstEnv
 import NewDemand
 import BasicTypes

-import Name
+import Name hiding (varName)

 import NameSet
 import IfaceEnv
 import NameEnv
 import NameSet
 import IfaceEnv
 import NameEnv

@@ -50,8 +50,9 @@ import Data.IORef     ( IORef, readIORef, writeIORef )
 \end{code}
 
 
 \end{code}
 
 

-Constructing the TypeEnv, Instances, Rules from which the ModIface is
-constructed, and which goes on to subsequent modules in --make mode.
+Constructing the TypeEnv, Instances, Rules, VectInfo from which the
+ModIface is constructed, and which goes on to subsequent modules in
+--make mode.

 
 Most of the interface file is obtained simply by serialising the
 TypeEnv.  One important consequence is that if the *interface file*
 
 Most of the interface file is obtained simply by serialising the
 TypeEnv.  One important consequence is that if the *interface file*

@@ -207,6 +208,10 @@ Step 1: Figure out external Ids
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Note [choosing external names]
 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Note [choosing external names]
 

+See also the section "Interface stability" in the
+RecompilationAvoidance commentary:
+  http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+

 First we figure out which Ids are "external" Ids.  An
 "external" Id is one that is visible from outside the compilation
 unit.  These are
 First we figure out which Ids are "external" Ids.  An
 "external" Id is one that is visible from outside the compilation
 unit.  These are

@@ -299,8 +304,10 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
              ; th         = dopt Opt_TemplateHaskell      dflags
               }
 
              ; th         = dopt Opt_TemplateHaskell      dflags
               }
 

+       ; let { implicit_binds = getImplicitBinds type_env }
+

         ; (unfold_env, tidy_occ_env)
         ; (unfold_env, tidy_occ_env)

-              <- chooseExternalIds hsc_env type_env mod omit_prags binds
+              <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds

 
         ; let { ext_rules 
                   | omit_prags = []
 
         ; let { ext_rules 
                   | omit_prags = []

@@ -333,8 +340,9 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                -- and indeed it does, but if omit_prags is on, ext_rules is
                -- empty
 
                -- and indeed it does, but if omit_prags is on, ext_rules is
                -- empty
 

+              ; tidy_vect_info = tidyVectInfo tidy_env vect_info
+

              -- See Note [Injecting implicit bindings]
              -- See Note [Injecting implicit bindings]

-             ; implicit_binds = getImplicitBinds type_env

              ; all_tidy_binds = implicit_binds ++ tidy_binds
 
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
              ; all_tidy_binds = implicit_binds ++ tidy_binds
 
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)

@@ -359,10 +367,9 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                   ModDetails { md_types     = tidy_type_env,
                                md_rules     = tidy_rules,
                                md_insts     = tidy_insts,
                   ModDetails { md_types     = tidy_type_env,
                                md_rules     = tidy_rules,
                                md_insts     = tidy_insts,

-                               md_fam_insts = fam_insts,
+                                md_vect_info = tidy_vect_info,                                                  md_fam_insts = fam_insts,

                                md_exports   = exports,
                                md_exports   = exports,

-                               md_anns      = anns,     -- are already tidy
-                                md_vect_info = vect_info --
+                               md_anns      = anns      -- are already tidy

                               })
        }
 
                               })
        }
 

@@ -471,6 +478,29 @@ tidyInstances tidy_dfun ispecs
                 tidy_dfun (instanceDFunId ispec)
 \end{code}
 
                 tidy_dfun (instanceDFunId ispec)
 \end{code}
 

+\begin{code}
+tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
+tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar     = vars
+                                         , vectInfoPADFun  = pas
+                                         , vectInfoIso     = isos })
+  = info { vectInfoVar    = tidy_vars
+         , vectInfoPADFun = tidy_pas
+         , vectInfoIso    = tidy_isos }
+  where
+    tidy_vars = mkVarEnv
+              $ map tidy_var_mapping
+              $ varEnvElts vars
+
+    tidy_pas = mapNameEnv tidy_snd_var pas
+    tidy_isos = mapNameEnv tidy_snd_var isos
+
+    tidy_var_mapping (from, to) = (from', (from', lookup_var to))
+      where from' = lookup_var from
+    tidy_snd_var (x, var) = (x, lookup_var var)
+      
+    lookup_var var = lookupWithDefaultVarEnv var_env var var
+\end{code}
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -491,6 +521,11 @@ why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of
 optimisation first.  (Only matters when the selector is used curried;
 eg map x ys.)  See Trac #2070.
 
 optimisation first.  (Only matters when the selector is used curried;
 eg map x ys.)  See Trac #2070.
 

+[Oct 09: in fact, record selectors are no longer implicit Ids at all,
+because we really do want to optimise them properly. They are treated
+much like any other Id.  But doing "light" optimisation on an implicit
+Id still makes sense.]
+

 At one time I tried injecting the implicit bindings *early*, at the
 beginning of SimplCore.  But that gave rise to real difficulty,
 becuase GlobalIds are supposed to have *fixed* IdInfo, but the
 At one time I tried injecting the implicit bindings *early*, at the
 beginning of SimplCore.  But that gave rise to real difficulty,
 becuase GlobalIds are supposed to have *fixed* IdInfo, but the

@@ -501,18 +536,23 @@ importing modules were expecting it to have arity 1 (Trac #2844).
 It's much safer just to inject them right at the end, after tidying.
 
 Oh: two other reasons for injecting them late:
 It's much safer just to inject them right at the end, after tidying.
 
 Oh: two other reasons for injecting them late:

+

   - If implicit Ids are already in the bindings when we start TidyPgm,
     we'd have to be careful not to treat them as external Ids (in
     the sense of findExternalIds); else the Ids mentioned in *their*
     RHSs will be treated as external and you get an interface file 
     saying      a18 = <blah>
     but nothing refererring to a18 (because the implicit Id is the 
   - If implicit Ids are already in the bindings when we start TidyPgm,
     we'd have to be careful not to treat them as external Ids (in
     the sense of findExternalIds); else the Ids mentioned in *their*
     RHSs will be treated as external and you get an interface file 
     saying      a18 = <blah>
     but nothing refererring to a18 (because the implicit Id is the 

-    one that does).
+    one that does, and implicit Ids don't appear in interface files).

 
   - More seriously, the tidied type-envt will include the implicit
     Id replete with a18 in its unfolding; but we won't take account
     of a18 when computing a fingerprint for the class; result chaos.
     
 
   - More seriously, the tidied type-envt will include the implicit
     Id replete with a18 in its unfolding; but we won't take account
     of a18 when computing a fingerprint for the class; result chaos.
     

+There is one sort of implicit binding that is injected still later,
+namely those for data constructor workers. Reason (I think): it's
+really just a code generation trick.... binding itself makes no sense.
+See CorePrep Note [Data constructor workers].

 
 \begin{code}
 getImplicitBinds :: TypeEnv -> [CoreBind]
 
 \begin{code}
 getImplicitBinds :: TypeEnv -> [CoreBind]

@@ -545,14 +585,14 @@ type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
   -- Bool => expose unfolding or not.
 
 chooseExternalIds :: HscEnv
   -- Bool => expose unfolding or not.
 
 chooseExternalIds :: HscEnv

-                  -> TypeEnv

                   -> Module
                   -> Bool
                  -> [CoreBind]
                   -> Module
                   -> Bool
                  -> [CoreBind]

+                  -> [CoreBind]

                   -> IO (UnfoldEnv, TidyOccEnv)
        -- Step 1 from the notes above
 
                   -> IO (UnfoldEnv, TidyOccEnv)
        -- Step 1 from the notes above
 

-chooseExternalIds hsc_env type_env mod omit_prags binds 
+chooseExternalIds hsc_env mod omit_prags binds implicit_binds

   = do
     (unfold_env1,occ_env1) 
         <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env
   = do
     (unfold_env1,occ_env1) 
         <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env

@@ -573,19 +613,22 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
                      filter isExportedId binders
 
   binders = bindersOfBinds binds
                      filter isExportedId binders
 
   binders = bindersOfBinds binds

+  implicit_binders = bindersOfBinds implicit_binds

 
 

-  bind_env :: IdEnv CoreExpr
-  bind_env = mkVarEnv (flattenBinds binds)
+  bind_env :: IdEnv (Id,CoreExpr)
+  bind_env = mkVarEnv (zip (map fst bs) bs) where bs = flattenBinds binds

 
 

-  avoids   = [getOccName name | bndr <- typeEnvIds type_env,
+  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,

                                 let name = idName bndr,
                                 let name = idName bndr,

-                                isExternalName name]
+                                isExternalName name ]

                -- In computing our "avoids" list, we must include
                --      all implicit Ids
                --      all things with global names (assigned once and for
                --                                      all by the renamer)
                -- since their names are "taken".
                -- The type environment is a convenient source of such things.
                -- In computing our "avoids" list, we must include
                --      all implicit Ids
                --      all things with global names (assigned once and for
                --                                      all by the renamer)
                -- since their names are "taken".
                -- The type environment is a convenient source of such things.

+                -- In particular, the set of binders doesn't include
+                -- implicit Ids at this stage.

 
        -- We also make sure to avoid any exported binders.  Consider
        --      f{-u1-} = 1     -- Local decl
 
        -- We also make sure to avoid any exported binders.  Consider
        --      f{-u1-} = 1     -- Local decl

@@ -605,12 +648,18 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
 
   search [] unfold_env occ_env = return (unfold_env, occ_env)
 
 
   search [] unfold_env occ_env = return (unfold_env, occ_env)
 

-  search ((id,referrer) : rest) unfold_env occ_env
-    | id `elemVarEnv` unfold_env = search rest unfold_env occ_env
+  search ((idocc,referrer) : rest) unfold_env occ_env
+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env

     | otherwise = do
     | otherwise = do

-      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env id
+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc

       let 
       let 

-          rhs = expectJust "chooseExternalIds" $ lookupVarEnv bind_env id
+          (id, rhs) = expectJust (showSDoc (text "chooseExternalIds: " <>
+                                            ppr idocc)) $
+                                 lookupVarEnv bind_env idocc
+          -- NB. idocc might be an *occurrence* of an Id, whereas we want
+          -- the Id from the binding site, because only the latter is
+          -- guaranteed to have the unfolding attached.  This is why we
+          -- keep binding site Ids in the bind_env.

           (new_ids, show_unfold)
                 | omit_prags = ([], False)
                 | otherwise  = addExternal id rhs
           (new_ids, show_unfold)
                 | omit_prags = ([], False)
                 | otherwise  = addExternal id rhs

@@ -632,7 +681,8 @@ addExternal :: Id -> CoreExpr -> ([Id],Bool)
 addExternal id rhs = (new_needed_ids, show_unfold)
   where
     new_needed_ids = unfold_ids ++
 addExternal id rhs = (new_needed_ids, show_unfold)
   where
     new_needed_ids = unfold_ids ++

-                     filter (not . (`elemVarSet` unfold_set)) 
+                     filter (\id -> isLocalId id &&
+                                    not (id `elemVarSet` unfold_set))

                        (varSetElems worker_ids ++ 
                         varSetElems spec_ids) -- XXX non-det ordering
 
                        (varSetElems worker_ids ++ 
                         varSetElems spec_ids) -- XXX non-det ordering
 

@@ -764,7 +814,21 @@ tidyTopName mod nc_var maybe_ref occ_env id
     new_occ
       | Just ref <- maybe_ref, ref /= id = 
           mkOccName (occNameSpace old_occ) $
     new_occ
       | Just ref <- maybe_ref, ref /= id = 
           mkOccName (occNameSpace old_occ) $

-             occNameString (getOccName ref) ++ '_' : occNameString old_occ
+             let
+                 ref_str = occNameString (getOccName ref)
+                 occ_str = occNameString old_occ
+             in
+             case occ_str of
+               '$':'w':_ -> occ_str
+                  -- workers: the worker for a function already
+                  -- includes the occname for its parent, so there's
+                  -- no need to prepend the referrer.
+               _other | isSystemName name -> ref_str
+                      | otherwise         -> ref_str ++ '_' : occ_str
+                  -- If this name was system-generated, then don't bother
+                  -- to retain its OccName, just use the referrer.  These
+                  -- system-generated names will become "f1", "f2", etc. for
+                  -- a referrer "f".

       | otherwise = old_occ
 
     (occ_env', occ') = tidyOccName occ_env new_occ
       | otherwise = old_occ
 
     (occ_env', occ') = tidyOccName occ_env new_occ