[project @ 1996-07-15 16:16:46 by partain]

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

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index cdb26cb..4453c10 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -18,22 +18,23 @@ module OccurAnal (
     ) where
 
 IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop)        -- paranoia
 
 import BinderInfo
 import CmdLineOpts     ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
 import Digraph         ( stronglyConnComp )
 import Id              ( idWantsToBeINLINEd, isConstMethodId,
+                         externallyVisibleId,
                          emptyIdSet, unionIdSets, mkIdSet,
                          unitIdSet, elementOfIdSet,
-                         addOneToIdSet, IdSet(..),
+                         addOneToIdSet, SYN_IE(IdSet),
                          nullIdEnv, unitIdEnv, combineIdEnvs,
                          delOneFromIdEnv, delManyFromIdEnv,
-                         mapIdEnv, lookupIdEnv, IdEnv(..),
+                         mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
                          GenId{-instance Eq-}
                        )
 import Maybes          ( maybeToBool )
-import Name            ( isExported )
 import Outputable      ( Outputable(..){-instance * (,) -} )
 import PprCore
 import PprStyle                ( PprStyle(..) )
@@ -43,7 +44,7 @@ import TyVar          ( GenTyVar{-instance Eq-} )
 import Unique          ( Unique{-instance Eq-} )
 import Util            ( assoc, zipEqual, pprTrace, panic )
 
-isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
+isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
 \end{code}
 
 
@@ -137,7 +138,7 @@ tagBinder usage binder
     )
 
 usage_of usage binder
-  | isExported binder = ManyOcc        0 -- Exported things count as many
+  | externallyVisibleId binder = ManyOcc 0 -- Visible-elsewhere things count as many
   | otherwise
   = case (lookupIdEnv usage binder) of
       Nothing   -> DeadCode
@@ -170,7 +171,7 @@ occurAnalyseBinds binds simplifier_sw_chkr
                                     binds'
   | otherwise            = binds'
   where
-    (_, binds') = do initial_env binds
+    (_, binds') = doo initial_env binds
 
     initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
                         (simplifier_sw_chkr KeepSpecPragmaIds)
@@ -178,12 +179,12 @@ occurAnalyseBinds binds simplifier_sw_chkr
                         (simplifier_sw_chkr IgnoreINLINEPragma)
                         emptyIdSet
 
-    do env [] = (emptyDetails, [])
-    do env (bind:binds)
+    doo env [] = (emptyDetails, [])
+    doo env (bind:binds)
       = (final_usage, new_binds ++ the_rest)
       where
        new_env                  = env `addNewCands` (bindersOf bind)
-       (binds_usage, the_rest)  = do new_env binds
+       (binds_usage, the_rest)  = doo new_env binds
        (final_usage, new_binds) = occAnalBind env bind binds_usage
 \end{code}
 
@@ -379,8 +380,27 @@ occAnal env (Var v)
   = (emptyDetails, Var v)
 
 occAnal env (Lit lit)     = (emptyDetails, Lit lit)
-occAnal env (Con con args) = (occAnalArgs env args, Con con args)
 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+\end{code}
+
+We regard variables that occur as constructor arguments as "dangerousToDup":
+
+\begin{verbatim}
+module A where
+f x = let y = expensive x in 
+      let z = (True,y) in 
+      (case z of {(p,q)->q}, case z of {(p,q)->q})
+\end{verbatim}
+
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
+\begin{code}
+occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args), 
+                             Con con args)
 
 occAnal env (SCC cc body)
   = (mapIdEnv markInsideSCC usage, SCC cc body')
@@ -398,12 +418,21 @@ occAnal env (App fun arg)
     (fun_usage, fun') = occAnal    env fun
     arg_usage        = occAnalArg env arg
 
-occAnal env (Lam (ValBinder binder) body)
+-- For value lambdas we do a special hack.  Consider
+--     (\x. \y. ...x...)
+-- If we did nothing, x is used inside the \y, so would be marked
+-- as dangerous to dup.  But in the common case where the abstraction
+-- is applied to two arguments this is over-pessimistic.
+-- So instead we don't take account of the \y when dealing with x's usage;
+-- instead, the simplifier is careful when partially applying lambdas
+
+occAnal env expr@(Lam (ValBinder binder) body)
   = (mapIdEnv markDangerousToDup final_usage,
-     Lam (ValBinder tagged_binder) body')
+     foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
   where
-    (body_usage, body')         = occAnal (env `addNewCand` binder) body
-    (final_usage, tagged_binder) = tagBinder body_usage binder
+    (binders,body)               = collectValBinders expr
+    (body_usage, body')          = occAnal (env `addNewCands` binders) body
+    (final_usage, tagged_binders) = tagBinders body_usage binders
 
 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 occAnal env (Lam (TyBinder tyvar) body)