[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 9047cd7..b1a4a1a 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -44,36 +44,45 @@ module Id (
        -- IdInfo stuff
        setIdUnfolding,
        setIdArity,
-       setIdDemandInfo, setIdNewDemandInfo, 
-       setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
+       setIdNewDemandInfo, 
+       setIdNewStrictness, zapIdNewStrictness,
         setIdTyGenInfo,
        setIdWorkerInfo,
        setIdSpecialisation,
        setIdCgInfo,
-       setIdCprInfo,
        setIdOccInfo,
 
+#ifdef OLD_STRICTNESS
+       idDemandInfo, 
+       idStrictness, 
+       idCprInfo,
+       setIdStrictness, 
+       setIdDemandInfo, 
+       setIdCprInfo,
+#endif
+
        idArity, 
-       idDemandInfo, idNewDemandInfo,
-       idStrictness, idNewStrictness, idNewStrictness_maybe, 
+       idNewDemandInfo,
+       idNewStrictness, idNewStrictness_maybe, 
         idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
-       idSpecialisation,
+       idSpecialisation, idCoreRules,
        idCgInfo,
        idCafInfo,
-       idCprInfo,
        idLBVarInfo,
        idOccInfo,
 
+#ifdef OLD_STRICTNESS
        newStrictnessFromOld    -- Temporary
+#endif
 
     ) where
 
 #include "HsVersions.h"
 
 
-import CoreSyn         ( Unfolding, CoreRules )
+import CoreSyn         ( Unfolding, CoreRules, IdCoreRule, rulesRules )
 import BasicTypes      ( Arity )
 import Var             ( Id, DictId,
                          isId, isExportedId, isSpecPragmaId, isLocalId,
@@ -92,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 )
@@ -104,20 +113,21 @@ import SrcLoc             ( SrcLoc )
 import Outputable
 import Unique          ( Unique, mkBuiltinUnique )
 
+-- infixl so you can say (id `set` a `set` b)
 infixl         1 `setIdUnfolding`,
          `setIdArity`,
-         `setIdDemandInfo`,
-         `setIdStrictness`,
          `setIdNewDemandInfo`,
          `setIdNewStrictness`,
          `setIdTyGenInfo`,
          `setIdWorkerInfo`,
          `setIdSpecialisation`,
          `setInlinePragma`,
-         `idCafInfo`,
-         `idCprInfo`
-
-       -- infixl so you can say (id `set` a `set` b)
+         `idCafInfo`
+#ifdef OLD_STRICTNESS
+         ,`idCprInfo`
+         ,`setIdStrictness`
+         ,`setIdDemandInfo`
+#endif
 \end{code}
 
 
@@ -150,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}
 
@@ -165,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]
@@ -183,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}
 
 
@@ -311,13 +323,15 @@ idArity id = arityInfo (idInfo id)
 setIdArity :: Id -> Arity -> Id
 setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
+#ifdef OLD_STRICTNESS
        ---------------------------------
-       -- STRICTNESS 
+       -- (OLD) STRICTNESS 
 idStrictness :: Id -> StrictnessInfo
 idStrictness id = strictnessInfo (idInfo id)
 
 setIdStrictness :: Id -> StrictnessInfo -> Id
 setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
+#endif
 
 -- isBottomingId returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
@@ -359,13 +373,15 @@ idUnfolding id = unfoldingInfo (idInfo id)
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
+#ifdef OLD_STRICTNESS
        ---------------------------------
-       -- DEMAND
+       -- (OLD) DEMAND
 idDemandInfo :: Id -> Demand.Demand
 idDemandInfo id = demandInfo (idInfo id)
 
 setIdDemandInfo :: Id -> Demand.Demand -> Id
 setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+#endif
 
 idNewDemandInfo :: Id -> NewDemand.Demand
 idNewDemandInfo id = newDemandInfo (idInfo id)
@@ -378,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
@@ -398,21 +417,22 @@ 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
 #else
 idCafInfo id = cgCafInfo (idCgInfo id)
 #endif
-
        ---------------------------------
        -- CPR INFO
+#ifdef OLD_STRICTNESS
 idCprInfo :: Id -> CprInfo
 idCprInfo id = cprInfo (idInfo id)
 
 setIdCprInfo :: Id -> CprInfo -> Id
 setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+#endif
 
        ---------------------------------
        -- Occcurrence INFO