%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.59 2003/10/09 11:58:46 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.62 2004/03/31 15:23:17 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
- UpdateFlag,
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureReEntrant, closureSemiTag,
closureFunInfo, isStandardFormThunk,
- GenStgArg,
isToplevClosure,
closureTypeDescr, -- profiling
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
-import Name ( Name, nameUnique, getOccName, getName )
+import Name ( Name, nameUnique, getOccName, getName, getOccString )
import OccName ( occNameUserString )
-import PprType ( getTyDescription )
import PrimRep
import SMRep -- all of it
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
-import TyCon ( isFunTyCon )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+import TcType ( tcSplitSigmaTy )
+import TyCon ( isFunTyCon, isAbstractTyCon )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
import Util ( mapAccumL, listLengthCmp, lengthIs )
import FastString
import Outputable
might_be_a_function :: Type -> Bool
might_be_a_function ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty),
- not (isFunTyCon tc) = False
+ not (isFunTyCon tc) && not (isAbstractTyCon tc) = False
+ -- don't forget to check for abstract types, which might
+ -- be functions too.
| otherwise = True
\end{code}
= getTyDescription ty
closureTypeDescr (ConInfo { closureCon = data_con })
= occNameUserString (getOccName (dataConTyCon data_con))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res -> '-' : '>' : fun_result res
+ NewTcApp tycon _ -> getOccString tycon
+ TyConApp tycon _ -> getOccString tycon
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
+ PredTy sty -> getPredTyDescription sty
+ ForAllTy _ ty -> getTyDescription ty
+ }
+ where
+ fun_result (FunTy _ res) = '>' : fun_result res
+ fun_result other = getTyDescription other
+
+getPredTyDescription (ClassP cl tys) = getOccString cl
+getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
%************************************************************************