[project @ 2001-11-27 10:03:36 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 9b40301..9047cd7 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -43,7 +43,7 @@ module Id (
 
        -- IdInfo stuff
        setIdUnfolding,
-       setIdArityInfo,
+       setIdArity,
        setIdDemandInfo, setIdNewDemandInfo, 
        setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
         setIdTyGenInfo,
@@ -53,16 +53,15 @@ module Id (
        setIdCprInfo,
        setIdOccInfo,
 
-       idArity, idArityInfo, 
+       idArity, 
        idDemandInfo, idNewDemandInfo,
-       idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
+       idStrictness, idNewStrictness, idNewStrictness_maybe, 
         idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
        idSpecialisation,
        idCgInfo,
        idCafInfo,
-       idCgArity,
        idCprInfo,
        idLBVarInfo,
        idOccInfo,
@@ -91,9 +90,7 @@ import Type           ( Type, typePrimRep, addFreeTyVars,
 import IdInfo 
 
 import qualified Demand        ( Demand )
-import NewDemand       ( Demand, DmdResult(..), StrictSig, topSig, isBotRes,
-                         isBottomingSig, splitStrictSig, strictSigResInfo
-                       )
+import NewDemand       ( Demand, StrictSig, topSig, isBottomingSig )
 import Name            ( Name, OccName,
                          mkSysLocalName, mkLocalName,
                          getOccName, getSrcLoc
@@ -108,7 +105,7 @@ import Outputable
 import Unique          ( Unique, mkBuiltinUnique )
 
 infixl         1 `setIdUnfolding`,
-         `setIdArityInfo`,
+         `setIdArity`,
          `setIdDemandInfo`,
          `setIdStrictness`,
          `setIdNewDemandInfo`,
@@ -139,10 +136,8 @@ where it can easily be found.
 mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
 mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
 
-mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id
-mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc)
-                                                   (addFreeTyVars ty)
-                                                   vanillaIdInfo
+mkSpecPragmaId :: Name -> Type -> Id
+mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
 
 mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
 mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
@@ -266,11 +261,12 @@ isDataConWrapId id = case globalIdDetails id of
                        DataConWrapId con -> True
                        other             -> False
 
-       -- hasNoBinding returns True of an Id which may not have a
-       -- binding, even though it is defined in this module.  Notably,
-       -- the constructors of a dictionary are in this situation.
+-- hasNoBinding returns True of an Id which may not have a
+-- binding, even though it is defined in this module.  
+-- Data constructor workers used to be things of this kind, but
+-- they aren't any more.  Instead, we inject a binding for 
+-- them at the CorePrep stage.
 hasNoBinding id = case globalIdDetails id of
-                       DataConId _ -> True
                        PrimOpId _  -> True
                        FCallId _   -> True
                        other       -> False
@@ -309,23 +305,16 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
 \begin{code}
        ---------------------------------
        -- ARITY
-idArityInfo :: Id -> ArityInfo
-idArityInfo id = arityInfo (idInfo id)
-
 idArity :: Id -> Arity
-idArity id = arityLowerBound (idArityInfo id)
+idArity id = arityInfo (idInfo id)
 
-setIdArityInfo :: Id -> Arity -> Id
-setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArity :: Id -> Arity -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
        ---------------------------------
        -- STRICTNESS 
 idStrictness :: Id -> StrictnessInfo
-idStrictness id = case strictnessInfo (idInfo id) of
-                       NoStrictnessInfo -> case idNewStrictness_maybe id of
-                                               Just sig -> oldStrictnessFromNew sig
-                                               Nothing  -> NoStrictnessInfo
-                       strictness -> strictness
+idStrictness id = strictnessInfo (idInfo id)
 
 setIdStrictness :: Id -> StrictnessInfo -> Id
 setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
@@ -340,20 +329,6 @@ idNewStrictness :: Id -> StrictSig
 idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
 idNewStrictness       id = idNewStrictness_maybe id `orElse` topSig
 
-getNewStrictness :: Id -> StrictSig
--- First tries the "new-strictness" field, and then
--- reverts to the old one. This is just until we have
--- cross-module info for new strictness
-getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
-                     
-newStrictnessFromOld :: Id -> StrictSig
-newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
-
-oldStrictnessFromNew :: StrictSig -> StrictnessInfo
-oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
-                        where
-                          (dmds, res_info) = splitStrictSig sig
-
 setIdNewStrictness :: Id -> StrictSig -> Id
 setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
 
@@ -423,21 +398,18 @@ setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
        ---------------------------------
        -- CAF INFO
 idCafInfo :: Id -> CafInfo
+#ifdef DEBUG
+idCafInfo id = case cgInfo (idInfo id) of
+                 NoCgInfo -> pprPanic "idCafInfo" (ppr id)
+                 info     -> cgCafInfo info
+#else
 idCafInfo id = cgCafInfo (idCgInfo id)
-
-       ---------------------------------
-       -- CG ARITY
-idCgArity :: Id -> Arity
-idCgArity id = cgArity (idCgInfo id)
+#endif
 
        ---------------------------------
        -- CPR INFO
 idCprInfo :: Id -> CprInfo
-idCprInfo id = case cprInfo (idInfo id) of
-                NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
-                               RetCPR -> ReturnsCPR
-                               other  -> NoCPRInfo
-                ReturnsCPR -> ReturnsCPR
+idCprInfo id = cprInfo (idInfo id)
 
 setIdCprInfo :: Id -> CprInfo -> Id
 setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
@@ -521,3 +493,4 @@ zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
 
 zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
 \end{code}
+