New flag -dsuppress-coercions to avoid printing coercions in Core dumps

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

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 2a068d9..7551494 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -304,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 = []
@@ -549,14 +549,13 @@ type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
   -- Bool => expose unfolding or not.
 
 chooseExternalIds :: HscEnv
-                  -> TypeEnv
                   -> Module
                   -> Bool
                  -> [CoreBind]
                   -> 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
   = do
     (unfold_env1,occ_env1) 
         <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env
@@ -578,12 +577,12 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
 
   binders = bindersOfBinds 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,
                                 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,12 +608,18 @@ chooseExternalIds hsc_env type_env mod omit_prags binds
 
   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
-      (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 
-          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
@@ -636,7 +641,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
 
@@ -768,7 +774,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