[project @ 2005-02-20 01:36:23 by ross]

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

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 1a2cb50..cb848a1 100644 (file)
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -15,11 +15,11 @@ module Id (
 
        -- Taking an Id apart
        idName, idType, idUnique, idInfo,
-       idPrimRep, isId, globalIdDetails,
+       isId, globalIdDetails, idPrimRep,
        recordSelectorFieldLabel,
 
        -- Modifying an Id
-       setIdName, setIdUnique, Id.setIdType, setIdLocalExported, setGlobalIdDetails,
+       setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, 
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
        zapLamIdInfo, zapDemandIdInfo, 
 
@@ -38,7 +38,8 @@ module Id (
 
 
        -- One shot lambda stuff
-       isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+       isOneShotBndr, isOneShotLambda, isStateHackType,
+       setOneShotLambda, clearOneShotLambda,
 
        -- IdInfo stuff
        setIdUnfolding,
@@ -78,19 +79,22 @@ module Id (
 #include "HsVersions.h"
 
 
-import CoreSyn         ( Unfolding, CoreRules, IdCoreRule, rulesRules )
+import CoreSyn         ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
 import BasicTypes      ( Arity )
 import Var             ( Id, DictId,
                          isId, isExportedId, isSpecPragmaId, isLocalId,
                          idName, idType, idUnique, idInfo, isGlobalId,
-                         setIdName, setIdType, setIdUnique, setIdLocalExported,
+                         setIdName, setIdType, setIdUnique, 
+                         setIdExported, setIdNotExported,
                          setIdInfo, lazySetIdInfo, modifyIdInfo, 
                          maybeModifyIdInfo,
-                         globalIdDetails, setGlobalIdDetails
+                         globalIdDetails
                        )
 import qualified Var   ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
-import Type            ( Type, typePrimRep, addFreeTyVars, seqType)
-
+import TyCon           ( FieldLabel, TyCon )
+import Type            ( Type, typePrimRep, addFreeTyVars, seqType, 
+                         splitTyConApp_maybe, PrimRep )
+import TysPrim         ( statePrimTyCon )
 import IdInfo 
 
 #ifdef OLD_STRICTNESS
@@ -104,12 +108,11 @@ import Name               ( Name, OccName, nameIsLocalOrFrom,
                        ) 
 import Module          ( Module )
 import OccName         ( EncodedFS, mkWorkerOcc )
-import PrimRep         ( PrimRep )
-import FieldLabel      ( FieldLabel )
 import Maybes          ( orElse )
 import SrcLoc          ( SrcLoc )
 import Outputable
 import Unique          ( Unique, mkBuiltinUnique )
+import CmdLineOpts     ( opt_NoStateHack )
 
 -- infixl so you can say (id `set` a `set` b)
 infixl         1 `setIdUnfolding`,
@@ -237,13 +240,13 @@ Meanwhile, it is not discarded as dead code.
 
 
 \begin{code}
-recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
 recordSelectorFieldLabel id = case globalIdDetails id of
-                                RecordSelId lbl -> lbl
+                                RecordSelId tycon lbl -> (tycon,lbl)
                                 other -> panic "recordSelectorFieldLabel"
 
 isRecordSelector id = case globalIdDetails id of
-                       RecordSelId lbl -> True
+                       RecordSelId _ _ -> True
                        other           -> False
 
 isPrimOpId id = case globalIdDetails id of
@@ -288,7 +291,7 @@ isImplicitId :: Id -> Bool
        -- file, even if it's mentioned in some other interface unfolding.
 isImplicitId id
   = case globalIdDetails id of
-       RecordSelId _   -> True
+       RecordSelId _ _ -> True
         FCallId _       -> True
         PrimOpId _      -> True
        ClassOpId _     -> True
@@ -393,7 +396,7 @@ idSpecialisation :: Id -> CoreRules
 idSpecialisation id = specInfo (idInfo id)
 
 idCoreRules :: Id -> [IdCoreRule]
-idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)]
 
 setIdSpecialisation :: Id -> CoreRules -> Id
 setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
@@ -455,6 +458,39 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (
 idLBVarInfo :: Id -> LBVarInfo
 idLBVarInfo id = lbvarInfo (idInfo id)
 
+isOneShotBndr :: Id -> Bool
+-- This one is the "business end", called externally.
+-- Its main purpose is to encapsulate the Horrible State Hack
+isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id))
+
+isStateHackType :: Type -> Bool
+isStateHackType ty
+  | opt_NoStateHack 
+  = False
+  | otherwise
+  = case splitTyConApp_maybe ty of
+       Just (tycon,_) -> tycon == statePrimTyCon
+        other          -> False
+       -- This 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.
+       --
+       -- Another good example is in fill_in in PrelPack.lhs.  We should be able to
+       -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+
+
+-- The OneShotLambda functions simply fiddle with the IdInfo flag
 isOneShotLambda :: Id -> Bool
 isOneShotLambda id = case idLBVarInfo id of
                        IsOneShotLambda  -> True