[project @ 1999-07-12 14:40:08 by simonmar]
[ghc-hetmet.git] / ghc / compiler / basicTypes / Id.lhs
index 0ae23a6..aa086a1 100644 (file)
@@ -5,11 +5,11 @@
 
 \begin{code}
 module Id (
-       Id, DictId, GenId,
+       Id, DictId,
 
        -- Simple construction
-       mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
-       mkTemplateLocals, mkWildId, mkUserId,
+       mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+       mkTemplateLocals, mkWildId, mkTemplateLocal,
 
        -- Taking an Id apart
        idName, idType, idUnique, idInfo,
@@ -17,67 +17,76 @@ module Id (
        recordSelectorFieldLabel,
 
        -- Modifying an Id
-       setIdName, setIdUnique, setIdType, setIdInfo,
-       setIdVisibility, mkIdVisible,
+       setIdName, setIdUnique, setIdType, setIdNoDiscard, 
+       setIdInfo, modifyIdInfo, maybeModifyIdInfo,
 
        -- Predicates
        omitIfaceSigForId,
+       exportWithOrigOccName,
        externallyVisibleId,
        idFreeTyVars, 
 
        -- Inline pragma stuff
        getInlinePragma, setInlinePragma, modifyInlinePragma, 
-       idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
-       isSpecPragmaId,
-       
+       idMustBeINLINEd, idMustNotBeINLINEd,
 
-       isRecordSelector,
+       isSpecPragmaId, isRecordSelector,
        isPrimitiveId_maybe, isDataConId_maybe,
-       isConstantId,
-       isBottomingId, 
+       isConstantId, isBottomingId, idAppIsBottom,
+       isExportedId, isUserExportedId,
+
+       -- One shot lambda stuff
+       isOneShotLambda, setOneShotLambda,
 
        -- IdInfo stuff
        setIdUnfolding,
        setIdArity,
        setIdDemandInfo,
        setIdStrictness,
+       setIdWorkerInfo,
        setIdSpecialisation,
        setIdUpdateInfo,
        setIdCafInfo,
+       setIdCprInfo,
 
        getIdArity,
        getIdDemandInfo,
        getIdStrictness,
+       getIdWorkerInfo,
        getIdUnfolding,
        getIdSpecialisation,
        getIdUpdateInfo,
-       getIdCafInfo
+       getIdCafInfo,
+       getIdCprInfo
 
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} CoreUnfold ( Unfolding )
+import {-# SOURCE #-} CoreSyn    ( CoreRules )
 
-import Var             ( Id, GenId, DictId, VarDetails(..), 
-                         isId, mkId, 
-                         idName, idType, idUnique, idInfo, varDetails,
-                         setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
+import Var             ( Id, DictId,
+                         isId, mkIdVar,
+                         idName, idType, idUnique, idInfo,
+                         setIdName, setVarType, setIdUnique, 
+                         setIdInfo, modifyIdInfo, maybeModifyIdInfo,
                          externallyVisibleId
                        )
 import VarSet
-import Type            ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
+import Type            ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
 import IdInfo
-import Demand          ( Demand )
-import Name            ( Name, OccName, 
+import Demand          ( Demand, isStrict, wwLazy )
+import Name            ( Name, OccName,
                          mkSysLocalName, mkLocalName,
-                         isWiredInName, setNameVisibility, mkNameVisible
+                         isWiredInName, isUserExportedName
                        ) 
 import Const           ( Con(..) )
 import PrimRep         ( PrimRep )
 import PrimOp          ( PrimOp )
+import TysPrim         ( realWorldStatePrimTy )
 import FieldLabel      ( FieldLabel(..) )
-import BasicTypes      ( Module )
+import SrcLoc          ( SrcLoc )
 import Unique          ( Unique, mkBuiltinUnique, getBuiltinUniques )
 import Outputable
 
@@ -85,9 +94,13 @@ infixl       1 `setIdUnfolding`,
          `setIdArity`,
          `setIdDemandInfo`,
          `setIdStrictness`,
+         `setIdWorkerInfo`,
          `setIdSpecialisation`,
          `setIdUpdateInfo`,
-         `setInlinePragma`
+         `setInlinePragma`,
+         `getIdCafInfo`,
+         `getIdCprInfo`
+
        -- infixl so you can say (id `set` a `set` b)
 \end{code}
 
@@ -99,23 +112,30 @@ infixl     1 `setIdUnfolding`,
 %*                                                                     *
 %************************************************************************
 
-\begin{code}
-mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
-mkVanillaId name ty = mkId name ty VanillaId noIdInfo
+Absolutely all Ids are made by mkId.  It 
+       a) Pins free-tyvar-info onto the Id's type, 
+          where it can easily be found.
+       b) Ensures that exported Ids are 
 
-mkImportedId :: Name -> Type -> IdInfo -> Id
-mkImportedId name ty info = mkId name ty VanillaId info
+\begin{code}
+mkId :: Name -> Type -> IdInfo -> Id
+mkId name ty info = mkIdVar name (addFreeTyVars ty) info'
+                 where
+                   info' | isUserExportedName name = setNoDiscardInfo info
+                         | otherwise               = info
+\end{code}
 
-mkUserId :: Name -> GenType flexi -> GenId flexi
-mkUserId name ty = mkVanillaId name ty
+\begin{code}
+mkVanillaId :: Name -> Type -> Id
+mkVanillaId name ty = mkId name ty vanillaIdInfo
 
 -- SysLocal: for an Id being created by the compiler out of thin air...
 -- UserLocal: an Id with a name the user might recognize...
-mkUserLocal :: OccName -> Unique -> GenType flexi -> GenId flexi
-mkSysLocal  ::            Unique -> GenType flexi -> GenId flexi
+mkUserLocal :: OccName     -> Unique -> Type -> SrcLoc -> Id
+mkSysLocal  :: FAST_STRING -> Unique -> Type -> Id
 
-mkSysLocal  uniq ty     = mkVanillaId (mkSysLocalName uniq)  ty
-mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
+mkSysLocal  fs uniq ty      = mkVanillaId (mkSysLocalName uniq fs)      ty
+mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName    uniq occ loc) ty
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
@@ -125,13 +145,16 @@ instantiated before use.
 \begin{code}
 -- "Wild Id" typically used when you need a binder that you don't expect to use
 mkWildId :: Type -> Id
-mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty
+mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
 
 -- "Template locals" typically used in unfoldings
 mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith mkSysLocal
+mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
                               (getBuiltinUniques (length tys))
                               tys
+
+mkTemplateLocal :: Int -> Type -> Id
+mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
 \end{code}
 
 
@@ -142,10 +165,10 @@ mkTemplateLocals tys = zipWith mkSysLocal
 %************************************************************************
 
 \begin{code}
-idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi)
+idFreeTyVars :: Id -> TyVarSet
 idFreeTyVars id = tyVarsOfType (idType id)
 
-setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2
+setIdType :: Id -> Type -> Id
        -- Add free tyvar info to the type
 setIdType id ty = setVarType id (addFreeTyVars ty)
 
@@ -153,39 +176,6 @@ idPrimRep :: Id -> PrimRep
 idPrimRep id = typePrimRep (idType id)
 \end{code}
 
-omitIfaceSigForId tells whether an Id's info is implied by other declarations,
-so we don't need to put its signature in an interface file, even if it's mentioned
-in some other interface unfolding.
-
-\begin{code}
-omitIfaceSigForId :: Id -> Bool
-omitIfaceSigForId id
-  | isWiredInName (idName id)
-  = True
-
-  | otherwise
-  = case varDetails id of
-       RecordSelId _  -> True  -- Includes dictionary selectors
-        ConstantId _   -> True
-               -- ConstantIds are implied by their type or class decl;
-               -- remember that all type and class decls appear in the interface file.
-               -- The dfun id must *not* be omitted, because it carries version info for
-               -- the instance decl
-
-       other          -> False -- Don't omit!
-\end{code}
-
-See notes with setNameVisibility (Name.lhs)
-
-\begin{code}
-setIdVisibility :: Maybe Module -> Unique -> Id -> Id
-setIdVisibility maybe_mod u id
-  = setIdName id (setNameVisibility maybe_mod u (idName id))
-
-mkIdVisible :: Module -> Unique -> Id -> Id
-mkIdVisible mod u id 
-  = setIdName id (mkNameVisible mod u (idName id))
-\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -194,28 +184,81 @@ mkIdVisible mod u id
 %************************************************************************
 
 \begin{code}
