[project @ 2000-07-14 08:14:53 by simonpj]

[ghc-hetmet.git] / ghc / compiler / absCSyn / PprAbsC.lhs

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index ce7180e..d4379e8 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

 %
 %************************************************************************
 %*                                                                     *
 %
 %************************************************************************
 %*                                                                     *

@@ -10,10 +10,9 @@
 \begin{code}
 module PprAbsC (
        writeRealC,
 \begin{code}
 module PprAbsC (
        writeRealC,

-       dumpRealC
-#ifdef DEBUG
-       , pprAmode -- otherwise, not exported
-#endif
+       dumpRealC,
+       pprAmode,
+       pprMagicId

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -25,31 +24,42 @@ import ClosureInfo
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )

-import CallConv                ( CallConv, callConvAttribute, cCallConv )
-import Constants       ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+
+import Constants       ( mIN_UPD_SIZE )
+import CallConv                ( callConvAttribute )

 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,

-                         isReadOnly, needsCDecl, pprCLabel,
-                         CLabel{-instance Ord-}
+                         needsCDecl, pprCLabel,
+                         mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+                         mkClosureLabel,
+                         CLabel, CLabelType(..), labelType, labelDynamic

                        )
                        )

-import CmdLineOpts     ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
-import CostCentre      ( uppCostCentre, uppCostCentreDecl )
+
+import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
+import CostCentre      ( pprCostCentreDecl, pprCostCentreStackDecl )
+

 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )
 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )

-import CStrings                ( stringToC )
+import CStrings                ( stringToC, pprCLabelString )

 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )

-import HeapOffs                ( isZeroOff, subOff, pprHeapOffset )
-import Literal         ( showLiteral, Literal(..) )
+import Literal         ( Literal(..) )
+import TyCon           ( tyConDataCons )
+import Name            ( NamedThing(..) )
+import DataCon         ( DataCon{-instance NamedThing-}, dataConWrapId )

 import Maybes          ( maybeToBool, catMaybes )
 import Maybes          ( maybeToBool, catMaybes )

-import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep         ( isFloatingRep, PrimRep(..), showPrimRep )
-import SMRep           ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-                         isConstantRep, isSpecRep, isPhantomRep
-                       )
+import PrimOp          ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
+                         PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
+import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
+import SMRep           ( pprSMRep )

 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
 import UniqSet         ( emptyUniqSet, elementOfUniqSet,
                          addOneToUniqSet, UniqSet
                        )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
 import UniqSet         ( emptyUniqSet, elementOfUniqSet,
                          addOneToUniqSet, UniqSet
                        )

+import StgSyn          ( SRT(..) )
+import BitSet          ( intBS )

 import Outputable
 import Outputable

-import Util            ( nOfThem, panic, assertPanic )
+import Util            ( nOfThem )
+
+import ST
+import MutableArray

 
 infixr 9 `thenTE`
 \end{code}
 
 infixr 9 `thenTE`
 \end{code}

@@ -60,18 +70,34 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
 @pprAbsC@ has a new ``costs'' argument.  %% HWL
 
 \begin{code}
 @pprAbsC@ has a new ``costs'' argument.  %% HWL
 
 \begin{code}

-writeRealC :: Handle -> AbstractC -> SDoc -> IO ()
---writeRealC handle absC postlude = 
+{-
+writeRealC :: Handle -> AbstractC -> IO ()
+writeRealC handle absC
+     -- avoid holding on to the whole of absC in the !Gransim case.
+     if opt_GranMacros
+       then printForCFast fp (pprAbsC absC (costs absC))
+       else printForCFast fp (pprAbsC absC (panic "costs"))
+            --printForC handle (pprAbsC absC (panic "costs"))
+dumpRealC :: AbstractC -> SDoc
+dumpRealC absC = pprAbsC absC (costs absC)
+-}
+
+writeRealC :: Handle -> AbstractC -> IO ()
+--writeRealC handle absC = 

 -- _scc_ "writeRealC" 
 -- printDoc LeftMode handle (pprAbsC absC (costs absC))
 -- _scc_ "writeRealC" 
 -- printDoc LeftMode handle (pprAbsC absC (costs absC))

-writeRealC handle absC postlude = 
- _scc_ "writeRealC" 
- printForC handle (pprAbsC absC (costs absC) $$ postlude)
-
-dumpRealC :: AbstractC -> SDoc -> SDoc
-dumpRealC absC postlude 
- | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC)    $$ postlude)
- | otherwise     = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude)
+
+writeRealC handle absC
+ | opt_GranMacros = _scc_ "writeRealC" printForC handle $ 
+                                      pprCode CStyle (pprAbsC absC (costs absC))
+ | otherwise     = _scc_ "writeRealC" printForC handle $
+                                      pprCode CStyle (pprAbsC absC (panic "costs"))
+
+dumpRealC :: AbstractC -> SDoc
+dumpRealC absC
+ | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
+ | otherwise     = pprCode CStyle (pprAbsC absC (panic "costs"))
+

 \end{code}
 
 This emits the macro,  which is used in GrAnSim  to compute the total costs
 \end{code}
 
 This emits the macro,  which is used in GrAnSim  to compute the total costs

@@ -80,7 +106,8 @@ from a cost 5 tuple. %%  HWL
 \begin{code}
 emitMacro :: CostRes -> SDoc
 
 \begin{code}
 emitMacro :: CostRes -> SDoc
 

--- ToDo: Check a compile time flag to decide whether a macro should be emitted
+emitMacro _ | not opt_GranMacros = empty
+

 emitMacro (Cost (i,b,l,s,f))
   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                           int i, comma, int b, comma, int l, comma,
 emitMacro (Cost (i,b,l,s,f))
   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                           int i, comma, int b, comma, int l, comma,

@@ -98,10 +125,8 @@ pprAbsC :: AbstractC -> CostRes -> SDoc
 pprAbsC AbsCNop _ = empty
 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
 
 pprAbsC AbsCNop _ = empty
 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
 

-pprAbsC (CClosureUpdInfo info) c
-  = pprAbsC info c
-

 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src

+

 pprAbsC (CJump target) c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
             (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 pprAbsC (CJump target) c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
             (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])

@@ -118,12 +143,14 @@ pprAbsC (CReturn am return_info)  c
             (hcat [text jmp_lit, target, pp_paren_semi ])
   where
    target = case return_info of
             (hcat [text jmp_lit, target, pp_paren_semi ])
   where
    target = case return_info of

-       DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen]
+       DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
+                             pprAmode am, rparen]

        DynamicVectoredReturn am' -> mk_vector (pprAmode am')
        StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
        DynamicVectoredReturn am' -> mk_vector (pprAmode am')
        StaticVectoredReturn n -> mk_vector (int n)     -- Always positive

-   mk_vector x = hcat [parens (pprAmode am), brackets (text "RVREL" <> parens x)]
+   mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
+                      x, rparen ]

 
 

-pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
+pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")

 
 -- we optimise various degenerate cases of CSwitches.
 
 
 -- we optimise various degenerate cases of CSwitches.
 

@@ -148,8 +175,9 @@ pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
       Just dc ->               -- make it an "if"
                 do_if_stmt discrim tag alt_code dc c
 
       Just dc ->               -- make it an "if"
                 do_if_stmt discrim tag alt_code dc c
 

-pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
-                             (tag2@(MachInt i2 _), alt_code2)] deflt) c
+-- What problem is the re-ordering trying to solve ?
+pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
+                         (tag2@(MachInt i2), alt_code2)] deflt) c

   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
   = if (i1 == 0) then
        do_if_stmt discrim tag1 alt_code1 alt_code2 c
   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
   = if (i1 == 0) then
        do_if_stmt discrim tag1 alt_code1 alt_code2 c

@@ -185,10 +213,10 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 

-pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _ _) args liveness_mask vol_regs) _
-  = pprCCall op args results liveness_mask vol_regs
+pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
+  = pprCCall ccall args results vol_regs

 
 

-pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
+pprAbsC stmt@(COpStmt results op args vol_regs) _

   = let
        non_void_args = grab_non_void_amodes args
        non_void_results = grab_non_void_amodes results
   = let
        non_void_args = grab_non_void_amodes args
        non_void_results = grab_non_void_amodes results

@@ -200,15 +228,15 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
        the_op = ppr_op_call non_void_results non_void_args
                -- liveness mask is *in* the non_void_args
     in
        the_op = ppr_op_call non_void_results non_void_args
                -- liveness mask is *in* the non_void_args
     in

-    case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->

     if primOpNeedsWrapper op then
     if primOpNeedsWrapper op then

