[project @ 1997-09-30 10:26:40 by simonm]

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

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 5d06570..673dd7a 100644 (file)
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -13,7 +13,11 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
 
 IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(CgLoop2)       ( cgExpr )
+#else
+import {-# SOURCE #-} CgExpr ( cgExpr )
+#endif
 
 import CgMonad
 import AbsCSyn
@@ -49,27 +53,25 @@ import ClosureInfo  -- lots and lots of stuff
 import CmdLineOpts     ( opt_ForConcurrent, opt_GranMacros )
 import CostCentre      ( useCurrentCostCentre, currentOrSubsumedCosts,
                          noCostCentreAttached, costsAreSubsumed,
-                         isCafCC, isDictCC, overheadCostCentre, showCostCentre
+                         isCafCC, isDictCC, overheadCostCentre, showCostCentre,
+                         CostCentre
                        )
 import HeapOffs                ( SYN_IE(VirtualHeapOffset) )
 import Id              ( idType, idPrimRep, 
                          showId, getIdStrictness, dataConTag,
                          emptyIdSet,
-                         GenId{-instance Outputable-}
+                         GenId{-instance Outputable-}, SYN_IE(Id)
                        )
 import ListSetOps      ( minusList )
 import Maybes          ( maybeToBool )
-import Outputable      ( Outputable(..){-instances-} ) -- ToDo:rm
-import PprStyle                ( PprStyle(..) )
+import Outputable      ( Outputable(..){-instances-}, PprStyle(..) )
 import PprType         ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty          ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
+import Pretty          ( Doc, hcat, char, ptext, hsep, text )
 import PrimRep         ( isFollowableRep, PrimRep(..) )
 import TyCon           ( isPrimTyCon, tyConDataCons )
-import Unpretty                ( uppShow )
+import Type             ( showTypeCategory )
 import Util            ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
 
-myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
-showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
 \end{code}
 
@@ -434,6 +436,10 @@ closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention id lf_info
                       (map idPrimRep all_args)         `thenFC` \ entry_conv ->
     let
+       -- Figure out what is needed and what isn't
+       slow_code_needed   = slowFunEntryCodeRequired id binder_info entry_conv
+       info_table_needed  = funInfoTableRequired id binder_info lf_info
+
        -- Arg mapping for standard (slow) entry point; all args on stack
        (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
           = mkVirtStkOffsets
@@ -550,10 +556,6 @@ closureCodeBody binder_info closure_info cc all_args body
 
     cl_descr mod_name = closureDescription mod_name id all_args body
 
-       -- Figure out what is needed and what isn't
-    slow_code_needed   = slowFunEntryCodeRequired id binder_info
-    info_table_needed  = funInfoTableRequired id binder_info lf_info
-
        -- Manufacture labels
     id        = closureId closure_info
     fast_label = mkFastEntryLabel id stg_arity
@@ -563,7 +565,7 @@ closureCodeBody binder_info closure_info cc all_args body
     wrapper_maybe = get_ultimate_wrapper Nothing id
       where
        get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
-         = case (myWrapperMaybe x) of
+         = case myWrapperMaybe x of
              Nothing -> deflt
              Just xx -> get_ultimate_wrapper (Just xx) xx
 
@@ -603,7 +605,7 @@ enterCostCentreCode closure_info cc is_thunk
        if costsAreSubsumed cc then
            --ASSERT(isToplevClosure closure_info)
            --ASSERT(is_thunk == IsFunction)
-           (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
+           (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, text (showCostCentre PprDebug False cc)])) $
            costCentresC SLIT("ENTER_CC_FSUB") []
 
        else if currentOrSubsumedCosts cc then 
@@ -916,12 +918,12 @@ closureDescription :: FAST_STRING -- Module
        -- CgConTbls.lhs with a description generated from the data constructor
 
 closureDescription mod_name name args body
-  = uppShow 0 (prettyToUn (
-       ppBesides [ppChar '<',
-                  ppPStr mod_name,
-                  ppChar '.',
+  = show (
+       hcat [char '<',
+                  ptext mod_name,
+                  char '.',
                   ppr PprDebug name,
-                  ppChar '>']))
+                  char '>'])
 \end{code}
 
 \begin{code}
@@ -980,7 +982,7 @@ mkWrapperArgTypeCategories wrapper_ty wrap_info
     do_one (WwPrim, _) = 'P'
     do_one (WwEnum, _) = 'E'
     do_one (WwStrict, arg_ty_char) = arg_ty_char
-    do_one (WwUnpack _, arg_ty_char)
+    do_one (WwUnpack _ _ _, arg_ty_char)
       = if arg_ty_char `elem` "CIJFDTS"
        then toLower arg_ty_char
        else if arg_ty_char == '+' then 't'