[project @ 2003-02-04 15:09:38 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 9f07786..bd9fffb 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -9,7 +9,7 @@ module Id (
 
        -- Simple construction
        mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
-       mkSysLocal, mkUserLocal, mkVanillaGlobal,
+       mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
        mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
        mkWorkerId,
 
@@ -46,7 +46,6 @@ module Id (
        setIdArity,
        setIdNewDemandInfo, 
        setIdNewStrictness, zapIdNewStrictness,
-        setIdTyGenInfo,
        setIdWorkerInfo,
        setIdSpecialisation,
        setIdCgInfo,
@@ -64,7 +63,6 @@ module Id (
        idArity, 
        idNewDemandInfo, idNewDemandInfo_maybe,
        idNewStrictness, idNewStrictness_maybe, 
-        idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
        idSpecialisation, idCoreRules,
@@ -94,19 +92,18 @@ import Var          ( Id, DictId,
                        )
 import qualified Var   ( mkLocalId, mkGlobalId, mkSpecPragmaId )
 import Type            ( Type, typePrimRep, addFreeTyVars, 
-                          usOnce, eqUsage, seqType, splitTyConApp_maybe )
+                          seqType, splitTyConApp_maybe )
 
 import IdInfo 
 
 import qualified Demand        ( Demand )
 import NewDemand       ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
 import Name            ( Name, OccName,
-                         mkSystemName, mkInternalName,
+                         mkSystemName, mkSystemNameEncoded, mkInternalName,
                          getOccName, getSrcLoc
                        ) 
 import OccName         ( EncodedFS, mkWorkerOcc )
 import PrimRep         ( PrimRep )
-import TysPrim         ( statePrimTyCon )
 import FieldLabel      ( FieldLabel )
 import Maybes          ( orElse )
 import SrcLoc          ( SrcLoc )
@@ -118,7 +115,6 @@ infixl      1 `setIdUnfolding`,
          `setIdArity`,
          `setIdNewDemandInfo`,
          `setIdNewStrictness`,
-         `setIdTyGenInfo`,
          `setIdWorkerInfo`,
          `setIdSpecialisation`,
          `setInlinePragma`,
@@ -165,7 +161,11 @@ 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 (mkSystemName uniq fs)      ty
+mkSysLocal          fs uniq ty = mkLocalId (mkSystemNameEncoded uniq fs) ty
+
+-- version to use when the faststring needs to be encoded
+mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs)        ty
+
 mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName    uniq occ loc) ty
 mkVanillaGlobal            = mkGlobalId VanillaGlobal
 \end{code}
@@ -350,14 +350,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)
@@ -471,34 +463,12 @@ idLBVarInfo :: Id -> LBVarInfo
 idLBVarInfo id = lbvarInfo (idInfo id)
 
 isOneShotLambda :: Id -> Bool
-isOneShotLambda id = analysis || hack
-  where analysis = case idLBVarInfo id of
-                     LBVarInfo u    | u `eqUsage` usOnce      -> True
-                     other                                    -> False
-        hack     = case splitTyConApp_maybe (idType id) of
-                     Just (tycon,_) | tycon == statePrimTyCon -> True
-                     other                                    -> False
-
-       -- The last clause 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
-       -- difference.  For example, consider
-       --      a `thenST` \ r -> ...E...
-       -- The early full laziness pass, if it doesn't know that r is one-shot
-       -- will pull out E (let's say it doesn't mention r) to give
-       --      let lvl = E in a `thenST` \ r -> ...lvl...
-       -- When `thenST` gets inlined, we end up with
-       --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...
-       -- and we don't re-inline E.
-       --
-       -- It would be better to spot that r was one-shot to start with, but
-       -- I don't want to rely on that.
-       --
-       -- Another good example is in fill_in in PrelPack.lhs.  We should be able to
-       -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+isOneShotLambda id = case idLBVarInfo id of
+                       IsOneShotLambda  -> True
+                       NoLBVarInfo      -> False
 
 setOneShotLambda :: Id -> Id
-setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
 
 clearOneShotLambda :: Id -> Id
 clearOneShotLambda id