+       case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->

        vcat [  pp_saves,
                the_op,
                pp_restores
             ]
        vcat [  pp_saves,
                the_op,
                pp_restores
             ]

+       }

     else
        the_op
     else
        the_op

-    }

   where
     ppr_op_call results args
       = hcat [ pprPrimOp op, lparen,
   where
     ppr_op_call results args
       = hcat [ pprPrimOp op, lparen,

@@ -221,30 +249,86 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
       -- primop macros do their own casting of result;
       -- hence we can toss the provided cast...
 
       -- primop macros do their own casting of result;
       -- hence we can toss the provided cast...
 

+pprAbsC stmt@(CSRT lbl closures) c
+  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+         pp_exts
+      $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
+      $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
+         <> ptext SLIT("};")
+  }
+
+pprAbsC stmt@(CBitmap lbl mask) c
+  = vcat [
+       hcat [ ptext SLIT("BITMAP"), lparen, 
+                       pprCLabel lbl, comma,
+                       int (length mask), 
+              rparen ],
+        hcat (punctuate comma (map (int.intBS) mask)),
+       ptext SLIT("}};")
+    ]
+

 pprAbsC (CSimultaneous abs_c) c
   = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
 
 pprAbsC (CSimultaneous abs_c) c
   = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
 

-pprAbsC stmt@(CMacroStmt macro as) _
-  = hcat [text (show macro), lparen,
+pprAbsC (CCheck macro as code) c
+  = hcat [ptext (cCheckMacroText macro), lparen,
+       hcat (punctuate comma (map ppr_amode as)), comma,
+       pprAbsC code c, pp_paren_semi
+    ]
+pprAbsC (CMacroStmt macro as) _
+  = hcat [ptext (cStmtMacroText macro), lparen,

        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting

-pprAbsC stmt@(CCallProfCtrMacro op as) _
+pprAbsC (CCallProfCtrMacro op as) _

   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]

-pprAbsC stmt@(CCallProfCCMacro op as) _
+pprAbsC (CCallProfCCMacro op as) _

   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
   = hcat [ptext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]

-pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results args) _
-  =  hsep [ ptext SLIT("typedef")
+pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
+  =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))

          , ccall_res_ty
          , fun_nm
          , parens (hsep (punctuate comma ccall_decl_ty_args))
          ] <> semi
     where
          , ccall_res_ty
          , fun_nm
          , parens (hsep (punctuate comma ccall_decl_ty_args))
          ] <> semi
     where

