[project @ 2002-03-18 15:23:05 by simonpj]

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

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 75cce86..b1a4a1a 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -52,7 +52,7 @@ module Id (
        setIdCgInfo,
        setIdOccInfo,
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        idDemandInfo, 
        idStrictness, 
        idCprInfo,
@@ -67,13 +67,13 @@ module Id (
         idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
-       idSpecialisation,
+       idSpecialisation, idCoreRules,
        idCgInfo,
        idCafInfo,
        idLBVarInfo,
        idOccInfo,
 
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
        newStrictnessFromOld    -- Temporary
 #endif
 
@@ -82,7 +82,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,
@@ -101,10 +101,10 @@ import IdInfo
 import qualified Demand        ( Demand )
 import NewDemand       ( Demand, StrictSig, topSig, isBottomingSig )
 import Name            ( Name, OccName,
-                         mkSysLocalName, mkLocalName,
+                         mkSystemName, mkInternalName,
                          getOccName, getSrcLoc
                        ) 
-import OccName         ( UserFS, mkWorkerOcc )
+import OccName         ( EncodedFS, UserFS, mkWorkerOcc )
 import PrimRep         ( PrimRep )
 import TysPrim         ( statePrimTyCon )
 import FieldLabel      ( FieldLabel )
@@ -123,7 +123,7 @@ infixl      1 `setIdUnfolding`,
          `setIdSpecialisation`,
          `setInlinePragma`,
          `idCafInfo`
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
          ,`idCprInfo`
          ,`setIdStrictness`
          ,`setIdDemandInfo`
@@ -160,11 +160,13 @@ mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
 -- SysLocal: for an Id being created by the compiler out of thin air...
 -- UserLocal: an Id with a name the user might recognize...
 mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
-mkSysLocal  :: UserFS  -> Unique -> Type -> Id
+mkSysLocal  :: EncodedFS  -> Unique -> Type -> Id
 mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
 
-mkSysLocal  fs uniq ty      = mkLocalId (mkSysLocalName uniq fs)      ty
-mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName    uniq occ loc) ty
+-- 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 (mkSystemName uniq fs)      ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName    uniq occ loc) ty
 mkVanillaGlobal            = mkGlobalId VanillaGlobal
 \end{code}
 
@@ -175,14 +177,14 @@ instantiated before use.
 \begin{code}
 -- "Wild Id" typically used when you need a binder that you don't expect to use
 mkWildId :: Type -> Id
-mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
+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]
@@ -193,7 +195,7 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id]
 mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
 
 mkTemplateLocal :: Int -> Type -> Id
-mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
+mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
 \end{code}
 
 
@@ -321,7 +323,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
@@ -371,7 +373,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
@@ -392,13 +394,16 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
 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
@@ -412,7 +417,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
@@ -421,7 +426,7 @@ idCafInfo id = cgCafInfo (idCgInfo id)
 #endif
        ---------------------------------
        -- CPR INFO
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
 idCprInfo :: Id -> CprInfo
 idCprInfo id = cprInfo (idInfo id)