+idFlavour :: Id -> IdFlavour
+idFlavour id = flavourInfo (idInfo id)
+
+setIdNoDiscard :: Id -> Id
+setIdNoDiscard id      -- Make an Id into a NoDiscardId, unless it is already
+  = modifyIdInfo setNoDiscardInfo id
+
 recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case varDetails id of
+recordSelectorFieldLabel id = case idFlavour id of
                                RecordSelId lbl -> lbl
 
-isRecordSelector id = case varDetails id of
+isRecordSelector id = case idFlavour id of
                        RecordSelId lbl -> True
                        other           -> False
 
-isPrimitiveId_maybe id = case varDetails id of
+isPrimitiveId_maybe id = case idFlavour id of
                            ConstantId (PrimOp op) -> Just op
                            other                  -> Nothing
 
-isDataConId_maybe id = case varDetails id of
+isDataConId_maybe id = case idFlavour id of
                          ConstantId (DataCon con) -> Just con
                          other                    -> Nothing
 
-isConstantId id = case varDetails id of
+isConstantId id = case idFlavour id of
                    ConstantId _ -> True
                    other        -> False
+
+isSpecPragmaId id = case idFlavour id of
+                       SpecPragmaId -> True
+                       other        -> False
+
+-- Don't drop a binding for an exported Id,
+-- if it otherwise looks dead.  
+isExportedId :: Id -> Bool
+isExportedId id = case idFlavour id of
+                       VanillaId -> False
+                       other     -> True       -- All the others are no-discard
+
+-- Say if an Id was exported by the user
+-- Implies isExportedId (see mkId above)
+isUserExportedId :: Id -> Bool
+isUserExportedId id = isUserExportedName (idName id)
 \end{code}
 
 
+omitIfaceSigForId tells whether an Id's info is implied by other declarations,
+so we don't need to put its signature in an interface file, even if it's mentioned
+in some other interface unfolding.
+
+\begin{code}
+omitIfaceSigForId :: Id -> Bool
+omitIfaceSigForId id
+  | isWiredInName (idName id)
+  = True
+
+  | otherwise
+  = case idFlavour id of
+       RecordSelId _  -> True  -- Includes dictionary selectors
+        ConstantId _   -> True
+               -- ConstantIds are implied by their type or class decl;
+               -- remember that all type and class decls appear in the interface file.
+               -- The dfun id must *not* be omitted, because it carries version info for
+               -- the instance decl
+
+       other          -> False -- Don't omit!
+
+-- Certain names must be exported with their original occ names, because
+-- these names are bound by either a class declaration or a data declaration
+-- or an explicit user export.
+exportWithOrigOccName :: Id -> Bool
+exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id
+\end{code}
+
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{IdInfo stuff}
@@ -225,62 +268,82 @@ isConstantId id = case varDetails id of
 \begin{code}
        ---------------------------------
        -- ARITY
-getIdArity :: GenId flexi -> ArityInfo
+getIdArity :: Id -> ArityInfo
 getIdArity id = arityInfo (idInfo id)
 
-setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
-setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
+setIdArity :: Id -> ArityInfo -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
        ---------------------------------
        -- STRICTNESS
-getIdStrictness :: GenId flexi -> StrictnessInfo
+getIdStrictness :: Id -> StrictnessInfo
 getIdStrictness id = strictnessInfo (idInfo id)
 
-setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
-setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
+setIdStrictness :: Id -> StrictnessInfo -> Id
+setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
+
+-- isBottomingId returns true if an application to n args would diverge
+isBottomingId :: Id -> Bool
+isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
+
+idAppIsBottom :: Id -> Int -> Bool
+idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
+
+       ---------------------------------
+       -- WORKER ID
+getIdWorkerInfo :: Id -> WorkerInfo
+getIdWorkerInfo id = workerInfo (idInfo id)
 
-isBottomingId :: GenId flexi -> Bool
-isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
+setIdWorkerInfo :: Id -> WorkerInfo -> Id
+setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
 
        ---------------------------------
        -- UNFOLDING
-getIdUnfolding :: GenId flexi -> Unfolding
+getIdUnfolding :: Id -> Unfolding
 getIdUnfolding id = unfoldingInfo (idInfo id)
 
-setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
-setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
+setIdUnfolding :: Id -> Unfolding -> Id
+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
        ---------------------------------
        -- DEMAND
-getIdDemandInfo :: GenId flexi -> Demand
+getIdDemandInfo :: Id -> Demand
 getIdDemandInfo id = demandInfo (idInfo id)
 
-setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
-setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
+setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
 
        ---------------------------------
        -- UPDATE INFO
-getIdUpdateInfo :: GenId flexi -> UpdateInfo
+getIdUpdateInfo :: Id -> UpdateInfo
 getIdUpdateInfo id = updateInfo (idInfo id)
 
-setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
-setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
+setIdUpdateInfo :: Id -> UpdateInfo -> Id
+setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id
 
        ---------------------------------
        -- SPECIALISATION
-getIdSpecialisation :: GenId flexi -> IdSpecEnv
+getIdSpecialisation :: Id -> CoreRules
 getIdSpecialisation id = specInfo (idInfo id)
 
-setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
-setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
+setIdSpecialisation :: Id -> CoreRules -> Id
+setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
 
        ---------------------------------
        -- CAF INFO
-getIdCafInfo :: GenId flexi -> CafInfo
+getIdCafInfo :: Id -> CafInfo
 getIdCafInfo id = cafInfo (idInfo id)
 
-setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
-setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
+setIdCafInfo :: Id -> CafInfo -> Id
+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+
+       ---------------------------------
+       -- CPR INFO
+getIdCprInfo :: Id -> CprInfo
+getIdCprInfo id = cprInfo (idInfo id)
+
+setIdCprInfo :: Id -> CprInfo -> Id
+setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
 \end{code}
 
 
@@ -290,32 +353,48 @@ 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}
-getInlinePragma :: GenId flexi -> InlinePragInfo
+getInlinePragma :: Id -> InlinePragInfo
 getInlinePragma id = inlinePragInfo (idInfo id)
 
-setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
-setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
-
-modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
-modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
+setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 
-idWantsToBeINLINEd :: GenId flexi -> Bool
-idWantsToBeINLINEd id = case getInlinePragma id of
-                         IWantToBeINLINEd -> True
-                         IMustBeINLINEd   -> True
-                         other            -> False
+modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
 
 idMustNotBeINLINEd id = case getInlinePragma id of
                          IMustNotBeINLINEd -> True
-                         IAmASpecPragmaId  -> True
                          IAmALoopBreaker   -> True
                          other             -> False
 
 idMustBeINLINEd id =  case getInlinePragma id of
                        IMustBeINLINEd -> True
                        other          -> False
+\end{code}
+
 
-isSpecPragmaId id = case getInlinePragma id of
-                       IAmASpecPragmaId -> True
-                       other            -> False
+       ---------------------------------
+       -- ONE-SHOT LAMBDAS
+\begin{code}
+isOneShotLambda :: Id -> Bool
+isOneShotLambda id = case lbvarInfo (idInfo id) of
+                       IsOneShotLambda -> True
+                       NoLBVarInfo     -> idType id == realWorldStatePrimTy
+       -- 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.
+
+setOneShotLambda :: Id -> Id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
 \end{code}