-     fun_nm       = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+    {-
+      In the non-casm case, to ensure that we're entering the given external
+      entry point using the correct calling convention, we have to do the following:
+
+       - When entering via a function pointer (the `dynamic' case) using the specified
+         calling convention, we emit a typedefn declaration attributed with the
+         calling convention to use together with the result and parameter types we're
+         assuming. Coerce the function pointer to this type and go.
+
+        - to enter the function at a given code label, we emit an extern declaration
+         for the label here, stating the calling convention together with result and
+          argument types we're assuming. 
+
+          The C compiler will hopefully use this extern declaration to good effect,
+          reporting any discrepancies between our extern decl and any other that
+         may be in scope.
+    
+         Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
+         the external function `foo' use the calling convention of the first `foo'
+         prototype it encounters (nor does it complain about conflicting attribute
+         declarations). The consequence of this is that you cannot override the
+         calling convention of `foo' using an extern declaration (you'd have to use
+         a typedef), but why you would want to do such a thing in the first place
+         is totally beyond me.
+         
+         ToDo: petition the gcc folks to add code to warn about conflicting attribute
+         declarations.
+
+    -}
+
+     fun_nm
+       | is_tdef   = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+       | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty

 
      ccall_fun_ty = 
         case op_str of
 
      ccall_fun_ty = 
         case op_str of

-         Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+         DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+         StaticTarget x  -> pprCLabelString x

 
      ccall_res_ty = 
        case non_void_results of
 
      ccall_res_ty = 
        case non_void_results of

@@ -252,13 +336,16 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results a
          [amode]  -> text (showPrimRep (getAmodeRep amode))
          _        -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
 
          [amode]  -> text (showPrimRep (getAmodeRep amode))
          _        -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
 

-     ccall_decl_ty_args = tail ccall_arg_tys
+     ccall_decl_ty_args 
+       | is_tdef   = tail ccall_arg_tys
+       | otherwise = ccall_arg_tys
+

      ccall_arg_tys      = map (text.showPrimRep.getAmodeRep) non_void_args
 
       -- the first argument will be the "I/O world" token (a VoidRep)
       -- all others should be non-void
      non_void_args =
      ccall_arg_tys      = map (text.showPrimRep.getAmodeRep) non_void_args
 
       -- the first argument will be the "I/O world" token (a VoidRep)
       -- all others should be non-void
      non_void_args =

-       let nvas = tail args
+       let nvas = init args

        in ASSERT (all non_void nvas) nvas
 
       -- there will usually be two results: a (void) state which we
        in ASSERT (all non_void nvas) nvas
 
       -- there will usually be two results: a (void) state which we

@@ -267,117 +354,104 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results a
        let nvrs = grab_non_void_amodes results
        in ASSERT (length nvrs <= 1) nvrs
 
        let nvrs = grab_non_void_amodes results
        in ASSERT (length nvrs <= 1) nvrs
 

-pprAbsC (CCodeBlock label abs_C) _
-  = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+pprAbsC (CCodeBlock lbl abs_C) _
+  = if not (maybeToBool(nonemptyAbsC abs_C)) then
+       pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
+    else

     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [
     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [

-       hcat [text (if (externallyVisibleCLabel label)
+        empty,
+       pp_exts, 
+       hcat [text (if (externallyVisibleCLabel lbl)

                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),
                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),

-                  pprCLabel label, text ") {"],
+                  pprCLabel lbl, text ") {"],

 
 

-       pp_exts, pp_temps,
+       pp_temps,

 
        nest 8 (ptext SLIT("FB_")),
        nest 8 (pprAbsC abs_C (costs abs_C)),
        nest 8 (ptext SLIT("FE_")),
 
        nest 8 (ptext SLIT("FB_")),
        nest 8 (pprAbsC abs_C (costs abs_C)),
        nest 8 (ptext SLIT("FE_")),

-       char '}' ]
+       char '}',
+        char ' ' ]

     }
 
     }
 

-pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
-  = hcat [ pp_init_hdr, text "_HDR(",
-               ppr_amode (CAddr reg_rel), comma,
-               pprCLabel info_lbl, comma,
-               if_profiling (pprAmode cost_centre), comma,
-               pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
+
+pprAbsC (CInitHdr cl_info amode cost_centre) _
+  = hcat [ ptext SLIT("SET_HDR_"), char '(',
+               ppr_amode amode, comma,
+               pprCLabelAddr info_lbl, comma,
+               if_profiling (pprAmode cost_centre),
+               pp_paren_semi ]

   where
     info_lbl   = infoTableLabelFromCI cl_info
   where
     info_lbl   = infoTableLabelFromCI cl_info

-    sm_rep     = closureSMRep     cl_info
-    size       = closureSizeWithoutFixedHdr cl_info
-    ptr_wds    = closurePtrsSize  cl_info
-
-    pp_init_hdr = text (if inplace_upd then
-                           getSMUpdInplaceHdrStr sm_rep
-                       else
-                           getSMInitHdrStr sm_rep)

 
 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
     vcat [
        pp_exts,
        hcat [
 
 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
     vcat [
        pp_exts,
        hcat [

-               ptext SLIT("SET_STATIC_HDR"),char '(',
-               pprCLabel closure_lbl,                  comma,
+               ptext SLIT("SET_STATIC_HDR"), char '(',
+               pprCLabel closure_lbl,                          comma,

                pprCLabel info_lbl,                             comma,
                pprCLabel info_lbl,                             comma,

-               if_profiling (pprAmode cost_centre),    comma,
+               if_profiling (pprAmode cost_centre),            comma,

                ppLocalness closure_lbl,                        comma,
                ppLocalness closure_lbl,                        comma,

-               ppLocalnessMacro False{-for data-} info_lbl,
+               ppLocalnessMacro True{-include dyn-} info_lbl,

                char ')'
                ],
                char ')'
                ],

-       nest 2 (hcat (map ppr_item amodes)),
-       nest 2 (hcat (map ppr_item padding_wds)),
+       nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),

        ptext SLIT("};") ]
     }
   where
     info_lbl = infoTableLabelFromCI cl_info
 
        ptext SLIT("};") ]
     }
   where
     info_lbl = infoTableLabelFromCI cl_info
 

+    ppr_payload [] = empty
+    ppr_payload ls = comma <+> 
+                    braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
+

     ppr_item item
     ppr_item item

-      = if getAmodeRep item == VoidRep
-       then text ", (W_) 0" -- might not even need this...
-       else (<>) (text ", (W_)") (ppr_amode item)
+      | rep == VoidRep   = text "0" -- might not even need this...
+      | rep == FloatRep  = ppr_amode (floatToWord item)
+      | rep == DoubleRep = hcat (punctuate (text ", (L_)")
+                                (map ppr_amode (doubleToWords item)))
+      | otherwise       = ppr_amode item
+      where 
+       rep = getAmodeRep item

 
     padding_wds =
        if not (closureUpdReqd cl_info) then
            []
        else
 
     padding_wds =
        if not (closureUpdReqd cl_info) then
            []
        else

-           case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+           case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->

            nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 
            nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 

-{-
-   STATIC_INIT_HDR(c,i,localness) blows into:
-       localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
-
-   then *NO VarHdr STUFF FOR STATIC*...
-
-   then the amodes are dropped in...
-       ,a1 ,a2 ... ,aN
-   then a close brace:
-       };
--}
+    static_link_field
+       | staticClosureNeedsLink cl_info = [mkIntCLit 0]
+       | otherwise                      = []

 
 

-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
+pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _

   = vcat [
        hcat [
   = vcat [
        hcat [

-           pp_info_rep,
-           ptext SLIT("_ITBL"),char '(',
-           pprCLabel info_lbl,                 comma,
-
-               -- CONST_ITBL needs an extra label for
-               -- the static version of the object.
-           if isConstantRep sm_rep
-           then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma
-           else empty,
-
-           pprCLabel slow_lbl, comma,
-           pprAmode upd,               comma,
-           int liveness,               comma,
+            ptext SLIT("INFO_TABLE"),
+            ( if is_selector then
+                ptext SLIT("_SELECTOR")
+              else if is_constr then
+                ptext SLIT("_CONSTR")
+              else if needs_srt then
+                ptext SLIT("_SRT")
+               else empty ), char '(',
+
+           pprCLabel info_lbl,                         comma,
+           pprCLabel slow_lbl,                         comma,
+           pp_rest, {- ptrs,nptrs,[srt,]type,-}        comma,
+
+           ppLocalness info_lbl,                          comma,
+           ppLocalnessMacro True{-include dyn-} slow_lbl, comma,

 
 

-           pp_tag,                     comma,
-           pp_size,                    comma,
-           pp_ptr_wds,                 comma,
-
-           ppLocalness info_lbl,                               comma,
-           ppLocalnessMacro True{-function-} slow_lbl,         comma,
-
-           if is_selector
-           then (<>) (int select_word_i) comma
-           else empty,
-
-           if_profiling pp_kind, comma,

            if_profiling pp_descr, comma,
            if_profiling pp_type,
            text ");"
            if_profiling pp_descr, comma,
            if_profiling pp_type,
            text ");"

-       ],
+            ],

        pp_slow,
        case maybe_fast of
            Nothing -> empty
        pp_slow,
        case maybe_fast of
            Nothing -> empty

@@ -387,7 +461,6 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness)
   where
     info_lbl   = infoTableLabelFromCI cl_info
     fast_lbl    = fastLabelFromCI cl_info
   where
     info_lbl   = infoTableLabelFromCI cl_info
     fast_lbl    = fastLabelFromCI cl_info

-    sm_rep     = closureSMRep    cl_info

 
     (slow_lbl, pp_slow)
       = case (nonemptyAbsC slow) of
 
     (slow_lbl, pp_slow)
       = case (nonemptyAbsC slow) of

@@ -398,78 +471,143 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness)
 
     maybe_selector = maybeSelectorInfo cl_info
     is_selector = maybeToBool maybe_selector
 
     maybe_selector = maybeSelectorInfo cl_info
     is_selector = maybeToBool maybe_selector

-    (Just (_, select_word_i)) = maybe_selector
+    (Just select_word_i) = maybe_selector

 
 

-    pp_info_rep            -- special stuff if it's a selector; otherwise, just the SMrep
-      = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
+    maybe_tag = closureSemiTag cl_info
+    is_constr = maybeToBool maybe_tag
+    (Just tag) = maybe_tag

 
 

-    pp_tag = int (closureSemiTag cl_info)
+    needs_srt = infoTblNeedsSRT cl_info
+    srt = getSRTInfo cl_info

 
 

-    is_phantom = isPhantomRep sm_rep
+    size = closureNonHdrSize cl_info

 
 

-    pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
-                int (closureNonHdrSize cl_info)
+    ptrs        = closurePtrsSize cl_info
+    nptrs      = size - ptrs

 
 

-             else if is_phantom then   -- do not have sizes for these
-                empty
-             else
-                pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
+    pp_rest | is_selector      = int select_word_i
+            | otherwise        = hcat [
+                 int ptrs,             comma,
+                 int nptrs,            comma,
+                 if is_constr then
+                       hcat [ int tag, comma ]
+                  else if needs_srt then
+                       pp_srt_info srt
+                 else empty,
+                 type_str ]

 
 

-    pp_ptr_wds = if is_phantom then
-                    empty
-                 else
-                    int (closurePtrsSize cl_info)
+    type_str = pprSMRep (closureSMRep cl_info)

 
 

-    pp_kind  = text (closureKind cl_info)

     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 
     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 

-pprAbsC (CRetVector lbl maybes deflt) c
-  = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
-              nest 8 (sep (map ppr_maybe_amode maybes)),
-              text "} /*default=*/ {", pprAbsC deflt c,
-              char '}']
-  where
-    ppr_maybe_amode Nothing  = ptext SLIT("/*default*/")
-    ppr_maybe_amode (Just a) = pprAmode a
+pprAbsC stmt@(CClosureTbl tycon) _
+  = vcat (
+       ptext SLIT("CLOSURE_TBL") <> 
+          lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
+       punctuate comma (
+          map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
+       )
+   ) $$ ptext SLIT("};")

 
 

-pprAbsC stmt@(CRetUnVector label amode) _
-  = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
-           pprAmode amode, rparen]
+pprAbsC stmt@(CRetDirect uniq code srt liveness) _
+  = vcat [
+      hcat [
+         ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen, 
+         pprCLabel info_lbl,           comma,
+         pprCLabel entry_lbl,          comma,
+          pp_liveness liveness,                comma,    -- bitmap
+         pp_srt_info srt,                        -- SRT
+         ptext type_str,               comma,    -- closure type
+         ppLocalness info_lbl,         comma,    -- info table storage class
+         ppLocalnessMacro True{-include dyn-} entry_lbl,       comma,    -- entry pt storage class
+         int 0, comma,
+         int 0, text ");"
+      ],
+      pp_code
+    ]

   where
   where

-    pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
-
-pprAbsC stmt@(CFlatRetVector label amodes) _
-  =    case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
-       vcat [
-           pp_exts,
-           hcat [ppLocalness label, ptext SLIT(" W_ "),
-                      pprCLabel label, text "[] = {"],
-           nest 2 (sep (punctuate comma (map ppr_item amodes))),
-           text "};" ] }
+     info_lbl  = mkReturnInfoLabel uniq
+     entry_lbl = mkReturnPtLabel uniq
+
+     pp_code   = let stuff = CCodeBlock entry_lbl code in
+                pprAbsC stuff (costs stuff)
+
+     type_str = case liveness of
+                  LvSmall _ -> SLIT("RET_SMALL")
+                  LvLarge _ -> SLIT("RET_BIG")
+
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
+  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+    vcat [
+       pp_exts,
+       hcat [
+         ptext SLIT("VEC_INFO_") <> int size,
+         lparen, 
+         pprCLabel lbl, comma,
+         pp_liveness liveness, comma,  -- bitmap liveness mask
+         pp_srt_info srt,              -- SRT
+         ptext type_str, comma,
+         ppLocalness lbl, comma
+       ],
+       nest 2 (sep (punctuate comma (map ppr_item amodes))),
+       text ");"
+    ]
+    }
+

   where
   where

-    ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
+    ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
+    size = length amodes
+
+    type_str = case liveness of
+                  LvSmall _ -> SLIT("RET_VEC_SMALL")
+                  LvLarge _ -> SLIT("RET_VEC_BIG")

 
 

-pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
+
+pprAbsC stmt@(CModuleInitBlock lbl code) _
+  = vcat [
+       ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
+       case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
+       pprAbsC code (costs code),
+       hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
+    ]
+
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-ppLocalness label
-  = (<>) static const
+ppLocalness lbl
+  = if (externallyVisibleCLabel lbl) 
+               then empty 
+               else ptext SLIT("static ")
+
+-- Horrible macros for declaring the types and locality of labels (see
+-- StgMacros.h).
+
+ppLocalnessMacro include_dyn_prefix clabel =
+     hcat [
+        visiblity_prefix,
+       dyn_prefix,
+        case label_type of
+         ClosureType    -> ptext SLIT("C_")
+         CodeType       -> ptext SLIT("F_")
+         InfoTblType    -> ptext SLIT("I_")
+         ClosureTblType -> ptext SLIT("CP_")
+         DataType       -> ptext SLIT("D_")
+     ]

   where
   where

-    static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
-    const  = if not (isReadOnly label)         then empty else ptext SLIT("const")
-
-ppLocalnessMacro for_fun{-vs data-} clabel
-  = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
-                 if for_fun then 
-                    ptext SLIT("F_") 
-                 else 
-                    (<>) (ptext SLIT("D_"))
-                              (if isReadOnly clabel then 
-                                 ptext SLIT("RO_") 
-                              else 
-                                 empty)]
+   is_visible = externallyVisibleCLabel clabel
+   label_type = labelType clabel
+
+   visiblity_prefix
+     | is_visible = char 'E'
+     | otherwise  = char 'I'
+
+   dyn_prefix
+     | include_dyn_prefix && labelDynamic clabel = char 'D'
+     | otherwise                                = empty
+

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -498,36 +636,36 @@ ppr_vol_regs (r:rs)
     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
 
     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
 

--- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
+-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and

 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
 -- depending on the platform.  (The "volatile regs" stuff handles all
 -- other registers.)  Just be *sure* BaseReg is OK before trying to do
 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
 -- depending on the platform.  (The "volatile regs" stuff handles all
 -- other registers.)  Just be *sure* BaseReg is OK before trying to do

--- anything else.
-pp_basic_saves
-  = vcat [
-       ptext SLIT("CALLER_SAVE_Base"),
-       ptext SLIT("CALLER_SAVE_SpA"),
-       ptext SLIT("CALLER_SAVE_SuA"),
-       ptext SLIT("CALLER_SAVE_SpB"),
-       ptext SLIT("CALLER_SAVE_SuB"),
-       ptext SLIT("CALLER_SAVE_Ret"),
---     ptext SLIT("CALLER_SAVE_Activity"),
-       ptext SLIT("CALLER_SAVE_Hp"),
-       ptext SLIT("CALLER_SAVE_HpLim") ]
-
-pp_basic_restores
-  = vcat [
-       ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
-       ptext SLIT("CALLER_RESTORE_SpA"),
-       ptext SLIT("CALLER_RESTORE_SuA"),
-       ptext SLIT("CALLER_RESTORE_SpB"),
-       ptext SLIT("CALLER_RESTORE_SuB"),
-       ptext SLIT("CALLER_RESTORE_Ret"),
---     ptext SLIT("CALLER_RESTORE_Activity"),
-       ptext SLIT("CALLER_RESTORE_Hp"),
-       ptext SLIT("CALLER_RESTORE_HpLim"),
-       ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
-       ptext SLIT("CALLER_RESTORE_StkStub") ]
+-- anything else. The correct sequence of saves&restores are
+-- encoded by the CALLER_*_SYSTEM macros.
+pp_basic_saves    = ptext SLIT("CALLER_SAVE_SYSTEM")
+pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
+\end{code}
+
+\begin{code}
+has_srt (_, NoSRT) = False
+has_srt _ = True
+
+pp_srt_info srt = 
+    case srt of
+       (lbl, NoSRT) -> 
+               hcat [  int 0, comma, 
+                       int 0, comma, 
+                       int 0, comma ]
+       (lbl, SRT off len) -> 
+               hcat [  pprCLabel lbl, comma,
+                       int off, comma,
+                       int len, comma ]
+\end{code}
+
+\begin{code}
+pp_closure_lbl lbl
+      | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
+      | otherwise       = char '&' <> pprCLabel lbl

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -546,13 +684,26 @@ do_if_stmt discrim tag alt_code deflt c
   = case tag of
       -- This special case happens when testing the result of a comparison.
       -- We can just avoid some redundant clutter in the output.
   = case tag of
       -- This special case happens when testing the result of a comparison.
       -- We can just avoid some redundant clutter in the output.

-      MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
+      MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)

                                      deflt alt_code
                                      (addrModeCosts discrim Rhs) c
                                      deflt alt_code
                                      (addrModeCosts discrim Rhs) c

-      other              -> let
-                              cond = hcat [ pprAmode discrim,
-                                         ptext SLIT(" == "),
-                                         pprAmode (CLit tag) ]
+      other            -> let
+                              cond = hcat [ pprAmode discrim
+                                          , ptext SLIT(" == ")
+                                          , tcast
+                                          , pprAmode (CLit tag)
+                                          ]
+                               -- to be absolutely sure that none of the 
+                               -- conversion rules hit, e.g.,
+                               --
+                               --     minInt is different to (int)minInt
+                               --
+                               -- in C (when minInt is a number not a constant
+                               --  expression which evaluates to it.)
+                               -- 
+                              tcast = case other of
+                                          MachInt _  -> ptext SLIT("(I_)")
+                                          _          -> empty

                            in
                            ppr_if_stmt cond
                                         alt_code deflt
                            in
                            ppr_if_stmt cond
                                         alt_code deflt

@@ -597,11 +748,6 @@ Some rough notes on generating code for @CCallOp@:
    (This happens after restoration of essential registers because we
    might need the @Base@ register to access all the others correctly.)
 
    (This happens after restoration of essential registers because we
    might need the @Base@ register to access all the others correctly.)
 

-{- Doesn't apply anymore with ForeignObj, structure created via the primop.
-   makeForeignObj (i.e., ForeignObj is not CReturnable)
-7) If returning Malloc Pointer, build a closure containing the
-   appropriate value.
--}

    Otherwise, copy local variable into result register.
 
 8) If ccall (not casm), declare the function being called as extern so
    Otherwise, copy local variable into result register.
 
 8) If ccall (not casm), declare the function being called as extern so

@@ -625,22 +771,17 @@ Amendment to the above: if we can GC, we have to:
   can get at them.
 * be sure that there are no live registers or we're in trouble.
   (This can cause problems if you try something foolish like passing
   can get at them.
 * be sure that there are no live registers or we're in trouble.
   (This can cause problems if you try something foolish like passing

-   an array or foreign obj to a _ccall_GC_ thing.)
+   an array or a foreign obj to a _ccall_GC_ thing.)

 * increment/decrement the @inCCallGC@ counter before/after the call so
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}
 * increment/decrement the @inCCallGC@ counter before/after the call so
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}

-pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask vol_regs
-  = if (may_gc && liveness_mask /= noLiveRegsMask)
-    then pprPanic "Live register in _casm_GC_ " 
-                 (doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
-    else
-    vcat [
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
+  = vcat [

       char '{',
       declare_local_vars,   -- local var for *result*
       vcat local_arg_decls,
       pp_save_context,
       char '{',
       declare_local_vars,   -- local var for *result*
       vcat local_arg_decls,
       pp_save_context,

-        declare_fun_extern,   -- declare expected function type.

         process_casm local_vars pp_non_void_args casm_str,
       pp_restore_context,
       assign_results,
         process_casm local_vars pp_non_void_args casm_str,
       pp_restore_context,
       assign_results,

@@ -648,21 +789,18 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
     ]
   where
     (pp_saves, pp_restores) = ppr_vol_regs vol_regs
     ]
   where
     (pp_saves, pp_restores) = ppr_vol_regs vol_regs

-

     (pp_save_context, pp_restore_context)
     (pp_save_context, pp_restore_context)

-       | may_gc =
-            ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;"
-            , text "inCCallGC--; RestoreAllStgRegs();} while(0);"
-            )
-        | otherwise = 
-            ( pp_basic_saves $$ pp_saves
-            , pp_basic_restores $$ pp_restores
-            )
-
-    non_void_args =
-       let nvas = tail args
-       in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidRep)
+       | may_gc  = ( text "{ I_ id; SUSPEND_THREAD(id);"
+                   , text "RESUME_THREAD(id);}"
+                   )
+       | otherwise = ( pp_basic_saves $$ pp_saves,
+                       pp_basic_restores $$ pp_restores)
+
+    non_void_args = 
+       let nvas = init args
+       in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+       nvas
+    -- the last argument will be the "I/O world" token (a VoidRep)

     -- all others should be non-void
 
     non_void_results =
     -- all others should be non-void
 
     non_void_results =

@@ -674,89 +812,17 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
     (local_arg_decls, pp_non_void_args)
       = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
 
     (local_arg_decls, pp_non_void_args)
       = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
 

-    pp_liveness = pprAmode (mkIntCLit liveness_mask)
-
-    {-
-      In the non-casm case, to ensure that we're entering the given external
-      entry point using the correct calling convention, we have to do the following:
-
-       - When entering via a function pointer (the `dynamic' case) using the specified
-         calling convention, we emit a typedefn declaration attributed with the
-         calling convention to use together with the result and parameter types we're
-         assuming. Coerce the function pointer to this type and go.
-
-        - to enter the function at a given code label, we emit an extern declaration
-         for the label here, stating the calling convention together with result and
-          argument types we're assuming. 
-
-          The C compiler will hopefully use this extern declaration to good effect,
-          reporting any discrepancies between our extern decl and any other that
-         may be in scope.
-    
-         Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
-         the external function `foo' use the calling convention of the first `foo'
-         prototype it encounters (nor does it complain about conflicting attribute
-         declarations). The consequence of this is that you cannot override the
-         calling convention of `foo' using an extern declaration (you'd have to use
-         a typedef), but why you would want to do such a thing in the first place
-         is totally beyond me.
-         
-         ToDo: petition the gcc folks to add code to warn about conflicting attribute
-         declarations.
-
-    -}
-    declare_fun_extern
-      | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
-      | otherwise                          =
-         hsep [ typedef_or_extern
-             , ccall_res_ty
-             , fun_nm
-             , parens (hsep (punctuate comma ccall_decl_ty_args))
-             ] <> semi
-       where
-       typedef_or_extern
-         | is_dynamic     = ptext SLIT("typedef")
-         | otherwise      = ptext SLIT("extern")
-
-        fun_nm 
-         | is_dynamic     = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
-         | otherwise      = text (callConvAttribute cconv) <+> ptext asm_str
-
-         -- leave out function pointer
-       ccall_decl_ty_args
-         | is_dynamic     = tail ccall_arg_tys
-         | otherwise      = ccall_arg_tys
-
-    ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
-
-    ccall_res_ty = 
-       case non_void_results of
-          []       -> ptext SLIT("void")
-         [amode]  -> text (showPrimRep (getAmodeRep amode))
-         _        -> panic "pprCCall: ccall_res_ty"
-
-    ccall_fun_ty = 
-       ptext SLIT("_ccall_fun_ty") <>
-       case op_str of
-         Right u -> ppr u
-        _       -> empty
-

     (declare_local_vars, local_vars, assign_results)
     (declare_local_vars, local_vars, assign_results)

-      = ppr_casm_results non_void_results pp_liveness
-
-    (Left asm_str) = op_str
-    is_dynamic = 
-       case op_str of
-         Left _ -> False
-        _      -> True
+      = ppr_casm_results non_void_results

 
     casm_str = if is_asm then _UNPK_ asm_str else ccall_str
 
     casm_str = if is_asm then _UNPK_ asm_str else ccall_str

+    StaticTarget asm_str = op_str      -- Must be static if it's a casm

 
     -- Remainder only used for ccall
 
 
     -- Remainder only used for ccall
 

-    fun_name 
-      | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
-      | otherwise  = ptext asm_str
+    fun_name = case op_str of
+                DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+                StaticTarget st -> pprCLabelString st

 
     ccall_str = showSDoc
        (hcat [
 
     ccall_str = showSDoc
        (hcat [

@@ -768,9 +834,8 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
                text "));"
        ])
 
                text "));"
        ])
 

-    ccall_fun_args
-     | is_dynamic = tail ccall_args
-     | otherwise  = ccall_args
+    ccall_fun_args | isDynamicTarget op_str = tail ccall_args
+                  | otherwise              = ccall_args

 
     ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
 
 
     ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
 

@@ -778,7 +843,7 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
 
 If the argument is a heap object, we need to reach inside and pull out
 the bit the C world wants to see.  The only heap objects which can be
 
 If the argument is a heap object, we need to reach inside and pull out
 the bit the C world wants to see.  The only heap objects which can be

-passed are @Array@s, @ByteArray@s and @ForeignObj@s.
+passed are @Array@s and @ByteArray@s.

 
 \begin{code}
 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
 
 \begin{code}
 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)

@@ -803,9 +868,10 @@ ppr_casm_arg amode a_num
                                hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 
              -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
                                hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 
              -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.

-             ForeignObjRep -> (ptext SLIT("StgForeignObj"),
-                               hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(', 
-                                           pp_amode, char ')'])
+             ForeignObjRep -> (pp_kind,
+                               hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
+                                     char '(', pp_amode, char ')'])
+

              other         -> (pp_kind, pp_amode)
 
        declare_local_var
              other         -> (pp_kind, pp_amode)
 
        declare_local_var

@@ -820,24 +886,18 @@ For l-values, the critical questions are:
 
    We only allow zero or one results.
 
 
    We only allow zero or one results.
 

-{- With the introduction of ForeignObj (MallocPtr++), no longer necess.
-2) Is the result is a foreign obj?
-
-   The mallocptr must be encapsulated immediately in a heap object.
--}

 \begin{code}
 ppr_casm_results
        :: [CAddrMode]  -- list of results (length <= 1)
 \begin{code}
 ppr_casm_results
        :: [CAddrMode]  -- list of results (length <= 1)

-       -> SDoc         -- liveness mask

        ->
        ( SDoc,         -- declaration of any local vars
          [SDoc],       -- list of result vars (same length as results)
          SDoc )        -- assignment (if any) of results in local var to registers
 
        ->
        ( SDoc,         -- declaration of any local vars
          [SDoc],       -- list of result vars (same length as results)
          SDoc )        -- assignment (if any) of results in local var to registers
 

-ppr_casm_results [] liveness
+ppr_casm_results []

   = (empty, [], empty)         -- no results
 
   = (empty, [], empty)         -- no results
 

-ppr_casm_results [r] liveness
+ppr_casm_results [r]

   = let
        result_reg = ppr_amode r
        r_kind     = getAmodeRep r
   = let
        result_reg = ppr_amode r
        r_kind     = getAmodeRep r

@@ -845,32 +905,14 @@ ppr_casm_results [r] liveness
        local_var  = ptext SLIT("_ccall_result")
 
        (result_type, assign_result)
        local_var  = ptext SLIT("_ccall_result")
 
        (result_type, assign_result)

-         = case r_kind of
-{- 
-   @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
-   Instead, external references have to explicitly turned into ForeignObjs
-   using the primop makeForeignObj#. Benefit: Multiple finalisation
-   routines can be accommodated and the below special case is not needed.
-   Price is, of course, that you have to explicitly wrap `foreign objects'
-   with makeForeignObj#.
-
-             ForeignObjRep ->
-               (ptext SLIT("StgForeignObj"),
-                hcat [ ptext SLIT("constructForeignObj"),char '(',
-                               liveness, comma,
-                               result_reg, comma,
-                               local_var,
-                            pp_paren_semi ]) 
--}
-             _ ->
-               (pprPrimKind r_kind,
-                hcat [ result_reg, equals, local_var, semi ])
+         = (pprPrimKind r_kind,
+            hcat [ result_reg, equals, local_var, semi ])

 
        declare_local_var = hcat [ result_type, space, local_var, semi ]
     in
     (declare_local_var, [local_var], assign_result)
 
 
        declare_local_var = hcat [ result_type, space, local_var, semi ]
     in
     (declare_local_var, [local_var], assign_result)
 

-ppr_casm_results rs liveness
+ppr_casm_results rs

   = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 
   = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 

@@ -890,7 +932,9 @@ process_casm :: [SDoc]              -- results (length <= 1)
 process_casm results args string = process results args string
  where
   process []    _ "" = empty
 process_casm results args string = process results args string
  where
   process []    _ "" = empty

-  process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
+  process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ 
+                             string ++ 
+                             "\"\n(Try changing result type to IO ()\n")

 
   process ress args ('%':cs)
     = case cs of
 
   process ress args ('%':cs)
     = case cs of

