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

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

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 20166c8..6e77dc7 100644 (file)
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -12,8 +12,8 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 \begin{code}
 module CgClosure ( cgTopRhsClosure, 
                   cgStdRhsClosure, 
-                  cgRhsClosure, 
-                  closureCodeBody ) where
+                  cgRhsClosure,
+                  ) where
 
 #include "HsVersions.h"
 
@@ -39,7 +39,6 @@ import Name           ( Name, isInternalName )
 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..), getPrimRepSize )
-import PprType          ( showTypeCategory )
 import Util            ( isIn, splitAtList )
 import CmdLineOpts     ( opt_SccProfilingOn )
 import Outputable
@@ -47,6 +46,12 @@ import FastString
 
 import Name             ( nameOccName )
 import OccName          ( occNameFS )
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType          ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
+import TyCon           ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
+import Maybe
 \end{code}
 
 %********************************************************
@@ -70,8 +75,11 @@ cgTopRhsClosure :: Id
 
 cgTopRhsClosure id ccs binder_info srt args body lf_info
   = 
+    let
+       name          = idName id
+    in
     -- LAY OUT THE OBJECT
-    getSRTInfo srt             `thenFC` \ srt_info ->
+    getSRTInfo name srt                `thenFC` \ srt_info ->
     moduleName                 `thenFC` \ mod_name ->
     let
        name          = idName id
@@ -177,10 +185,12 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info
        reduced_fvs    = if binder_is_a_fv
                         then fvs `minusList` [binder]
                         else fvs
+
+       name = idName binder
     in
 
     mapFCs getCAddrModeAndInfo reduced_fvs     `thenFC` \ fvs_w_amodes_and_info ->
-    getSRTInfo srt                             `thenFC` \ srt_info ->
+    getSRTInfo name srt                                `thenFC` \ srt_info ->
     moduleName                                 `thenFC` \ mod_name ->
     let
        descr = closureDescription mod_name (idName binder)
@@ -303,7 +313,7 @@ closureCodeBody binder_info closure_info cc all_args body
     --
     (case closureFunInfo closure_info of
        Just (_, ArgGen slow_lbl liveness) -> 
-               absC (CBitmap liveness) `thenC`
+               absC (maybeLargeBitmap liveness) `thenC`
                absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
                returnFC (mkRegSaveCode arg_regs arg_reps)
 
@@ -669,3 +679,55 @@ chooseDynCostCentres ccs args fvs body
     in
     (use_cc, blame_cc)
 \end{code}
+
+
+\begin{code}
+showTypeCategory :: Type -> Char
+  {-
+       {C,I,F,D}   char, int, float, double
+       T           tuple
+       S           other single-constructor type
+       {c,i,f,d}   unboxed ditto
+       t           *unpacked* tuple
+       s           *unpacked" single-cons...
+
+       v           void#
+       a           primitive array
+
+       E           enumeration type
+       +           dictionary, unless it's a ...
+       L           List
+       >           function
+       M           other (multi-constructor) data-con type
+       .           other type
+       -           reserved for others to mark as "uninteresting"
+    -}
+showTypeCategory ty
+  = if isDictTy ty
+    then '+'
+    else
+      case tcSplitTyConApp_maybe ty of
+       Nothing -> if isJust (tcSplitFunTy_maybe ty)
+                  then '>'
+                  else '.'
+
+       Just (tycon, _) ->
+          let utc = getUnique tycon in
+         if      utc == charDataConKey    then 'C'
+         else if utc == intDataConKey     then 'I'
+         else if utc == floatDataConKey   then 'F'
+         else if utc == doubleDataConKey  then 'D'
+         else if utc == smallIntegerDataConKey ||
+                 utc == largeIntegerDataConKey   then 'J'
+         else if utc == charPrimTyConKey  then 'c'
+         else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+               || utc == addrPrimTyConKey)                then 'i'
+         else if utc  == floatPrimTyConKey                then 'f'
+         else if utc  == doublePrimTyConKey               then 'd'
+         else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
+         else if isEnumerationTyCon tycon                 then 'E'
+         else if isTupleTyCon tycon                       then 'T'
+         else if isJust (maybeTyConSingleCon tycon)       then 'S'
+         else if utc == listTyConKey                      then 'L'
+         else 'M' -- oh, well...
+\end{code}