Compute demand signatures assuming idArity
[ghc.git] / compiler / basicTypes / Id.hs
index acb22e8..621be76 100644 (file)
@@ -53,7 +53,7 @@ module Id (
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
         zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
         zapIdUsedOnceInfo, zapIdTailCallInfo,
-        zapFragileIdInfo, zapIdStrictness,
+        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
         transferPolyIdInfo,
 
         -- ** Predicates on Ids
@@ -66,7 +66,10 @@ module Id (
         isClassOpId_maybe, isDFunId,
         isPrimOpId, isPrimOpId_maybe,
         isFCallId, isFCallId_maybe,
-        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
+        isDataConWorkId, isDataConWorkId_maybe,
+        isDataConWrapId, isDataConWrapId_maybe,
+        isDataConId_maybe,
+        idDataCon,
         isConLikeId, isBottomingId, idIsFrom,
         hasNoBinding,
 
@@ -116,7 +119,11 @@ module Id (
 
 #include "HsVersions.h"
 
-import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
+import GhcPrelude
+
+import DynFlags
+import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
+                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -126,8 +133,7 @@ import Var( Id, CoVar, DictId, JoinId,
             InId,  InVar,
             OutId, OutVar,
             idInfo, idDetails, setIdDetails, globaliseId, varType,
-            isId, isLocalId, isGlobalId, isExportedId,
-            isJoinId, isJoinId_maybe )
+            isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
 
 import Type
@@ -147,7 +153,6 @@ import Unique
 import UniqSupply
 import FastString
 import Util
-import StaticFlags
 
 -- infixl so you can say (id `set` a `set` b)
 infixl  1 `setIdUnfolding`,
@@ -202,7 +207,7 @@ setIdNotExported :: Id -> Id
 setIdNotExported = Var.setIdNotExported
 
 localiseId :: Id -> Id
--- Make an with the same unique and type as the
+-- Make an Id with the same unique and type as the
 -- incoming Id, but with an *Internal* Name and *LocalId* flavour
 localiseId id
   | ASSERT( isId id ) isLocalId id && isInternalName name
@@ -217,9 +222,9 @@ lazySetIdInfo = Var.lazySetIdInfo
 
 setIdInfo :: Id -> IdInfo -> Id
 setIdInfo id info = info `seq` (lazySetIdInfo id info)
-        -- Try to avoid spack leaks by seq'ing
+        -- Try to avoid space leaks by seq'ing
 
-modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
+modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
 modifyIdInfo fn id = setIdInfo id (fn (idInfo id))
 
 -- maybeModifyIdInfo tries to avoid unnecessary thrashing
@@ -265,20 +270,20 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
 -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
 mkLocalId :: Name -> Type -> Id
 mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
- -- It's tempting to ASSERT( not (isCoercionType ty) ), but don't. Sometimes,
+ -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes,
  -- the type is a panic. (Search invented_id)
 
 -- | Make a local CoVar
 mkLocalCoVar :: Name -> Type -> CoVar
 mkLocalCoVar name ty
-  = ASSERT( isCoercionType ty )
+  = ASSERT( isCoVarType ty )
     Var.mkLocalVar CoVarId name ty vanillaIdInfo
 
 -- | Like 'mkLocalId', but checks the type to see if it should make a covar
 mkLocalIdOrCoVar :: Name -> Type -> Id
 mkLocalIdOrCoVar name ty
-  | isCoercionType ty = mkLocalCoVar name ty
-  | otherwise         = mkLocalId    name ty
+  | isCoVarType ty = mkLocalCoVar name ty
+  | otherwise      = mkLocalId    name ty
 
 -- | Make a local id, with the IdDetails set to CoVarId if the type indicates
 -- so.
@@ -286,8 +291,8 @@ mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id
 mkLocalIdOrCoVarWithInfo name ty info
   = Var.mkLocalVar details name ty info
   where
-    details | isCoercionType ty = CoVarId
-            | otherwise         = VanillaId
+    details | isCoVarType ty = CoVarId
+            | otherwise      = VanillaId
 
     -- proper ids only; no covars!
 mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
@@ -309,7 +314,7 @@ mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaId
 -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")
 -- that are created by the compiler out of thin air
 mkSysLocal :: FastString -> Unique -> Type -> Id
-mkSysLocal fs uniq ty = ASSERT( not (isCoercionType ty) )
+mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) )
                         mkLocalId (mkSystemVarName uniq fs) ty
 
 -- | Like 'mkSysLocal', but checks to see if we have a covar type
@@ -326,7 +331,7 @@ mkSysLocalOrCoVarM fs ty
 
 -- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize
 mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id
-mkUserLocal occ uniq ty loc = ASSERT( not (isCoercionType ty) )
+mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) )
                               mkLocalId (mkInternalName uniq occ loc) ty
 
 -- | Like 'mkUserLocal', but checks if we have a coercion type
