[project @ 1998-04-07 16:40:08 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplVar.lhs

diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 7ed82de..30b9381 100644 (file)
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -16,13 +16,13 @@ import {-# SOURCE #-} Simplify ( simplExpr )
 import CmdLineOpts     ( switchIsOn, SimplifierSwitch(..) )
 import CoreSyn
 import CoreUnfold      ( Unfolding(..), UnfoldingGuidance(..), 
-                         FormSummary, whnfOrBottom,
+                         FormSummary, whnfOrBottom, okToInline,
                          smallEnoughToInline )
 import CoreUtils       ( coreExprCc )
-import BinderInfo      ( BinderInfo, noBinderInfo, okToInline )
+import BinderInfo      ( BinderInfo, noBinderInfo )
 
 import CostCentre      ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
-import Id              ( idType, getIdInfo, getIdUnfolding, 
+import Id              ( idType, getIdUnfolding, 
                          getIdSpecialisation, setIdSpecialisation,
                          idMustBeINLINEd, idHasNoFreeTyVars,
                          mkIdWithNewUniq, mkIdWithNewType, 
@@ -53,7 +53,7 @@ import Outputable
 This where all the heavy-duty unfolding stuff comes into its own.
 
 \begin{code}
-completeVar env var args result_ty
+completeVar env inline_call var args result_ty
 
   | maybeToBool maybe_magic_result
   = tick MagicUnfold   `thenSmpl_`
@@ -76,7 +76,7 @@ completeVar env var args result_ty
        -- If "essential_unfoldings_only" is true we do no inlinings at all,
        -- EXCEPT for things that absolutely have to be done
        -- (see comments with idMustBeINLINEd)
-    && ok_to_inline
+    && (inline_call || ok_to_inline)
     && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
   =
 {-
@@ -94,6 +94,9 @@ completeVar env var args result_ty
     tickUnfold var             `thenSmpl_`
     simplExpr unf_env unf_template args result_ty
 
+  | inline_call                -- There was an InlineCall note, but we didn't inline!
+  = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
+
   | otherwise
   = returnSmpl (mkGenApp (Var var') args)
 
@@ -135,7 +138,7 @@ completeVar env var args result_ty
     sw_chkr                  = getSwitchChecker env
     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
     is_case_scrutinee        = switchIsOn sw_chkr SimplCaseScrutinee
-    ok_to_inline             = okToInline (whnfOrBottom form) small_enough occ_info 
+    ok_to_inline             = okToInline var (whnfOrBottom form) small_enough occ_info 
     small_enough             = smallEnoughToInline var arg_evals is_case_scrutinee guidance
     arg_evals                = [is_evald arg | arg <- args, isValArg arg]
 
@@ -195,12 +198,16 @@ simplBinder env (id, occ_info)
 
        -- id2 has its SpecEnv zapped
        id2 | isEmptySpecEnv spec_env = id1
-           | otherwise               = setIdSpecialisation id spec_env'
+           | otherwise               = setIdSpecialisation id1 spec_env'
     in
     if not_in_scope then
-       -- No need to clone
+       -- No need to clone, but we *must* zap any current substitution
+       -- for the variable.  For example:
+       --      (\x.e) with id_subst = [x |-> e']
+       -- Here we must simply zap the substitution for x
        let
-           env' = setIdEnv env (new_in_scope_ids id2, id_subst)
+           env' = setIdEnv env (new_in_scope_ids id2, 
+                                delOneFromIdEnv id_subst id)
        in
        returnSmpl (env', id2)
     else
@@ -234,9 +241,12 @@ simplBinders env binders = mapAccumLSmpl simplBinder env binders
 \begin{code}   
 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 simplTyBinder env tyvar
-  | not (tyvar `elementOfTyVarSet` tyvars)     -- No need to clone
-  = let
-       env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
+  | not (tyvar `elementOfTyVarSet` tyvars)
+  =    -- No need to clone; but must zap any binding for tyvar
+       -- see comments with simplBinder above
+    let
+       env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, 
+                            delFromTyVarEnv ty_subst tyvar)
     in
     returnSmpl (env', tyvar)