@@ -898,12 +942,12 @@ process_casm results args string = process results args string
            error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 
        ('%':css) ->
            error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 
        ('%':css) ->

-           (<>) (char '%') (process ress args css)
+           char '%' <> process ress args css

 
        ('r':css)  ->
          case ress of
            []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
 
        ('r':css)  ->
          case ress of
            []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")

-           [r] -> (<>) r (process [] args css)
+           [r] -> r <> (process [] args css)

            _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 
        other ->
            _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 
        other ->

@@ -914,13 +958,12 @@ process_casm results args string = process results args string
          case (read_int other) of
            [(num,css)] ->
                  if 0 <= num && num < length args
          case (read_int other) of
            [(num,css)] ->
                  if 0 <= num && num < length args

-                 then (<>) (parens (args !! num))
-                                (process ress args css)
-                   else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
+                 then parens (args !! num) <> process ress args css
+                 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")

            _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 
   process ress args (other_c:cs)
            _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 
   process ress args (other_c:cs)

-    = (<>) (char other_c) (process ress args cs)
+    = char other_c <> process ress args cs

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -960,13 +1003,13 @@ pprAssign Word64Rep dest@(CVal reg_rel _) src
 Lastly, the question is: will the C compiler think the types of the
 two sides of the assignment match?
 
 Lastly, the question is: will the C compiler think the types of the
 two sides of the assignment match?
 

