[project @ 2005-03-08 09:47:01 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 0a34d27..63ef83f 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -15,11 +15,11 @@ module Id (
 
        -- Taking an Id apart
        idName, idType, idUnique, idInfo,
-       idPrimRep, isId, globalIdDetails,
+       isId, globalIdDetails, idPrimRep,
        recordSelectorFieldLabel,
 
        -- Modifying an Id
-       setIdName, setIdUnique, Id.setIdType, setIdLocalExported, 
+       setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, 
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
        zapLamIdInfo, zapDemandIdInfo, 
 
@@ -38,7 +38,8 @@ module Id (
 
 
        -- One shot lambda stuff
-       isOneShotBndr, isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+       isOneShotBndr, isOneShotLambda, isStateHackType,
+       setOneShotLambda, clearOneShotLambda,
 
        -- IdInfo stuff
        setIdUnfolding,
@@ -78,18 +79,21 @@ module Id (
 #include "HsVersions.h"
 
 
-import CoreSyn         ( Unfolding, CoreRules, IdCoreRule, rulesRules )
+import CoreSyn         ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
 import BasicTypes      ( Arity )
 import Var             ( Id, DictId,
                          isId, isExportedId, isSpecPragmaId, isLocalId,
                          idName, idType, idUnique, idInfo, isGlobalId,
-                         setIdName, setIdType, setIdUnique, setIdLocalExported,
+                         setIdName, setIdType, setIdUnique, 
+                         setIdExported, setIdNotExported,
                          setIdInfo, lazySetIdInfo, modifyIdInfo, 
                          maybeModifyIdInfo,
                          globalIdDetails
                        )
 import qualified Var   ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
-import Type            ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+import TyCon           ( FieldLabel, TyCon )
+import Type            ( Type, typePrimRep, addFreeTyVars, seqType, 
+                         splitTyConApp_maybe, PrimRep )
 import TysPrim         ( statePrimTyCon )
 import IdInfo 
 
@@ -99,13 +103,11 @@ import qualified Demand    ( Demand )
 import DataCon         ( isUnboxedTupleCon )
 import NewDemand       ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
 import Name            ( Name, OccName, nameIsLocalOrFrom, 
-                         mkSystemName, mkSystemNameEncoded, mkInternalName,
+                         mkSystemVarName, mkSystemVarNameEncoded, mkInternalName,
                          getOccName, getSrcLoc
                        ) 
 import Module          ( Module )
 import OccName         ( EncodedFS, mkWorkerOcc )
-import PrimRep         ( PrimRep )
-import FieldLabel      ( FieldLabel )
 import Maybes          ( orElse )
 import SrcLoc          ( SrcLoc )
 import Outputable
@@ -166,10 +168,10 @@ 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 (mkSystemNameEncoded uniq fs) ty
+mkSysLocal fs uniq ty = mkLocalId (mkSystemVarNameEncoded uniq fs) ty
 
 -- version to use when the faststring needs to be encoded
-mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs)        ty
+mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemVarName uniq fs)  ty
 
 mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName    uniq occ loc) ty
 mkVanillaGlobal            = mkGlobalId VanillaGlobal
@@ -238,13 +240,13 @@ Meanwhile, it is not discarded as dead code.
 
 
 \begin{code}
-recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
 recordSelectorFieldLabel id = case globalIdDetails id of
-                                RecordSelId lbl -> lbl
+                                RecordSelId tycon lbl -> (tycon,lbl)
                                 other -> panic "recordSelectorFieldLabel"
 
 isRecordSelector id = case globalIdDetails id of
-                       RecordSelId lbl -> True
+                       RecordSelId _ _ -> True
                        other           -> False
 
 isPrimOpId id = case globalIdDetails id of
@@ -289,7 +291,7 @@ isImplicitId :: Id -> Bool
        -- file, even if it's mentioned in some other interface unfolding.
 isImplicitId id
   = case globalIdDetails id of
-       RecordSelId _   -> True
+       RecordSelId _ _ -> True
         FCallId _       -> True
         PrimOpId _      -> True
        ClassOpId _     -> True
@@ -394,7 +396,7 @@ idSpecialisation :: Id -> CoreRules
 idSpecialisation id = specInfo (idInfo id)
 
 idCoreRules :: Id -> [IdCoreRule]
-idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)]
 
 setIdSpecialisation :: Id -> CoreRules -> Id
 setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
@@ -459,15 +461,16 @@ idLBVarInfo id = lbvarInfo (idInfo id)
 isOneShotBndr :: Id -> Bool
 -- This one is the "business end", called externally.
 -- Its main purpose is to encapsulate the Horrible State Hack
-isOneShotBndr id = isOneShotLambda id || (isStateHack id)
+isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id))
 
-isStateHack id 
+isStateHackType :: Type -> Bool
+isStateHackType ty
   | opt_NoStateHack 
   = False
   | otherwise
-  = case splitTyConApp_maybe (idType id) of
-       Just (tycon,_) | tycon == statePrimTyCon -> True
-        other                                    -> False
+  = case splitTyConApp_maybe ty of
+       Just (tycon,_) -> tycon == statePrimTyCon
+        other          -> False
        -- This is a gross hack.  It claims that 
        -- every function over realWorldStatePrimTy is a one-shot
        -- function.  This is pretty true in practice, and makes a big