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]
 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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

@@ -300,7 +304,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
               }
 
         ; (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

 
         ; let { ext_rules 
                   | omit_prags = []
 
         ; 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-})
 
 \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
 
 chooseExternalIds :: HscEnv

-                  -> TypeEnv

                   -> Module
                   -> Bool
                  -> [CoreBind]
                   -> IO (UnfoldEnv, TidyOccEnv)
                   -> 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
 
        -- 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
   = 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)
 
   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,
                                 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
                -- 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 
     | 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
           (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 ++
 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
 

@@ -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) $
     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

@@ -860,16 +879,16 @@ tidyTopBind  :: PackageId
              -> CoreBind
             -> (TidyEnv, CoreBind)
 
              -> 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,  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)
   = (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')
            ]
 
     subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')

-    tidy_env2 = (occ_env1, subst2)
+    tidy_env2 = (occ_env, subst2)

 
     bndrs = map fst prs
 
 
     bndrs = map fst prs