-       We assume that the types will match
-       if neither side is a @CVal@ addressing mode for any register
-       which can point into the heap or B stack.
+       We assume that the types will match if neither side is a
+       @CVal@ addressing mode for any register which can point into
+       the heap or stack.

 
 

-Why?  Because the heap and B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things
-of fixed type.
+Why?  Because the heap and stack are used to store miscellaneous
+things, whereas the temporaries, registers, etc., are only used for
+things of fixed type.

 
 \begin{code}
 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
 
 \begin{code}
 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))

@@ -989,9 +1032,9 @@ pprAssign kind dest src
 
 pprAssign ByteArrayRep dest src
   | mixedPtrLocn src
 
 pprAssign ByteArrayRep dest src
   | mixedPtrLocn src

-    -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
+    -- Add in a cast iff the source is mixed

   = hcat [ ppr_amode dest, equals,
   = hcat [ ppr_amode dest, equals,

-               text "(B_)(",   -- Here is the cast
+               text "(StgByteArray)(", -- Here is the cast

                ppr_amode src, pp_paren_semi ]
 
 pprAssign kind other_dest src
                ppr_amode src, pp_paren_semi ]
 
 pprAssign kind other_dest src

@@ -1044,6 +1087,29 @@ pprAmode amode
   = ppr_amode amode
 \end{code}
 
   = ppr_amode amode
 \end{code}
 

