[project @ 1998-03-20 11:44:30 by simonpj]

Fix bug in mkIdWithNewUniq

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index f8c92bc..cb8b1a1 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -233,7 +233,7 @@ mkVanillaId name ty info
        idInfo = info}
 
 mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq id uniq = id {idUnique = uniq}
+mkIdWithNewUniq id uniq = id {idUnique = uniq, idName = changeUnique (idName id) uniq}
 
 mkIdWithNewName :: Id -> Name -> Id
 mkIdWithNewName id new_name
@@ -562,7 +562,7 @@ getIdDemandInfo id = demandInfo (idInfo id)
 addIdDemandInfo :: Id -> DemandInfo -> Id
 addIdDemandInfo id@(Id {idInfo = info}) demand_info
   = id {idInfo = demand_info `setDemandInfo` info}
-\end{code}
+\end{code}p
 
 \begin{code}
 getIdUpdateInfo :: Id -> UpdateInfo

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 6449cda..5d285ff 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -40,7 +40,7 @@ import Constants      ( uNFOLDING_CHEAP_OP_COST,
                          uNFOLDING_DEAR_OP_COST,
                          uNFOLDING_NOREP_LIT_COST
                        )
-import BinderInfo      ( BinderInfo, isOneSameSCCFunOcc,
+import BinderInfo      ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
                          isInlinableOcc, isOneSafeFunOcc
                        )
 import CoreSyn
@@ -538,5 +538,11 @@ okToInline id _ _ _                -- Check the Id first
   | idWantsToBeINLINEd id = True
   | idMustNotBeINLINEd id = False
 
-okToInline id whnf small binder_info = isInlinableOcc whnf small binder_info
+okToInline id whnf small binder_info 
+#ifdef DEBUG
+  | isDeadOcc binder_info
+  = pprTrace "okToInline: dead" (ppr id) False
+  | otherwise
+#endif
+  = isInlinableOcc whnf small binder_info
 \end{code}

diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index c7d3313..0e80f1e 100644 (file)
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -610,12 +610,13 @@ simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
             info_from_this_case rhs_c
   = simplBinder env binder     `thenSmpl` \ (env1, binder') ->
     let
-      env2    = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
+      env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
 
        -- Add form details for the default binder
-      scrut_info = lookupUnfolding env scrut_var
-      env3       = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
-      new_env    = extendEnvGivenNewRhs env3 scrut_var (Var binder')
+      scrut_unf = lookupUnfolding env scrut_var
+      new_env   = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
+                       -- Use noBinderInfo rather than occ_info because we've
+                       -- added more occurrences by binding the scrut_var to it
     in
     rhs_c new_env rhs                  `thenSmpl` \ rhs' ->
     returnSmpl (BindDefault binder' rhs')

diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 7f81320..95bd9c8 100644 (file)
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -441,8 +441,7 @@ extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subs
                      out_id occ_info rhs_info
   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
   where
-    new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id 
-                                 (out_id, occ_info, rhs_info)
+    new_in_scope_ids = addToUFM in_scope_ids out_id (out_id, occ_info, rhs_info)
 \end{code}