Teach advanceSrcLoc about tab characters

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

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 74fd2cf..ceba599 100644 (file)
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -49,16 +49,17 @@ module Id (
        isImplicitId, isDeadBinder, isDictId, isStrictId,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector, isNaughtyRecordSelector,
        isImplicitId, isDeadBinder, isDictId, isStrictId,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector, isNaughtyRecordSelector,

-       isClassOpId_maybe,
+       isClassOpId_maybe, isDFunId,

        isPrimOpId, isPrimOpId_maybe, 
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
        isPrimOpId, isPrimOpId_maybe, 
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,

-       isBottomingId, idIsFrom,
+        isConLikeId, isBottomingId, idIsFrom,

         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff

-       idInlinePragma, setInlinePragma, modifyInlinePragma, 
+       idInlinePragma, setInlinePragma, modifyInlinePragma,
+        idInlineActivation, setInlineActivation, idRuleMatchInfo,

 
        -- ** One-shot lambdas
        isOneShotBndr, isOneShotLambda, isStateHackType,
 
        -- ** One-shot lambdas
        isOneShotBndr, isOneShotLambda, isStateHackType,

@@ -66,47 +67,34 @@ module Id (
 
        -- ** Reading 'IdInfo' fields
        idArity, 
 
        -- ** Reading 'IdInfo' fields
        idArity, 

-       idNewDemandInfo, idNewDemandInfo_maybe,
-       idNewStrictness, idNewStrictness_maybe, 
-       idWorkerInfo,
-       idUnfolding,
+       idDemandInfo, idDemandInfo_maybe,
+       idStrictness, idStrictness_maybe, 
+       idUnfolding, realIdUnfolding,

        idSpecialisation, idCoreRules, idHasRules,
        idCafInfo,
        idLBVarInfo,
        idOccInfo,
 
        idSpecialisation, idCoreRules, idHasRules,
        idCafInfo,
        idLBVarInfo,
        idOccInfo,
 

-#ifdef OLD_STRICTNESS
-       idDemandInfo, 
-       idStrictness, 
-       idCprInfo,
-#endif
-

        -- ** Writing 'IdInfo' fields
        setIdUnfolding,
        setIdArity,
        -- ** Writing 'IdInfo' fields
        setIdUnfolding,
        setIdArity,

-       setIdNewDemandInfo, 
-       setIdNewStrictness, zapIdNewStrictness,
-       setIdWorkerInfo,
+       setIdDemandInfo, 
+       setIdStrictness, zapIdStrictness,

        setIdSpecialisation,
        setIdCafInfo,
        setIdOccInfo, zapIdOccInfo,
 
        setIdSpecialisation,
        setIdCafInfo,
        setIdOccInfo, zapIdOccInfo,
 

-#ifdef OLD_STRICTNESS
-       setIdStrictness, 
-       setIdDemandInfo, 
-       setIdCprInfo,
-#endif

     ) where
 
 #include "HsVersions.h"
 
     ) where
 
 #include "HsVersions.h"
 

-import CoreSyn ( CoreRule, Unfolding )
+import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )

 
 import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 
 
 import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 