+When we have an indirection through a CIndex, we have to be careful to
+get the type casts right.  
+
+this amode:
+
+       CVal (CIndex kind1 base offset) kind2
+
+means (in C speak): 
+       
+       *(kind2 *)((kind1 *)base + offset)
+
+That is, the indexing is done in units of kind1, but the resulting
+amode has kind2.
+
+\begin{code}
+ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
+  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
+       (pp_reg, Nothing)     -> panic "ppr_amode: CIndex"
+       (pp_reg, Just offset) -> 
+          hcat [ char '*', parens (pprPrimKind kind <> char '*'),
+                 parens (pp_reg <> char '+' <> offset) ]
+\end{code}
+

 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 
 \begin{code}
 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 
 \begin{code}

@@ -1059,49 +1125,82 @@ ppr_amode (CAddr reg_rel)
 
 ppr_amode (CReg magic_id) = pprMagicId magic_id
 
 
 ppr_amode (CReg magic_id) = pprMagicId magic_id
 

-ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_'
-
-ppr_amode (CLbl label kind) = pprCLabel label
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'

 
 

-ppr_amode (CUnVecLbl direct vectored)
-  = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma,
-              pprCLabel vectored, rparen]
+ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl 

 
 ppr_amode (CCharLike ch)
   = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
 ppr_amode (CIntLike int)
   = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
 
 
 ppr_amode (CCharLike ch)
   = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
 ppr_amode (CIntLike int)
   = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
 

-ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
-  -- ToDo: are these *used* for anything?
-

 ppr_amode (CLit lit) = pprBasicLit lit
 
 ppr_amode (CLit lit) = pprBasicLit lit
 

-ppr_amode (CLitLit str _) = ptext str
-
-ppr_amode (COffset off) = pprHeapOffset off
-
-ppr_amode (CCode abs_C)
-  = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CLabelledCode label abs_C)
-  = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")],
-              nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CJoinPoint _ _)
+ppr_amode (CJoinPoint _)

   = panic "ppr_amode: CJoinPoint"
 
   = panic "ppr_amode: CJoinPoint"
 

-ppr_amode (CTableEntry base index kind)
-  = hcat [text "((", pprPrimKind kind, text " *)(",
-              ppr_amode base, text "))[(I_)(", ppr_amode index,
-              ptext SLIT(")]")]
-

 ppr_amode (CMacroExpr pk macro as)
 ppr_amode (CMacroExpr pk macro as)

-  = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen,
-              hcat (punctuate comma (map pprAmode as)), text "))"]
+  = parens (ptext (cExprMacroText macro) <> 
+           parens (hcat (punctuate comma (map pprAmode as))))
+\end{code}

 
 

-ppr_amode (CCostCentre cc print_as_string)
-  = uppCostCentre print_as_string cc
+\begin{code}
+cExprMacroText ENTRY_CODE              = SLIT("ENTRY_CODE")
+cExprMacroText ARG_TAG                 = SLIT("ARG_TAG")
+cExprMacroText GET_TAG                 = SLIT("GET_TAG")
+cExprMacroText UPD_FRAME_UPDATEE       = SLIT("UPD_FRAME_UPDATEE")
+cExprMacroText CCS_HDR                 = SLIT("CCS_HDR")
+
+cStmtMacroText ARGS_CHK                        = SLIT("ARGS_CHK")
+cStmtMacroText ARGS_CHK_LOAD_NODE      = SLIT("ARGS_CHK_LOAD_NODE")
+cStmtMacroText UPD_CAF                 = SLIT("UPD_CAF")
+cStmtMacroText UPD_BH_UPDATABLE                = SLIT("UPD_BH_UPDATABLE")
+cStmtMacroText UPD_BH_SINGLE_ENTRY     = SLIT("UPD_BH_SINGLE_ENTRY")
+cStmtMacroText PUSH_UPD_FRAME          = SLIT("PUSH_UPD_FRAME")
+cStmtMacroText PUSH_SEQ_FRAME          = SLIT("PUSH_SEQ_FRAME")
+cStmtMacroText UPDATE_SU_FROM_UPD_FRAME        = SLIT("UPDATE_SU_FROM_UPD_FRAME")
+cStmtMacroText SET_TAG                 = SLIT("SET_TAG")
+cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT         = SLIT("REGISTER_IMPORT")
+cStmtMacroText GRAN_FETCH              = SLIT("GRAN_FETCH")
+cStmtMacroText GRAN_RESCHEDULE         = SLIT("GRAN_RESCHEDULE")
+cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
+cStmtMacroText THREAD_CONTEXT_SWITCH           = SLIT("THREAD_CONTEXT_SWITCH")
+cStmtMacroText GRAN_YIELD              = SLIT("GRAN_YIELD")
+
+cCheckMacroText        HP_CHK_NP               = SLIT("HP_CHK_NP")
+cCheckMacroText        STK_CHK_NP              = SLIT("STK_CHK_NP")
+cCheckMacroText        HP_STK_CHK_NP           = SLIT("HP_STK_CHK_NP")
+cCheckMacroText        HP_CHK_SEQ_NP           = SLIT("HP_CHK_SEQ_NP")
+cCheckMacroText        HP_CHK                  = SLIT("HP_CHK")
+cCheckMacroText        STK_CHK                 = SLIT("STK_CHK")
+cCheckMacroText        HP_STK_CHK              = SLIT("HP_STK_CHK")
+cCheckMacroText        HP_CHK_NOREGS           = SLIT("HP_CHK_NOREGS")
+cCheckMacroText        HP_CHK_UNPT_R1          = SLIT("HP_CHK_UNPT_R1")
+cCheckMacroText        HP_CHK_UNBX_R1          = SLIT("HP_CHK_UNBX_R1")
+cCheckMacroText        HP_CHK_F1               = SLIT("HP_CHK_F1")
+cCheckMacroText        HP_CHK_D1               = SLIT("HP_CHK_D1")
+cCheckMacroText        HP_CHK_L1               = SLIT("HP_CHK_L1")
+cCheckMacroText        HP_CHK_UT_ALT           = SLIT("HP_CHK_UT_ALT")
+cCheckMacroText        HP_CHK_GEN              = SLIT("HP_CHK_GEN")
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+pp_liveness :: Liveness -> SDoc
+pp_liveness lv = 
+   case lv of
+       LvLarge lbl  -> char '&' <> pprCLabel lbl
+       LvSmall mask    -- Avoid gcc bug when printing minInt
+          | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1"
+          | otherwise            -> int bitmap_int
+         where
+          bitmap_int = intBS mask

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1129,31 +1228,30 @@ pprRegRelative :: Bool          -- True <=> Print leading plus sign (if +ve)
               -> RegRelative
               -> (SDoc, Maybe SDoc)
 
               -> RegRelative
               -> (SDoc, Maybe SDoc)
 

