X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FId.lhs;h=5ac261255cb787d280a1bd86395b24d2622b6076;hp=36406939a855ffd338f5a1ff2f6a4855714a870e;hb=914e415702a25a6e52ab1eaaf2aea233d6c6097e;hpb=5c248c7dfa9b789df31ca5186c4f181f1e8eb42b

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 3640693..5ac2612 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -23,7 +23,7 @@
 -- * 'Var.Var': see "Var#name_types"
 module Id (
         -- * The main types
-	Id, DictId,
+	Var, Id, isId,
 
 	-- ** Simple construction
 	mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
@@ -34,8 +34,7 @@ module Id (
 
 	-- ** Taking an Id apart
 	idName, idType, idUnique, idInfo, idDetails,
-	isId, idPrimRep,
-	recordSelectorFieldLabel,
+	idPrimRep, recordSelectorFieldLabel,
 
 	-- ** Modifying an Id
 	setIdName, setIdUnique, Id.setIdType, 
@@ -46,10 +45,11 @@ module Id (
 	
 
 	-- ** Predicates on Ids
-	isImplicitId, isDeadBinder, isDictId, isStrictId,
+	isImplicitId, isDeadBinder, 
+        isStrictId,
 	isExportedId, isLocalId, isGlobalId,
 	isRecordSelector, isNaughtyRecordSelector,
-	isClassOpId_maybe, isDFunId,
+        isClassOpId_maybe, isDFunId, dfunNSilent,
 	isPrimOpId, isPrimOpId_maybe, 
 	isFCallId, isFCallId_maybe,
 	isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
@@ -57,6 +57,9 @@ module Id (
         isTickBoxOp, isTickBoxOp_maybe,
 	hasNoBinding, 
 
+	-- ** Evidence variables
+	DictId, isDictId, isEvVar, evVarPred,
+
 	-- ** Inline pragma stuff
 	idInlinePragma, setInlinePragma, modifyInlinePragma,
         idInlineActivation, setInlineActivation, idRuleMatchInfo,
@@ -76,6 +79,7 @@ module Id (
 	idOccInfo,
 
 	-- ** Writing 'IdInfo' fields
+	setIdUnfoldingLazily,
 	setIdUnfolding,
 	setIdArity,
 	setIdDemandInfo, 
@@ -94,8 +98,8 @@ import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 
-import Var( Var, Id, DictId,
-            idInfo, idDetails, globaliseId,
+import Var( Var, Id, DictId, EvVar,
+            idInfo, idDetails, globaliseId, varType,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
 
@@ -119,7 +123,8 @@ import Util( count )
 import StaticFlags
 
 -- infixl so you can say (id `set` a `set` b)
-infixl 	1 `setIdUnfolding`,
+infixl 	1 `setIdUnfoldingLazily`,
+	  `setIdUnfolding`,
 	  `setIdArity`,
 	  `setIdOccInfo`,
 	  `setIdDemandInfo`,
@@ -170,7 +175,7 @@ localiseId :: Id -> Id
 -- Make an with the same unique and type as the 
 -- incoming Id, but with an *Internal* Name and *LocalId* flavour
 localiseId id 
-  | isLocalId id && isInternalName name
+  | ASSERT( isId id ) isLocalId id && isInternalName name
   = id
   | otherwise
   = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id)
@@ -330,8 +335,13 @@ isPrimOpId id = case Var.idDetails id of
                         _          -> False
 
 isDFunId id = case Var.idDetails id of
-                        DFunId _ -> True
-                        _        -> False
+                        DFunId {} -> True
+                        _         -> False
+
+dfunNSilent :: Id -> Int
+dfunNSilent id = case Var.idDetails id of
+                   DFunId ns _ -> ns
+                   _ -> pprTrace "dfunSilent: not a dfun:" (ppr id) 0
 
 isPrimOpId_maybe id = case Var.idDetails id of
                         PrimOpId op -> Just op
@@ -365,10 +375,6 @@ idDataCon :: Id -> DataCon
 -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
 idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
 
-
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
-
 hasNoBinding :: Id -> Bool
 -- ^ Returns @True@ of an 'Id' which may not have a
 -- binding, even though it is defined in this module.
@@ -441,6 +447,26 @@ isTickBoxOp_maybe id =
 
 %************************************************************************
 %*									*
+              Evidence variables									
+%*									*
+%************************************************************************
+
+\begin{code}
+isEvVar :: Var -> Bool
+isEvVar var = isPredTy (varType var)
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+evVarPred :: EvVar -> PredType
+evVarPred var
+  = case splitPredTy_maybe (varType var) of
+      Just pred -> pred
+      Nothing   -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection{IdInfo stuff}
 %*									*
 %************************************************************************
@@ -496,6 +522,9 @@ realIdUnfolding :: Id -> Unfolding
 -- Expose the unfolding if there is one, including for loop breakers
 realIdUnfolding id = unfoldingInfo (idInfo id)
 
+setIdUnfoldingLazily :: Id -> Unfolding -> Id
+setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfolding) id
+
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id