[project @ 1998-04-30 18:47:08 by sof]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 3a1af2f..62d57cf 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -13,7 +13,8 @@ module CoreUtils (
        
        maybeErrorApp,
        nonErrorRHSs,
-       squashableDictishCcExpr
+       squashableDictishCcExpr,
+       idSpecVars
     ) where
 
 #include "HsVersions.h"
@@ -21,8 +22,9 @@ module CoreUtils (
 import CoreSyn
 
 import CostCentre      ( isDictCC, CostCentre, noCostCentre )
-import Id              ( idType, mkSysLocal, isBottomingId,
-                         toplevelishId, mkIdWithNewUniq,
+import MkId            ( mkSysLocal )
+import Id              ( idType, isBottomingId, getIdSpecialisation,
+                         mkIdWithNewUniq,
                          dataConRepType,
                          addOneToIdEnv, growIdEnvList, lookupIdEnv,
                          isNullIdEnv, IdEnv, Id
@@ -31,6 +33,7 @@ import Literal                ( literalType, Literal(..) )
 import Maybes          ( catMaybes, maybeToBool )
 import PprCore
 import PrimOp          ( primOpType, PrimOp(..) )
+import SpecEnv         ( specEnvValues )
 import SrcLoc          ( noSrcLoc )
 import TyVar           ( cloneTyVar,
                          isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
@@ -67,10 +70,10 @@ coreExprType (Var var) = idType   var
 coreExprType (Lit lit) = literalType lit
 
 coreExprType (Let _ body)      = coreExprType body
-coreExprType (SCC _ expr)      = coreExprType expr
 coreExprType (Case _ alts)     = coreAltsType alts
 
-coreExprType (Coerce _ ty _)   = ty -- that's the whole point!
+coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note other_note e)    = coreExprType e
 
 -- a Con is a fully-saturated application of a data constructor
 -- a Prim is <ditto> of a PrimOp
@@ -145,9 +148,10 @@ It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 
 \begin{code}
 coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
-coreExprCc (SCC cc e) = cc
-coreExprCc (Lam _ e)  = coreExprCc e
-coreExprCc other      = noCostCentre
+coreExprCc (Note (SCC cc) e)   = cc
+coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Lam _ e)           = coreExprCc e
+coreExprCc other               = noCostCentre
 \end{code}
 
 %************************************************************************
@@ -242,8 +246,7 @@ bop_expr f (Con con args)    = Con con args
 bop_expr f (Prim op args)    = Prim op args
 bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
 bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
-bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
-bop_expr f (Coerce c ty e)   = Coerce c ty (bop_expr f e)
+bop_expr f (Note note expr)  = Note note (bop_expr f expr)
 bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
 bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
 
@@ -410,3 +413,22 @@ squashableDictishCcExpr cc expr
       | notValArg a        = squashable f
     squashable other       = False
 \end{code}
+
+
+Given an Id, idSpecVars returns all its specialisations.
+We extract these from its SpecEnv.
+This is used by the occurrence analyser and free-var finder;
+we regard an Id's specialisations as free in the Id's definition.
+
+\begin{code}
+idSpecVars :: Id -> [Id]
+idSpecVars id 
+  = map get_spec (specEnvValues (getIdSpecialisation id))
+  where
+    -- get_spec is another cheapo function like dictRhsFVs
+    -- It knows what these specialisation temlates look like,
+    -- and just goes for the jugular
+    get_spec (App f _) = get_spec f
+    get_spec (Lam _ b) = get_spec b
+    get_spec (Var v)   = v
+\end{code}