[project @ 2001-11-28 14:47:54 by simonmar]

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

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 8e496b3..9047cd7 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -19,7 +19,7 @@ module Id (
        recordSelectorFieldLabel,
 
        -- Modifying an Id
-       setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails,
+       setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
        zapLamIdInfo, zapDemandIdInfo, 
 
@@ -28,6 +28,7 @@ module Id (
        isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isPrimOpId_maybe, 
+       isFCallId, isFCallId_maybe,
        isDataConId, isDataConId_maybe, 
        isDataConWrapId, isDataConWrapId_maybe,
        isBottomingId,
@@ -42,9 +43,9 @@ module Id (
 
        -- IdInfo stuff
        setIdUnfolding,
-       setIdArityInfo,
-       setIdDemandInfo,
-       setIdStrictness,
+       setIdArity,
+       setIdDemandInfo, setIdNewDemandInfo, 
+       setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
         setIdTyGenInfo,
        setIdWorkerInfo,
        setIdSpecialisation,
@@ -52,20 +53,21 @@ module Id (
        setIdCprInfo,
        setIdOccInfo,
 
-       idArity, idArityInfo, 
-       idDemandInfo,
-       idStrictness,
+       idArity, 
+       idDemandInfo, idNewDemandInfo,
+       idStrictness, idNewStrictness, idNewStrictness_maybe, 
         idTyGenInfo,
        idWorkerInfo,
        idUnfolding,
        idSpecialisation,
        idCgInfo,
        idCafInfo,
-       idCgArity,
        idCprInfo,
        idLBVarInfo,
        idOccInfo,
 
+       newStrictnessFromOld    -- Temporary
+
     ) where
 
 #include "HsVersions.h"
@@ -76,18 +78,19 @@ import BasicTypes   ( Arity )
 import Var             ( Id, DictId,
                          isId, isExportedId, isSpecPragmaId, isLocalId,
                          idName, idType, idUnique, idInfo, isGlobalId,
-                         setIdName, setVarType, setIdUnique, setIdNoDiscard,
+                         setIdName, setVarType, setIdUnique, setIdLocalExported,
                          setIdInfo, lazySetIdInfo, modifyIdInfo, 
                          maybeModifyIdInfo,
                          globalIdDetails, setGlobalIdDetails
                        )
 import qualified Var   ( mkLocalId, mkGlobalId, mkSpecPragmaId )
 import Type            ( Type, typePrimRep, addFreeTyVars, 
-                          usOnce, seqType, splitTyConApp_maybe )
+                          usOnce, eqUsage, seqType, splitTyConApp_maybe )
 
 import IdInfo 
 
-import Demand          ( Demand )
+import qualified Demand        ( Demand )
+import NewDemand       ( Demand, StrictSig, topSig, isBottomingSig )
 import Name            ( Name, OccName,
                          mkSysLocalName, mkLocalName,
                          getOccName, getSrcLoc
@@ -96,14 +99,17 @@ import OccName              ( UserFS, mkWorkerOcc )
 import PrimRep         ( PrimRep )
 import TysPrim         ( statePrimTyCon )
 import FieldLabel      ( FieldLabel )
+import Maybes          ( orElse )
 import SrcLoc          ( SrcLoc )
 import Outputable
 import Unique          ( Unique, mkBuiltinUnique )
 
 infixl         1 `setIdUnfolding`,
-         `setIdArityInfo`,
+         `setIdArity`,
          `setIdDemandInfo`,
          `setIdStrictness`,
+         `setIdNewDemandInfo`,
+         `setIdNewStrictness`,
          `setIdTyGenInfo`,
          `setIdWorkerInfo`,
          `setIdSpecialisation`,
@@ -130,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
@@ -233,6 +237,14 @@ isPrimOpId_maybe id = case globalIdDetails id of
                            PrimOpId op -> Just op
                            other       -> Nothing
 
+isFCallId id = case globalIdDetails id of
+                   FCallId call -> True
+                   other        -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+                           FCallId call -> Just call
+                           other        -> Nothing
+
 isDataConId id = case globalIdDetails id of
                        DataConId _ -> True
                        other       -> False
@@ -249,12 +261,14 @@ 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
 
 isImplicitId :: Id -> Bool
@@ -264,6 +278,7 @@ isImplicitId :: Id -> Bool
 isImplicitId id
   = case globalIdDetails id of
        RecordSelId _   -> True -- Includes dictionary selectors
+        FCallId _       -> True
         PrimOpId _      -> True
         DataConId _     -> True
        DataConWrapId _ -> True
@@ -290,17 +305,14 @@ 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 -> ArityInfo -> Id
-setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArity :: Id -> Arity -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
        ---------------------------------
-       -- STRICTNESS
+       -- STRICTNESS 
 idStrictness :: Id -> StrictnessInfo
 idStrictness id = strictnessInfo (idInfo id)
 
@@ -309,7 +321,19 @@ setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info)
 
 -- isBottomingId returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingStrictness (idStrictness id)
+isBottomingId id = isBottomingSig (idNewStrictness id)
+
+idNewStrictness_maybe :: Id -> Maybe StrictSig
+idNewStrictness :: Id -> StrictSig
+
+idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
+idNewStrictness       id = idNewStrictness_maybe id `orElse` topSig
+
+setIdNewStrictness :: Id -> StrictSig -> Id
+setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
+
+zapIdNewStrictness :: Id -> Id
+zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
 
        ---------------------------------
        -- TYPE GENERALISATION
@@ -337,12 +361,18 @@ setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
        ---------------------------------
        -- DEMAND
-idDemandInfo :: Id -> Demand
+idDemandInfo :: Id -> Demand.Demand
 idDemandInfo id = demandInfo (idInfo id)
 
-setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo :: Id -> Demand.Demand -> Id
 setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
 
+idNewDemandInfo :: Id -> NewDemand.Demand
+idNewDemandInfo id = newDemandInfo (idInfo id)
+
+setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
+
        ---------------------------------
        -- SPECIALISATION
 idSpecialisation :: Id -> CoreRules
@@ -368,13 +398,13 @@ 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
@@ -420,7 +450,7 @@ idLBVarInfo id = lbvarInfo (idInfo id)
 isOneShotLambda :: Id -> Bool
 isOneShotLambda id = analysis || hack
   where analysis = case idLBVarInfo id of
-                     LBVarInfo u    | u == usOnce             -> True
+                     LBVarInfo u    | u `eqUsage` usOnce      -> True
                      other                                    -> False
         hack     = case splitTyConApp_maybe (idType id) of
                      Just (tycon,_) | tycon == statePrimTyCon -> True
@@ -463,3 +493,4 @@ zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
 
 zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
 \end{code}
+