[project @ 2003-11-17 14:23:30 by simonmar]

[ghc-hetmet.git] / ghc / compiler / codeGen / ClosureInfo.lhs

diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 651c007..2de8802 100644 (file)
--- 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.61 2003/11/17 14:23:31 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 TcType          ( tcSplitSigmaTy )
 import TyCon           ( isFunTyCon )
-import BasicTypes      ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+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}
 
 %************************************************************************
@@ -1054,6 +1054,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 +1148,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 +1205,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 +1250,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 +1274,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 +1292,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 +1333,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}