[project @ 2002-07-16 12:05:37 by simonmar]

[ghc-hetmet.git] / ghc / compiler / basicTypes / Id.lhs

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 52b05e1..45b8b42 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -46,13 +46,12 @@ module Id (
        setIdArity,
        setIdNewDemandInfo, 
        setIdNewStrictness, zapIdNewStrictness,
-        setIdTyGenInfo,
        setIdWorkerInfo,
        setIdSpecialisation,
        setIdCgInfo,
        setIdOccInfo,
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        idDemandInfo, 
        idStrictness, 
        idCprInfo,
@@ -62,18 +61,17 @@ module Id (
 #endif
 
        idArity, 
-       idNewDemandInfo,
+       idNewDemandInfo, idNewDemandInfo_maybe,
        idNewStrictness, idNewStrictness_maybe, 
-        idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
-       idSpecialisation,
+       idSpecialisation, idCoreRules,
        idCgInfo,
        idCafInfo,
        idLBVarInfo,
        idOccInfo,
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        newStrictnessFromOld    -- Temporary
 #endif
 
@@ -82,7 +80,7 @@ module Id (
 #include "HsVersions.h"
 
 
-import CoreSyn         ( Unfolding, CoreRules )
+import CoreSyn         ( Unfolding, CoreRules, IdCoreRule, rulesRules )
 import BasicTypes      ( Arity )
 import Var             ( Id, DictId,
                          isId, isExportedId, isSpecPragmaId, isLocalId,
@@ -99,12 +97,12 @@ import Type         ( Type, typePrimRep, addFreeTyVars,
 import IdInfo 
 
 import qualified Demand        ( Demand )
-import NewDemand       ( Demand, StrictSig, topSig, isBottomingSig )
+import NewDemand       ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
 import Name            ( Name, OccName,
-                         mkSysLocalName, mkLocalName,
+                         mkSystemName, mkInternalName,
                          getOccName, getSrcLoc
                        ) 
-import OccName         ( EncodedFS, UserFS, mkWorkerOcc )
+import OccName         ( EncodedFS, mkWorkerOcc )
 import PrimRep         ( PrimRep )
 import TysPrim         ( statePrimTyCon )
 import FieldLabel      ( FieldLabel )
@@ -118,12 +116,11 @@ infixl    1 `setIdUnfolding`,
          `setIdArity`,
          `setIdNewDemandInfo`,
          `setIdNewStrictness`,
-         `setIdTyGenInfo`,
          `setIdWorkerInfo`,
          `setIdSpecialisation`,
          `setInlinePragma`,
          `idCafInfo`
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
          ,`idCprInfo`
          ,`setIdStrictness`
          ,`setIdDemandInfo`
@@ -165,8 +162,8 @@ mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
 
 -- for SysLocal, we assume the base name is already encoded, to avoid
 -- re-encoding the same string over and over again.
-mkSysLocal  fs uniq ty      = mkLocalId (mkSysLocalName uniq fs)      ty
-mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName    uniq occ loc) ty
+mkSysLocal  fs uniq ty      = mkLocalId (mkSystemName uniq fs)      ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName    uniq occ loc) ty
 mkVanillaGlobal            = mkGlobalId VanillaGlobal
 \end{code}
 
@@ -180,11 +177,11 @@ mkWildId :: Type -> Id
 mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
 
 mkWorkerId :: Unique -> Id -> Type -> Id
--- A worker gets a local name.  CoreTidy will globalise it if necessary.
+-- A worker gets a local name.  CoreTidy will externalise it if necessary.
 mkWorkerId uniq unwrkr ty
   = mkLocalId wkr_name ty
   where
-    wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
+    wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
 
 -- "Template locals" typically used in unfoldings
 mkTemplateLocals :: [Type] -> [Id]
@@ -323,7 +320,7 @@ idArity id = arityInfo (idInfo id)
 setIdArity :: Id -> Arity -> Id
 setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        ---------------------------------
        -- (OLD) STRICTNESS 
 idStrictness :: Id -> StrictnessInfo
@@ -350,14 +347,6 @@ zapIdNewStrictness :: Id -> Id
 zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
 
        ---------------------------------
-       -- TYPE GENERALISATION
-idTyGenInfo :: Id -> TyGenInfo
-idTyGenInfo id = tyGenInfo (idInfo id)
-
-setIdTyGenInfo :: Id -> TyGenInfo -> Id
-setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
-
-       ---------------------------------
        -- WORKER ID
 idWorkerInfo :: Id -> WorkerInfo
 idWorkerInfo id = workerInfo (idInfo id)
@@ -373,7 +362,7 @@ idUnfolding id = unfoldingInfo (idInfo id)
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        ---------------------------------
        -- (OLD) DEMAND
 idDemandInfo :: Id -> Demand.Demand
@@ -383,24 +372,30 @@ setIdDemandInfo :: Id -> Demand.Demand -> Id
 setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
 #endif
 
-idNewDemandInfo :: Id -> NewDemand.Demand
-idNewDemandInfo id = newDemandInfo (idInfo id)
+idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
+idNewDemandInfo       :: Id -> NewDemand.Demand
+
+idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
+idNewDemandInfo       id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
 
 setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
-setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
 
        ---------------------------------
        -- SPECIALISATION
 idSpecialisation :: Id -> CoreRules
 idSpecialisation id = specInfo (idInfo id)
 
+idCoreRules :: Id -> [IdCoreRule]
+idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+
 setIdSpecialisation :: Id -> CoreRules -> Id
 setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
 
        ---------------------------------
        -- CG INFO
 idCgInfo :: Id -> CgInfo
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
 idCgInfo id = case cgInfo (idInfo id) of
                  NoCgInfo -> pprPanic "idCgInfo" (ppr id)
                  info     -> info
@@ -414,7 +409,7 @@ setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
        ---------------------------------
        -- CAF INFO
 idCafInfo :: Id -> CafInfo
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
 idCafInfo id = case cgInfo (idInfo id) of
                  NoCgInfo -> pprPanic "idCafInfo" (ppr id)
                  info     -> cgCafInfo info
@@ -423,7 +418,7 @@ idCafInfo id = cgCafInfo (idCgInfo id)
 #endif
        ---------------------------------
        -- CPR INFO
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
 idCprInfo :: Id -> CprInfo
 idCprInfo id = cprInfo (idInfo id)