-pprRegRelative sign_wanted (SpARel spA off)
-  = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off))
-
-pprRegRelative sign_wanted (SpBRel spB off)
-  = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
+pprRegRelative sign_wanted (SpRel off)
+  = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))

 
 

-pprRegRelative sign_wanted r@(HpRel hp off)
-  = let to_print = hp `subOff` off
-       pp_Hp    = pprMagicId Hp
+pprRegRelative sign_wanted r@(HpRel o)
+  = let pp_Hp   = pprMagicId Hp; off = I# o

     in
     in

-    if isZeroOff to_print then
+    if off == 0 then

        (pp_Hp, Nothing)
     else
        (pp_Hp, Nothing)
     else

-       (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print)))
-                               -- No parens needed because pprHeapOffset
-                               -- does them when necessary
+       (pp_Hp, Just ((<>) (char '-') (int off)))

 
 

-pprRegRelative sign_wanted (NodeRel off)
-  = let pp_Node = pprMagicId node
+pprRegRelative sign_wanted (NodeRel o)
+  = let pp_Node = pprMagicId node; off = I# o

     in
     in

-    if isZeroOff off then
+    if off == 0 then

        (pp_Node, Nothing)
     else
        (pp_Node, Nothing)
     else

-       (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off)))
+       (pp_Node, Just (addPlusSign sign_wanted (int off)))

 
 

+pprRegRelative sign_wanted (CIndex base offset kind)
+  = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
+    , Just (hcat [if sign_wanted then char '+' else empty,
+           text "(I_)(", ppr_amode offset, ptext SLIT(")")])
+    )

 \end{code}
 
 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are
 \end{code}
 
 @pprMagicId@ just prints the register name.  @VanillaReg@ registers are

@@ -1164,29 +1262,21 @@ to select the union tag.
 pprMagicId :: MagicId -> SDoc
 
 pprMagicId BaseReg                 = ptext SLIT("BaseReg")
 pprMagicId :: MagicId -> SDoc
 
 pprMagicId BaseReg                 = ptext SLIT("BaseReg")

-pprMagicId StkOReg                 = ptext SLIT("StkOReg")

 pprMagicId (VanillaReg pk n)
                                    = hcat [ pprVanillaReg n, char '.',
                                                  pprUnionTag pk ]
 pprMagicId (VanillaReg pk n)
                                    = hcat [ pprVanillaReg n, char '.',
                                                  pprUnionTag pk ]

-pprMagicId (FloatReg  n)        = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
-pprMagicId (DoubleReg n)           = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
-pprMagicId (LongReg _ n)           = (<>) (ptext SLIT("LngReg")) (int IBOX(n))
-pprMagicId TagReg                  = ptext SLIT("TagReg")
-pprMagicId RetReg                  = ptext SLIT("RetReg")
-pprMagicId SpA             = ptext SLIT("SpA")
-pprMagicId SuA             = ptext SLIT("SuA")
-pprMagicId SpB             = ptext SLIT("SpB")
-pprMagicId SuB             = ptext SLIT("SuB")
-pprMagicId Hp              = ptext SLIT("Hp")
+pprMagicId (FloatReg  n)            = (<>) (ptext SLIT("F")) (int IBOX(n))
+pprMagicId (DoubleReg n)           = (<>) (ptext SLIT("D")) (int IBOX(n))
+pprMagicId (LongReg _ n)           = (<>) (ptext SLIT("L")) (int IBOX(n))
+pprMagicId Sp                      = ptext SLIT("Sp")
+pprMagicId Su                      = ptext SLIT("Su")
+pprMagicId SpLim                   = ptext SLIT("SpLim")
+pprMagicId Hp                      = ptext SLIT("Hp")

 pprMagicId HpLim                   = ptext SLIT("HpLim")
 pprMagicId HpLim                   = ptext SLIT("HpLim")

-pprMagicId LivenessReg     = ptext SLIT("LivenessReg")
-pprMagicId StdUpdRetVecReg      = ptext SLIT("StdUpdRetVecReg")
-pprMagicId StkStubReg      = ptext SLIT("StkStubReg")
-pprMagicId CurCostCentre           = ptext SLIT("CCC")
+pprMagicId CurCostCentre           = ptext SLIT("CCCS")

 pprMagicId VoidReg                 = panic "pprMagicId:VoidReg!"
 
 pprVanillaReg :: FAST_INT -> SDoc
 pprMagicId VoidReg                 = panic "pprMagicId:VoidReg!"
 
 pprVanillaReg :: FAST_INT -> SDoc

-

 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
 
 pprUnionTag :: PrimRep -> SDoc
 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
 
 pprUnionTag :: PrimRep -> SDoc

@@ -1194,19 +1284,23 @@ pprUnionTag :: PrimRep -> SDoc
 pprUnionTag PtrRep             = char 'p'
 pprUnionTag CodePtrRep         = ptext SLIT("fp")
 pprUnionTag DataPtrRep         = char 'd'
 pprUnionTag PtrRep             = char 'p'
 pprUnionTag CodePtrRep         = ptext SLIT("fp")
 pprUnionTag DataPtrRep         = char 'd'

-pprUnionTag RetRep             = char 'r'
+pprUnionTag RetRep             = char 'p'

 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'

-pprUnionTag AddrRep            = char 'v'
+pprUnionTag AddrRep            = char 'a'

 pprUnionTag FloatRep           = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag FloatRep           = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 

-pprUnionTag StablePtrRep       = char 'i'
+pprUnionTag StablePtrRep       = char 'p'
+pprUnionTag StableNameRep      = char 'p'
+pprUnionTag WeakPtrRep         = char 'p'

 pprUnionTag ForeignObjRep      = char 'p'
 
 pprUnionTag ForeignObjRep      = char 'p'
 

+pprUnionTag ThreadIdRep                = char 't'
+

 pprUnionTag ArrayRep           = char 'p'
 pprUnionTag ByteArrayRep       = char 'b'
 
 pprUnionTag ArrayRep           = char 'p'
 pprUnionTag ByteArrayRep       = char 'b'
 

@@ -1309,33 +1403,30 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels)
          False)
 
 labelSeenTE :: CLabel -> TeM Bool
          False)
 
 labelSeenTE :: CLabel -> TeM Bool

-labelSeenTE label env@(seen_uniqs, seen_labels)
-  = if (label `elementOfCLabelSet` seen_labels)
+labelSeenTE lbl env@(seen_uniqs, seen_labels)
+  = if (lbl `elementOfCLabelSet` seen_labels)

     then (env, True)
     else ((seen_uniqs,
     then (env, True)
     else ((seen_uniqs,

-         addToCLabelSet seen_labels label),
+         addToCLabelSet seen_labels lbl),

          False)
 \end{code}
 
 \begin{code}
 pprTempDecl :: Unique -> PrimRep -> SDoc
 pprTempDecl uniq kind
          False)
 \end{code}
 
 \begin{code}
 pprTempDecl :: Unique -> PrimRep -> SDoc
 pprTempDecl uniq kind

-  = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
-
-pprExternDecl :: CLabel -> PrimRep -> SDoc
-
-pprExternDecl clabel kind
-  = if not (needsCDecl clabel) then
-       empty -- do not print anything for "known external" things (e.g., < PreludeCore)
-    else
-       case (
-           case kind of
-             CodePtrRep -> ppLocalnessMacro True{-function-} clabel
-             _          -> ppLocalnessMacro False{-data-}    clabel
-       ) of { pp_macro_str ->
+  = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
+
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl in_srt clabel
+  | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
+  | otherwise              = 
+       hcat [ ppLocalnessMacro (not in_srt) clabel, 
+              lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
+ where
+  dyn_wrapper d
+    | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
+    | otherwise                            = d

 
 

-       hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
-       }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -1348,9 +1439,6 @@ ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
     returnTE (maybe_vcat [p1, p2])
 
     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
     returnTE (maybe_vcat [p1, p2])
 

-ppr_decls_AbsC (CClosureUpdInfo info)
-  = ppr_decls_AbsC info
-

 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (CAssign dest source)
 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (CAssign dest source)

@@ -1372,23 +1460,28 @@ ppr_decls_AbsC (CSwitch discrim alts deflt)
   where
     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
 
   where
     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
 

-ppr_decls_AbsC (CCodeBlock label absC)
+ppr_decls_AbsC (CCodeBlock lbl absC)

   = ppr_decls_AbsC absC
 
   = ppr_decls_AbsC absC
 

-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
+ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)

        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
     returnTE (Nothing,
              if label_seen then
                  Nothing
              else
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
     returnTE (Nothing,
              if label_seen then
                  Nothing
              else

-                 Just (pprExternDecl info_lbl PtrRep))
+                 Just (pprExternDecl False{-not in an SRT decl-} info_lbl))

   where
     info_lbl = infoTableLabelFromCI cl_info
 
   where
     info_lbl = infoTableLabelFromCI cl_info
 