@@ -381,7 +386,7 @@ of reasons:
  * Look them up in the current substitution when we come across
    occurrences of them (in Subst.lookupIdSubst). Lacking this we
    can get an out-of-date unfolding, which can in turn make the
-   simplifier go into an infinite loop (Trac #9857)
+   simplifier go into an infinite loop (#9857)
 
  * Ensure that for dfuns that the specialiser does not float dict uses
    above their defns, which would prevent good simplifications happening.
@@ -417,12 +422,14 @@ isDataConRecordSelector  :: Id -> Bool
 isPrimOpId              :: Id -> Bool
 isFCallId               :: Id -> Bool
 isDataConWorkId         :: Id -> Bool
+isDataConWrapId         :: Id -> Bool
 isDFunId                :: Id -> Bool
 
 isClassOpId_maybe       :: Id -> Maybe Class
 isPrimOpId_maybe        :: Id -> Maybe PrimOp
 isFCallId_maybe         :: Id -> Maybe ForeignCall
 isDataConWorkId_maybe   :: Id -> Maybe DataCon
+isDataConWrapId_maybe   :: Id -> Maybe DataCon
 
 isRecordSelector id = case Var.idDetails id of
                         RecSelId {}     -> True
@@ -472,12 +479,38 @@ isDataConWorkId_maybe id = case Var.idDetails id of
                         DataConWorkId con -> Just con
                         _                 -> Nothing
 
+isDataConWrapId id = case Var.idDetails id of
+                       DataConWrapId _ -> True
+                       _               -> False
+
+isDataConWrapId_maybe id = case Var.idDetails id of
+                        DataConWrapId con -> Just con
+                        _                 -> Nothing
+
 isDataConId_maybe :: Id -> Maybe DataCon
 isDataConId_maybe id = case Var.idDetails id of
                          DataConWorkId con -> Just con
                          DataConWrapId con -> Just con
                          _                 -> Nothing
 
+isJoinId :: Var -> Bool
+-- It is convenient in SetLevels.lvlMFE to apply isJoinId
+-- to the free vars of an expression, so it's convenient
+-- if it returns False for type variables
+isJoinId id
+  | isId id = case Var.idDetails id of
+                JoinId {} -> True
+                _         -> False
+  | otherwise = False
+
+isJoinId_maybe :: Var -> Maybe JoinArity
+isJoinId_maybe id
+ | isId id  = ASSERT2( isId id, ppr id )
+              case Var.idDetails id of
+                JoinId arity -> Just arity
+                _            -> Nothing
+ | otherwise = Nothing
+
 idDataCon :: Id -> DataCon
 -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.
 --
@@ -496,7 +529,8 @@ hasNoBinding id = case Var.idDetails id of
                         PrimOpId _       -> True        -- See Note [Primop wrappers]
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
-                        _                -> False
+                        _                -> isCompulsoryUnfolding (idUnfolding id)
+                                            -- See Note [Levity-polymorphic Ids]
 
 isImplicitId :: Id -> Bool
 -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other
@@ -518,7 +552,25 @@ isImplicitId id
 idIsFrom :: Module -> Id -> Bool
 idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
 
-{-
+{- Note [Levity-polymorphic Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some levity-polymorphic Ids must be applied and and inlined, not left
+un-saturated.  Example:
+  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b
+
+This has a compulsory unfolding because we can't lambda-bind those
+arguments.  But the compulsory unfolding may leave levity-polymorphic
+lambdas if it is not applied to enough arguments; e.g. (#14561)
+  bad :: forall (a :: TYPE r). a -> a
+  bad = unsafeCoerce#
+
+The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
+And we want that magic to apply to levity-polymorphic compulsory-inline things.
+The easiest way to do this is for hasNoBinding to return True of all things
+that have compulsory unfolding.  A very Ids with a compulsory unfolding also
+have a binding, but it does not harm to say they don't here, and its a very
+simple way to fix #14561.
+
 Note [Primop wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~
 Currently hasNoBinding claims that PrimOpIds don't have a curried
@@ -546,7 +598,7 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
 -}
 
 isEvVar :: Var -> Bool
-isEvVar var = isPredTy (varType var)
+isEvVar var = isEvVarType (varType var)
 
 isDictId :: Id -> Bool
 isDictId id = isDictTy (idType id)
@@ -611,9 +663,12 @@ idFunRepArity :: Id -> RepArity
 idFunRepArity x = countFunRepArgs (idArity x) (idType x)
 
 -- | Returns true if an application to n args would diverge
-isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingSig (idStrictness id)
+isBottomingId :: Var -> Bool
+isBottomingId v
+  | isId v    = isBottomingSig (idStrictness v)
+  | otherwise = False
 
+-- | Accesses the 'Id''s 'strictnessInfo'.
 idStrictness :: Id -> StrictSig
 idStrictness id = strictnessInfo (idInfo id)
 
@@ -696,7 +751,7 @@ setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
         ---------------------------------
-        -- Occcurrence INFO
+        -- Occurrence INFO
 idOccInfo :: Id -> OccInfo
 idOccInfo id = occInfo (idInfo id)
 
@@ -762,7 +817,7 @@ isOneShotBndr var
 
 -- | Should we apply the state hack to values of this 'Type'?
 stateHackOneShot :: OneShotInfo
-stateHackOneShot = OneShotLam         -- Or maybe ProbOneShot?
+stateHackOneShot = OneShotLam
 
 typeOneShot :: Type -> OneShotInfo
 typeOneShot ty
@@ -771,7 +826,7 @@ typeOneShot ty
 
 isStateHackType :: Type -> Bool
 isStateHackType ty
-  | opt_NoStateHack
+  | hasNoStateHack unsafeGlobalDynFlags
   = False
   | otherwise
   = case tyConAppTyCon_maybe ty of
@@ -798,7 +853,6 @@ isStateHackType ty
 isProbablyOneShotLambda :: Id -> Bool
 isProbablyOneShotLambda id = case idStateHackOneShotInfo id of
                                OneShotLam    -> True
-                               ProbOneShot   -> True
                                NoOneShotInfo -> False
 
 setOneShotLambda :: Id -> Id
@@ -819,8 +873,6 @@ updOneShotInfo id one_shot
     do_upd = case (idOneShotInfo id, one_shot) of
                 (NoOneShotInfo, _) -> True
                 (OneShotLam,    _) -> False
-                (_, NoOneShotInfo) -> False
-                _                  -> True
 
 -- The OneShotLambda functions simply fiddle with the IdInfo flag
 -- But watch out: this may change the type of something else
@@ -851,12 +903,18 @@ zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo
 zapIdTailCallInfo :: Id -> Id
 zapIdTailCallInfo = zapInfo zapTailCallInfo
 
+zapStableUnfolding :: Id -> Id
+zapStableUnfolding id
+ | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding
+ | otherwise                              = id
+
 {-
 Note [transferPolyIdInfo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-This transfer is used in two places:
+This transfer is used in three places:
         FloatOut (long-distance let-floating)
         SimplUtils.abstractFloats (short-distance let-floating)
+        StgLiftLams (selectively lambda-lift local functions to top-level)
 
 Consider the short-distance let-floating:
 
@@ -885,7 +943,7 @@ where the '*' means 'LoopBreaker'.  Then if we float we must get
 
 where g' is also marked as LoopBreaker.  If not, terrible things
 can happen if we re-simplify the binding (and the Simplifier does
-sometimes simplify a term twice); see Trac #4345.
+sometimes simplify a term twice); see #4345.
 
 It's not so simple to retain
   * worker info