Change the representation of the package database

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

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index ff7eafd..d198a3f 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -207,6 +207,10 @@ Step 1: Figure out external Ids
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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
@@ -300,7 +304,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
               }
 
         ; (unfold_env, tidy_occ_env)
-              <- chooseExternalIds hsc_env type_env mod omit_prags binds
+              <- chooseExternalIds hsc_env mod omit_prags binds
 
         ; let { ext_rules 
                   | omit_prags = []
@@ -538,20 +542,20 @@ Sete Note [choosing external names].
 
 \begin{code}
 type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
+  -- maps each top-level Id to its new Name (the Id is tidied in step 2)
+  -- The Unique is unchanged.  If the new Id is external, it will be
+  -- visible in the interface file.  
+  --
+  -- Bool => expose unfolding or not.
 
 chooseExternalIds :: HscEnv
-                  -> TypeEnv
                   -> Module
                   -> Bool
                  -> [CoreBind]
                   -> IO (UnfoldEnv, TidyOccEnv)
-                     -- maps top-level Ids to new, renamed, Ids.
-                     -- If the new Id is external, it will be visible
-                     -- in the interface file. 
-                     -- Bool => expose unfolding or not.
        -- Step 1 from the notes above
 
-chooseExternalIds hsc_env type_env mod omit_prags binds 
+chooseExternalIds hsc_env mod omit_prags binds
   = do
     (unfold_env1,occ_env1) 
         <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env
@@ -576,9 +580,9 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
   bind_env :: IdEnv CoreExpr
   bind_env = mkVarEnv (flattenBinds binds)
 
-  avoids   = [getOccName name | bndr <- typeEnvIds type_env,
+  avoids   = [getOccName name | bndr <- binders,
                                 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
@@ -609,7 +613,7 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
     | otherwise = do
       (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env id
       let 
-          rhs = expectJust "chooseExternalIds" $ lookupVarEnv bind_env id
+          rhs = expectJust (showSDoc (text "chooseExternalIds: " <> ppr id)) $ lookupVarEnv bind_env id
           (new_ids, show_unfold)
                 | omit_prags = ([], False)
                 | otherwise  = addExternal id rhs
@@ -631,7 +635,8 @@ addExternal :: Id -> CoreExpr -> ([Id],Bool)
 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
 
@@ -763,7 +768,21 @@ tidyTopName mod nc_var maybe_ref occ_env id
     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
@@ -860,16 +879,16 @@ tidyTopBind  :: PackageId
              -> CoreBind
             -> (TidyEnv, CoreBind)
 
-tidyTopBind this_pkg unfold_env (occ_env1,subst1) (NonRec bndr rhs)
+tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
     caf_info      = hasCafRefs this_pkg subst1 (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
-    tidy_env2     = (occ_env1, subst2)
+    tidy_env2     = (occ_env, subst2)
 
-tidyTopBind this_pkg unfold_env (occ_env1,subst1) (Rec prs)
+tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
     prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs)
@@ -879,7 +898,7 @@ tidyTopBind this_pkg unfold_env (occ_env1,subst1) (Rec prs)
            ]
 
     subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
-    tidy_env2 = (occ_env1, subst2)
+    tidy_env2 = (occ_env, subst2)
 
     bndrs = map fst prs