-ppr_decls_AbsC (COpStmt        results _ args _ _) = ppr_decls_Amodes (results ++ args)
+ppr_decls_AbsC (COpStmt        results _ args _) = ppr_decls_Amodes (results ++ args)

 ppr_decls_AbsC (CSimultaneous abc)         = ppr_decls_AbsC abc
 
 ppr_decls_AbsC (CSimultaneous abc)         = ppr_decls_AbsC abc
 

+ppr_decls_AbsC (CCheck             _ amodes code) = 
+     ppr_decls_Amodes amodes `thenTE` \p1 ->
+     ppr_decls_AbsC code     `thenTE` \p2 ->
+     returnTE (maybe_vcat [p1,p2])
+

 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)  = ppr_decls_Amodes [] -- *****!!!
 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)  = ppr_decls_Amodes [] -- *****!!!

@@ -1401,8 +1494,8 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 

-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
-  = ppr_decls_Amodes [entry_lbl, upd_lbl]      `thenTE` \ p1 ->
+ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
+  = ppr_decls_Amodes [entry_lbl]               `thenTE` \ p1 ->

     ppr_decls_AbsC slow                                `thenTE` \ p2 ->
     (case maybe_fast of
        Nothing   -> returnTE (Nothing, Nothing)
     ppr_decls_AbsC slow                                `thenTE` \ p2 ->
     (case maybe_fast of
        Nothing   -> returnTE (Nothing, Nothing)

@@ -1414,24 +1507,28 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
                    Nothing -> mkErrorStdEntryLabel
                    Just _  -> entryLabelFromCI cl_info
 
                    Nothing -> mkErrorStdEntryLabel
                    Just _  -> entryLabelFromCI cl_info
 

-ppr_decls_AbsC (CRetVector label maybe_amodes absC)
-  = ppr_decls_Amodes (catMaybes maybe_amodes)  `thenTE` \ p1 ->
-    ppr_decls_AbsC   absC                      `thenTE` \ p2 ->
-    returnTE (maybe_vcat [p1, p2])
+ppr_decls_AbsC (CSRT lbl closure_lbls)
+  = mapTE labelSeenTE closure_lbls             `thenTE` \ seen ->
+    returnTE (Nothing, 
+             if and seen then Nothing
+               else Just (vcat [ pprExternDecl True{-in SRT decl-} l
+                               | (l,False) <- zip closure_lbls seen ]))

 
 

-ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
-ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
+ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CModuleInitBlock _ code)     = ppr_decls_AbsC code
+
+ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)

 \end{code}
 
 \begin{code}
 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
 \end{code}
 
 \begin{code}
 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)

+ppr_decls_Amode (CVal  (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
+ppr_decls_Amode (CAddr (CIndex base offset _))   = ppr_decls_Amodes [base,offset]

 ppr_decls_Amode (CVal _ _)     = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CAddr _)      = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CReg _)       = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CVal _ _)     = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CAddr _)      = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CReg _)       = returnTE (Nothing, Nothing)

-ppr_decls_Amode (CString _)    = returnTE (Nothing, Nothing)

 ppr_decls_Amode (CLit _)       = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CLit _)       = returnTE (Nothing, Nothing)

-ppr_decls_Amode (CLitLit _ _)  = returnTE (Nothing, Nothing)
-ppr_decls_Amode (COffset _)    = returnTE (Nothing, Nothing)

 
 -- CIntLike must be a literal -- no decls
 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
 
 -- CIntLike must be a literal -- no decls
 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)

@@ -1449,47 +1546,13 @@ ppr_decls_Amode (CTemp uniq kind)
        returnTE
          (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
 
        returnTE
          (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
 

-ppr_decls_Amode (CLbl label VoidRep)
+ppr_decls_Amode (CLbl lbl VoidRep)

   = returnTE (Nothing, Nothing)
 
   = returnTE (Nothing, Nothing)
 

-ppr_decls_Amode (CLbl label kind)
-  = labelSeenTE label `thenTE` \ label_seen ->
-    returnTE (Nothing,
-             if label_seen then Nothing else Just (pprExternDecl label kind))
-
-{- WRONG:
-ppr_decls_Amode (CUnVecLbl direct vectored)
-  = labelSeenTE direct   `thenTE` \ dlbl_seen ->
-    labelSeenTE vectored `thenTE` \ vlbl_seen ->
-    let
-       ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
-       vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
-    in
+ppr_decls_Amode (CLbl lbl kind)
+  = labelSeenTE lbl `thenTE` \ label_seen ->

     returnTE (Nothing,
     returnTE (Nothing,

-               if (dlbl_seen || not (needsCDecl direct)) &&
-                  (vlbl_seen || not (needsCDecl vectored)) then Nothing
-               else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
--}
-
-ppr_decls_Amode (CUnVecLbl direct vectored)
-  = -- We don't mark either label as "seen", because
-    -- we don't know which one will be used and which one tossed
-    -- by the C macro...
-    --labelSeenTE direct   `thenTE` \ dlbl_seen ->
-    --labelSeenTE vectored `thenTE` \ vlbl_seen ->
-    let
-       ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
-       vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
-    in
-    returnTE (Nothing,
-               if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
-                  ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
-               else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
-
-ppr_decls_Amode (CTableEntry base index _)
-  = ppr_decls_Amode base    `thenTE` \ p1 ->
-    ppr_decls_Amode index   `thenTE` \ p2 ->
-    returnTE (maybe_vcat [p1, p2])
+             if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))

 
 ppr_decls_Amode (CMacroExpr _ _ amodes)
   = ppr_decls_Amodes amodes
 
 ppr_decls_Amode (CMacroExpr _ _ amodes)
   = ppr_decls_Amodes amodes

@@ -1513,3 +1576,65 @@ ppr_decls_Amodes amodes
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
     returnTE ( maybe_vcat ps )
 \end{code}
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
     returnTE ( maybe_vcat ps )
 \end{code}

+
+Print out a C Label where you want the *address* of the label, not the
+object it refers to.  The distinction is important when the label may
+refer to a C structure (info tables and closures, for instance).
+
+When just generating a declaration for the label, use pprCLabel.
+
+\begin{code}
+pprCLabelAddr :: CLabel -> SDoc
+pprCLabelAddr clabel =
+  case labelType clabel of
+     InfoTblType -> addr_of_label
+     ClosureType -> addr_of_label
+     VecTblType  -> addr_of_label
+     _           -> pp_label
+  where
+    addr_of_label = ptext SLIT("(P_)&") <> pp_label
+    pp_label = pprCLabel clabel
+
+\end{code}
+
+-----------------------------------------------------------------------------
+Initialising static objects with floating-point numbers.  We can't
+just emit the floating point number, because C will cast it to an int
+by rounding it.  We want the actual bit-representation of the float.
+
+This is a hack to turn the floating point numbers into ints that we
+can safely initialise to static locations.
+
+\begin{code}
+big_doubles = (getPrimRepSize DoubleRep) /= 1
+
+-- floatss are always 1 word
+floatToWord :: CAddrMode -> CAddrMode
+floatToWord (CLit (MachFloat r))
+  = runST (do
+       arr <- newFloatArray ((0::Int),0)
+       writeFloatArray arr 0 (fromRational r)
+       i <- readIntArray arr 0
+       return (CLit (MachInt (toInteger i)))
+    )
+
+doubleToWords :: CAddrMode -> [CAddrMode]
+doubleToWords (CLit (MachDouble r))
+  | big_doubles                                -- doubles are 2 words
+  = runST (do
+       arr <- newDoubleArray ((0::Int),1)
+       writeDoubleArray arr 0 (fromRational r)
+       i1 <- readIntArray arr 0
+       i2 <- readIntArray arr 1
+       return [ CLit (MachInt (toInteger i1))
+              , CLit (MachInt (toInteger i2))
+              ]
+    )
+  | otherwise                          -- doubles are 1 word
+  = runST (do
+       arr <- newDoubleArray ((0::Int),0)
+       writeDoubleArray arr 0 (fromRational r)
+       i <- readIntArray arr 0
+       return [ CLit (MachInt (toInteger i)) ]
+    )
+\end{code}