-import Var( Id, DictId,
+import Var( Var, Id, DictId,

             idInfo, idDetails, globaliseId,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
             idInfo, idDetails, globaliseId,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var

@@ -115,39 +103,30 @@ import TyCon
 import Type
 import TcType
 import TysPrim
 import Type
 import TcType
 import TysPrim

-#ifdef OLD_STRICTNESS
-import qualified Demand
-#endif

 import DataCon
 import DataCon

-import NewDemand
+import Demand

 import Name
 import Module
 import Class
 import PrimOp
 import ForeignCall
 import Name
 import Module
 import Class
 import PrimOp
 import ForeignCall

-import OccName

 import Maybes
 import SrcLoc
 import Outputable
 import Unique
 import UniqSupply
 import FastString
 import Maybes
 import SrcLoc
 import Outputable
 import Unique
 import UniqSupply
 import FastString

+import Util( count )

 import StaticFlags
 
 -- infixl so you can say (id `set` a `set` b)
 infixl         1 `setIdUnfolding`,
          `setIdArity`,
 import StaticFlags
 
 -- infixl so you can say (id `set` a `set` b)
 infixl         1 `setIdUnfolding`,
          `setIdArity`,

-         `setIdNewDemandInfo`,
-         `setIdNewStrictness`,
-         `setIdWorkerInfo`,
+         `setIdDemandInfo`,
+         `setIdStrictness`,

          `setIdSpecialisation`,
          `setInlinePragma`,
          `idCafInfo`
          `setIdSpecialisation`,
          `setInlinePragma`,
          `idCafInfo`

-#ifdef OLD_STRICTNESS
-         ,`idCprInfo`
-         ,`setIdStrictness`
-         ,`setIdDemandInfo`
-#endif

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -288,9 +267,7 @@ instantiated before use.
 -- | Workers get local names. "CoreTidy" will externalise these if necessary
 mkWorkerId :: Unique -> Id -> Type -> Id
 mkWorkerId uniq unwrkr ty
 -- | Workers get local names. "CoreTidy" will externalise these if necessary
 mkWorkerId :: Unique -> Id -> Type -> Id
 mkWorkerId uniq unwrkr ty

-  = mkLocalId wkr_name ty
-  where
-    wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr)
+  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty

 
 -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
 mkTemplateLocal :: Int -> Type -> Id
 
 -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
 mkTemplateLocal :: Int -> Type -> Id

@@ -325,6 +302,7 @@ isNaughtyRecordSelector :: Id -> Bool
 isPrimOpId              :: Id -> Bool
 isFCallId               :: Id -> Bool
 isDataConWorkId         :: Id -> Bool
 isPrimOpId              :: Id -> Bool
 isFCallId               :: Id -> Bool
 isDataConWorkId         :: Id -> Bool

+isDFunId                :: Id -> Bool

 
 isClassOpId_maybe       :: Id -> Maybe Class
 isPrimOpId_maybe        :: Id -> Maybe PrimOp
 
 isClassOpId_maybe       :: Id -> Maybe Class
 isPrimOpId_maybe        :: Id -> Maybe PrimOp

@@ -347,6 +325,10 @@ isPrimOpId id = case Var.idDetails id of
                         PrimOpId _ -> True
                         _          -> False
 
                         PrimOpId _ -> True
                         _          -> False
 

+isDFunId id = case Var.idDetails id of
+                        DFunId _ -> True
+                        _        -> False
+

 isPrimOpId_maybe id = case Var.idDetails id of
                         PrimOpId op -> Just op
                         _           -> Nothing
 isPrimOpId_maybe id = case Var.idDetails id of
                         PrimOpId op -> Just op
                         _           -> Nothing

@@ -403,11 +385,11 @@ isImplicitId :: Id -> Bool
 -- file, even if it's mentioned in some other interface unfolding.
 isImplicitId id
   = case Var.idDetails id of
 -- file, even if it's mentioned in some other interface unfolding.
 isImplicitId id
   = case Var.idDetails id of

-        FCallId _       -> True
-       ClassOpId _     -> True
-        PrimOpId _      -> True
-        DataConWorkId _ -> True
-       DataConWrapId _ -> True
+        FCallId {}       -> True
+       ClassOpId {}     -> True
+        PrimOpId {}      -> True
+        DataConWorkId {} -> True
+       DataConWrapId {} -> True

                -- These are are implied by their type or class decl;
                -- remember that all type and class decls appear in the interface file.
                -- The dfun id is not an implicit Id; it must *not* be omitted, because 
                -- These are are implied by their type or class decl;
                -- remember that all type and class decls appear in the interface file.
                -- The dfun id is not an implicit Id; it must *not* be omitted, because 

@@ -468,31 +450,21 @@ idArity id = arityInfo (idInfo id)
 setIdArity :: Id -> Arity -> Id
 setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
 setIdArity :: Id -> Arity -> Id
 setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 

-#ifdef OLD_STRICTNESS
-       ---------------------------------
-       -- (OLD) STRICTNESS 
-idStrictness :: Id -> StrictnessInfo
-idStrictness id = strictnessInfo (idInfo id)
-
-setIdStrictness :: Id -> StrictnessInfo -> Id
-setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-#endif
-

 -- | Returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
 -- | Returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool

-isBottomingId id = isBottomingSig (idNewStrictness id)
+isBottomingId id = isBottomingSig (idStrictness id)

 
 

-idNewStrictness_maybe :: Id -> Maybe StrictSig
-idNewStrictness :: Id -> StrictSig
+idStrictness_maybe :: Id -> Maybe StrictSig
+idStrictness :: Id -> StrictSig

 
 

-idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
-idNewStrictness       id = idNewStrictness_maybe id `orElse` topSig
+idStrictness_maybe id = strictnessInfo (idInfo id)
+idStrictness       id = idStrictness_maybe id `orElse` topSig

 
 

-setIdNewStrictness :: Id -> StrictSig -> Id
-setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
+setIdStrictness :: Id -> StrictSig -> Id
+setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id

 
 

-zapIdNewStrictness :: Id -> Id
-zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
+zapIdStrictness :: Id -> Id
+zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id

 
 -- | This predicate says whether the 'Id' has a strict demand placed on it or
 -- has a type such that it can always be evaluated strictly (e.g., an
 
 -- | This predicate says whether the 'Id' has a strict demand placed on it or
 -- has a type such that it can always be evaluated strictly (e.g., an

@@ -503,46 +475,40 @@ zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
 isStrictId :: Id -> Bool
 isStrictId id
   = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
 isStrictId :: Id -> Bool
 isStrictId id
   = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )

-           (isStrictDmd (idNewDemandInfo id)) || 
+           (isStrictDmd (idDemandInfo id)) || 

            (isStrictType (idType id))
 
        ---------------------------------
            (isStrictType (idType id))
 
        ---------------------------------

-       -- WORKER ID
-idWorkerInfo :: Id -> WorkerInfo
-idWorkerInfo id = workerInfo (idInfo id)
-
-setIdWorkerInfo :: Id -> WorkerInfo -> Id
-setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
-
-       ---------------------------------

        -- UNFOLDING
 idUnfolding :: Id -> Unfolding
        -- UNFOLDING
 idUnfolding :: Id -> Unfolding

-idUnfolding id = unfoldingInfo (idInfo id)
+-- Do not expose the unfolding of a loop breaker!
+idUnfolding id 
+  | isNonRuleLoopBreaker (occInfo info) = NoUnfolding
+  | otherwise                           = unfoldingInfo info
+  where
+    info = idInfo id
+
+realIdUnfolding :: Id -> Unfolding
+-- Expose the unfolding if there is one, including for loop breakers
+realIdUnfolding id = unfoldingInfo (idInfo id)

 
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
 
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 

-#ifdef OLD_STRICTNESS
-       ---------------------------------
-       -- (OLD) DEMAND
-idDemandInfo :: Id -> Demand.Demand
-idDemandInfo id = demandInfo (idInfo id)
-
-setIdDemandInfo :: Id -> Demand.Demand -> Id
-setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
-#endif
+idDemandInfo_maybe :: Id -> Maybe Demand
+idDemandInfo       :: Id -> Demand

 
 

-idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
-idNewDemandInfo       :: Id -> NewDemand.Demand
+idDemandInfo_maybe id = demandInfo (idInfo id)
+idDemandInfo       id = demandInfo (idInfo id) `orElse` topDmd

 
 

-idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
-idNewDemandInfo       id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
-
-setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
-setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
+setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id

 
        ---------------------------------
        -- SPECIALISATION
 
        ---------------------------------
        -- SPECIALISATION

+
+-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs
+

 idSpecialisation :: Id -> SpecInfo
 idSpecialisation id = specInfo (idInfo id)
 
 idSpecialisation :: Id -> SpecInfo
 idSpecialisation id = specInfo (idInfo id)
 

@@ -558,28 +524,12 @@ setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
        ---------------------------------
        -- CAF INFO
 idCafInfo :: Id -> CafInfo
        ---------------------------------
        -- CAF INFO
 idCafInfo :: Id -> CafInfo

-#ifdef OLD_STRICTNESS
-idCafInfo id = case cgInfo (idInfo id) of
-                 NoCgInfo -> pprPanic "idCafInfo" (ppr id)
-                 info     -> cgCafInfo info
-#else

 idCafInfo id = cafInfo (idInfo id)
 idCafInfo id = cafInfo (idInfo id)

-#endif

 
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
        ---------------------------------
 
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
        ---------------------------------

-       -- CPR INFO
-#ifdef OLD_STRICTNESS
-idCprInfo :: Id -> CprInfo
-idCprInfo id = cprInfo (idInfo id)
-
-setIdCprInfo :: Id -> CprInfo -> Id
-setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
-#endif
-
-       ---------------------------------

        -- Occcurrence INFO
 idOccInfo :: Id -> OccInfo
 idOccInfo id = occInfo (idInfo id)
        -- Occcurrence INFO
 idOccInfo :: Id -> OccInfo
 idOccInfo id = occInfo (idInfo id)

@@ -598,14 +548,26 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
 OK not to if optimisation is switched off.
 
 \begin{code}
 OK not to if optimisation is switched off.
 
 \begin{code}

-idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma :: Id -> InlinePragma

 idInlinePragma id = inlinePragInfo (idInfo id)
 
 idInlinePragma id = inlinePragInfo (idInfo id)
 

-setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma :: Id -> InlinePragma -> Id

 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 
 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 

-modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
+modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id

 modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
 modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id

+
+idInlineActivation :: Id -> Activation
+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
+
+setInlineActivation :: Id -> Activation -> Id
+setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)
+
+idRuleMatchInfo :: Id -> RuleMatchInfo
+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
+
+isConLikeId :: Id -> Bool
+isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)

 \end{code}
 
 
 \end{code}
 
 

