X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=86380ecaa6f071c12610b88537a05ce111a9935d;hb=99655406c82829dfc9663fc545a0e134c49fb79f;hp=651c007ae7e9413d949dd2fb06114a7824a8b124;hpb=7a236a564b90cd060612e1e979ce7d552da61fa1;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 651c007..86380ec 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: ClosureInfo.lhs,v 1.57 2003/05/14 09:13:56 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.62 2004/03/31 15:23:17 simonmar Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -17,7 +17,6 @@ module ClosureInfo (
 
 	mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
 	mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
-	UpdateFlag,
 
 	closureSize, closureNonHdrSize,
 	closureGoodStuffSize, closurePtrsSize,
@@ -40,7 +39,6 @@ module ClosureInfo (
 	closureLFInfo, closureSMRep, closureUpdReqd,
 	closureSingleEntry, closureReEntrant, closureSemiTag,
 	closureFunInfo,	isStandardFormThunk,
-	GenStgArg,
 
 	isToplevClosure,
 	closureTypeDescr,		-- profiling
@@ -72,14 +70,14 @@ import Id		( Id, idType, idArity, idName, idPrimRep )
 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
@@ -89,6 +87,8 @@ import Bitmap
 
 import Maybe		( isJust )
 import DATA_BITS
+
+import TypeRep	-- TEMP
 \end{code}
 
 %************************************************************************
@@ -241,7 +241,9 @@ mkClosureLFInfo bndr top fvs upd_flag []
 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}
 
@@ -1054,6 +1056,27 @@ closureTypeDescr (ClosureInfo { closureType = ty })
   = 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}
 
 %************************************************************************
@@ -1127,8 +1150,8 @@ represented by a label+offset expression).
 \begin{code}
 mkInfoTable :: ClosureInfo -> [CAddrMode]
 mkInfoTable cl_info
- | opt_Unregisterised = std_info ++ extra_bits
- | otherwise          = extra_bits ++ std_info
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise        = std_info ++ extra_bits
  where
     std_info = mkStdInfoTable entry_amode
 		  ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
@@ -1184,8 +1207,8 @@ mkInfoTable cl_info
     (Just (arity, arg_descr)) = maybe_fun_stuff
 
     fun_extra_bits
-	| opt_Unregisterised = reverse reg_fun_extra_bits
-	| otherwise 	     = reg_fun_extra_bits
+	| tablesNextToCode = reg_fun_extra_bits
+	| otherwise        = reverse reg_fun_extra_bits
 
     reg_fun_extra_bits
 	| ArgGen slow_lbl liveness <- arg_descr
@@ -1229,8 +1252,8 @@ mkBitmapInfoTable
    -> [CAddrMode]
    -> [CAddrMode]
 mkBitmapInfoTable entry_amode srt liveness vector
- | opt_Unregisterised = std_info ++ extra_bits
- | otherwise          = extra_bits ++ std_info
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise        = std_info ++ extra_bits
  where
    std_info = mkStdInfoTable entry_amode zero_amode zero_amode 
 		cl_type srt_len liveness_amode
@@ -1253,8 +1276,8 @@ mkBitmapInfoTable entry_amode srt liveness vector
    srt_bit | needsSRT srt || not (null vector) = [srt_label]
 	   | otherwise = []
 
-   extra_bits | opt_Unregisterised = srt_bit ++ vector
-	      | otherwise          = reverse vector ++ srt_bit
+   extra_bits | tablesNextToCode = reverse vector ++ srt_bit
+              | otherwise        = srt_bit ++ vector
 
 -- The standard bits of an info table.  This part of the info table
 -- corresponds to the StgInfoTable type defined in InfoTables.h.
@@ -1271,8 +1294,8 @@ mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
  = std_info
  where  
     std_info
-	| opt_Unregisterised  = entry_lbl : std_info'
-	| otherwise 	      = std_info'
+	| tablesNextToCode = std_info'
+	| otherwise        = entry_lbl : std_info'
 
     std_info' =
 	  -- par info
@@ -1312,4 +1335,12 @@ livenessToAddrMode (Liveness lbl size bits)
 			_   -> panic "livenessToAddrMode"
 
 zero_amode = mkIntCLit 0
+
+-- IA64 mangler doesn't place tables next to code
+tablesNextToCode :: Bool
+#ifdef ia64_TARGET_ARCH
+tablesNextToCode = False
+#else
+tablesNextToCode = not opt_Unregisterised
+#endif
 \end{code}