@@ -697,23 +659,47 @@ where g has interesting strictness information.  Then if we float thus
    g' = /\a. rhs
    f = /\a. ...[g' a/g]
 
    g' = /\a. rhs
    f = /\a. ...[g' a/g]
 

-we *do not* want to lose the strictness information on g.  Nor arity.
+we *do not* want to lose g's
+  * strictness information
+  * arity 
+  * inline pragma (though that is bit more debatable)

 
 It's simple to retain strictness and arity, but not so simple to retain
 
 It's simple to retain strictness and arity, but not so simple to retain

-       worker info
-       rules
+  * worker info
+  * rules

 so we simply discard those.  Sooner or later this may bite us.
 
 This transfer is used in two places: 
        FloatOut (long-distance let-floating)
        SimplUtils.abstractFloats (short-distance let-floating)
 
 so we simply discard those.  Sooner or later this may bite us.
 
 This transfer is used in two places: 
        FloatOut (long-distance let-floating)
        SimplUtils.abstractFloats (short-distance let-floating)
 

+If we abstract wrt one or more *value* binders, we must modify the 
+arity and strictness info before transferring it.  E.g. 
+      f = \x. e
+-->
+      g' = \y. \x. e
+      + substitute (g' y) for g
+Notice that g' has an arity one more than the original g
+

 \begin{code}
 \begin{code}

-transferPolyIdInfo :: Id -> Id -> Id
-transferPolyIdInfo old_id new_id
+transferPolyIdInfo :: Id       -- Original Id
+                  -> [Var]     -- Abstract wrt these variables
+                  -> Id        -- New Id
+                  -> Id
+transferPolyIdInfo old_id abstract_wrt new_id

   = modifyIdInfo transfer new_id
   where
   = modifyIdInfo transfer new_id
   where

-    old_info = idInfo old_id
-    transfer new_info = new_info `setNewStrictnessInfo` (newStrictnessInfo old_info)
-                                `setArityInfo` (arityInfo old_info)
+    arity_increase = count isId abstract_wrt   -- Arity increases by the
+                                               -- number of value binders
+
+    old_info       = idInfo old_id
+    old_arity       = arityInfo old_info
+    old_inline_prag = inlinePragInfo old_info
+    new_arity       = old_arity + arity_increase
+    old_strictness  = strictnessInfo old_info
+    new_strictness  = fmap (increaseStrictSigArity arity_increase) old_strictness
+
+    transfer new_info = new_info `setStrictnessInfo` new_strictness
+                                `setArityInfo` new_arity
+                                `setInlinePragInfo` old_inline_prag

 \end{code}
 \end{code}