projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2003-05-29 14:39:26 by sof]
[ghc-hetmet.git] / ghc / compiler / absCSyn / PprAbsC.lhs
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index fe78a3d..f0ae177 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,46 +10,65 @@
 \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"
 
 import IO      ( Handle )
 
     ) where
 
 #include "HsVersions.h"
 
 import IO      ( Handle )
 
+import PrimRep 
 import AbsCSyn
 import ClosureInfo
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
 import AbsCSyn
 import ClosureInfo
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
-import CallConv                ( CallConv, callConvAttribute, cCallConv )
-import Constants       ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
-import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
-                         isReadOnly, needsCDecl, pprCLabel,
-                         CLabel{-instance Ord-}
+
+import ForeignCall     ( CCallSpec(..), CCallTarget(..), playSafe,
+                         playThreadSafe, ccallConvAttribute,
+                         ForeignCall(..), Safety(..), DNCallSpec(..),
+                         DNType(..), DNKind(..) )
+import CLabel          ( externallyVisibleCLabel,
+                         needsCDecl, pprCLabel, mkClosureLabel,
+                         mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+                         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                ( pprCLabelString )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
-import HeapOffs                ( isZeroOff, subOff, pprHeapOffset )
-import Literal         ( showLiteral, Literal(..) )
-import Maybes          ( maybeToBool, catMaybes )
-import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep         ( isFloatingRep, PrimRep(..), showPrimRep )
-import SMRep           ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-                         isConstantRep, isSpecRep, isPhantomRep
-                       )
+import Literal         ( Literal(..) )
+import TyCon           ( tyConDataCons )
+import Name            ( NamedThing(..) )
+import Maybes          ( catMaybes )
+import PrimOp          ( primOpNeedsWrapper )
+import MachOp          ( MachOp(..) )
+import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize )
 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          ( StgOp(..) )
 import Outputable
 import Outputable
-import Util            ( nOfThem, panic, assertPanic )
+import FastString
+import Util            ( lengthExceeds )
+
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+
+#ifdef DEBUG
+import Util            ( listLengthCmp )
+#endif
+
+import Maybe           ( isJust )
+import GLAEXTS
+import MONAD_ST
 
 infixr 9 `thenTE`
 \end{code}
 
 infixr 9 `thenTE`
 \end{code}
@@ -60,18 +79,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 +115,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 +134,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 +152,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,15 +184,16 @@ 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
     else
        do_if_stmt discrim tag2 alt_code2 alt_code1 c
   where
   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
   = if (i1 == 0) then
        do_if_stmt discrim tag1 alt_code1 alt_code2 c
     else
        do_if_stmt discrim tag2 alt_code2 alt_code1 c
   where
-    empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
+    empty_deflt = not (isJust (nonemptyAbsC deflt))
 
 pprAbsC (CSwitch discrim alts deflt) c -- general case
   | isFloatingRep (getAmodeRep discrim)
 
 pprAbsC (CSwitch discrim alts deflt) c -- general case
   | isFloatingRep (getAmodeRep discrim)
@@ -185,10 +222,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 (StgFCallOp fcall uniq) args vol_regs) _
+  = pprFCall fcall uniq args results vol_regs
 
 
-pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
+pprAbsC stmt@(COpStmt results (StgPrimOp 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,18 +237,18 @@ 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
   where
     ppr_op_call results args
-      = hcat [ pprPrimOp op, lparen,
+      = hcat [ ppr op, lparen,
        hcat (punctuate comma (map ppr_op_result results)),
        if null results || null args then empty else comma,
        hcat (punctuate comma (map pprAmode args)),
        hcat (punctuate comma (map ppr_op_result results)),
        if null results || null args then empty else comma,
        hcat (punctuate comma (map pprAmode args)),
@@ -221,222 +258,426 @@ 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...
 
+-- NEW CASES FOR EXPANDED PRIMOPS
+
+pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
+  = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
+    in
+    case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+    saves $$
+    hcat (
+       [ppr_amode res, equals]
+       ++ (if prefix_fn 
+           then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
+           else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
+       ++ [semi]
+    )
+    $$ restores
+    }
+
+pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
+  = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+    saves $$
+    hcat [ppr_amode res, equals, 
+          pprMachOp_for_C mop, parens (pprAmode arg1),
+          semi]
+    $$ restores
+    }
+
+pprAbsC stmt@(CSequential stuff) c
+  = vcat (map (flip pprAbsC c) stuff)
+
+-- end of NEW CASES FOR EXPANDED PRIMOPS
+
+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 liveness@(Liveness lbl size mask)) c
+  = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)
+
+pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
+  = pprWordArray desc_lbl (
+       CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
+       mkWordCLit (fromIntegral len) :
+       bitmapAddrModes bitmap
+     )
+
 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) _
-  = hcat [ptext op, lparen,
+pprAbsC (CCallProfCtrMacro op as) _
+  = hcat [ftext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallProfCCMacro op as) _
-  = hcat [ptext op, lparen,
+pprAbsC (CCallProfCCMacro op as) _
+  = hcat [ftext op, lparen,
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
        hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq 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
+    {-
+      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.
+
+    -}
 
 
-pprAbsC (CCodeBlock label abs_C) _
-  = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+     fun_nm
+       | is_tdef   = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+       | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty
+
+     ccall_fun_ty = 
+        case op_str of
+         DynamicTarget  -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
+         StaticTarget x -> pprCLabelString x
+
+     ccall_res_ty = 
+       case non_void_results of
+          []       -> ptext SLIT("void")
+         [amode]  -> ppr (getAmodeRep amode)
+         _        -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
+
+     ccall_decl_ty_args 
+       | is_tdef   = tail ccall_arg_tys
+       | otherwise = ccall_arg_tys
+
+     ccall_arg_tys      = map (ppr . 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 = init args
+       in ASSERT (all non_void nvas) nvas
+
+      -- there will usually be two results: a (void) state which we
+      -- should ignore and a (possibly void) result.
+     non_void_results =
+       let nvrs = grab_non_void_amodes results
+       in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
+
+pprAbsC (CCodeBlock lbl abs_C) _
+  = if not (isJust(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
                          then "FN_("   -- abbreviations to save on output
-                         else "IFN_("),
-                  pprCLabel label, text ") {"],
+                         else "IF_("),
+                  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,
+
+pprAbsC (CInitHdr cl_info amode cost_centre size) _
+  = hcat [ ptext SLIT("SET_HDR_"), char '(',
+               ppr_amode amode, comma,
+               pprCLabelAddr info_lbl, comma,
                if_profiling (pprAmode cost_centre), comma,
                if_profiling (pprAmode cost_centre), comma,
-               pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
+               if_profiling (int size),
+               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),
        ptext SLIT("};") ]
     }
   where
        ptext SLIT("};") ]
     }
   where
-    info_lbl = infoTableLabelFromCI cl_info
-
-    ppr_item item
-      = if getAmodeRep item == VoidRep
-       then text ", (W_) 0" -- might not even need this...
-       else (<>) (text ", (W_)") (ppr_amode item)
-
-    padding_wds =
-       if not (closureUpdReqd cl_info) then
-           []
-       else
-           case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
-           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*...
+    info_lbl    = infoTableLabelFromCI cl_info
+
+    ppr_payload [] = empty
+    ppr_payload ls = 
+       comma <+> 
+         (braces $ hsep $ punctuate comma $
+          map (text "(L_)" <>) (foldr ppr_item [] ls))
+
+    ppr_item item rest
+      | rep == VoidRep   = rest
+      | rep == FloatRep  = ppr_amode (floatToWord item) : rest
+      | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
+      | otherwise       = ppr_amode item : rest
+      where 
+       rep  = getAmodeRep item
+
+pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
+  =  pprWordArray info_lbl (mkInfoTable cl_info)
+  $$ let stuff = CCodeBlock entry_lbl entry in
+     pprAbsC stuff (costs stuff)
+  where
+       entry_lbl = entryLabelFromCI cl_info
+       info_lbl  = infoTableLabelFromCI cl_info
+
+pprAbsC stmt@(CClosureTbl tycon) _
+  = vcat (
+       ptext SLIT("CLOSURE_TBL") <> 
+          lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
+       punctuate comma (
+          map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
+       )
+   ) $$ ptext SLIT("};")
+
+pprAbsC stmt@(CRetDirect uniq code srt liveness) _
+  =  pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
+  $$ let stuff = CCodeBlock entry_lbl code in
+     pprAbsC stuff (costs stuff)
+  where
+     info_lbl  = mkReturnInfoLabel uniq
+     entry_lbl = mkReturnPtLabel uniq
 
 
-   then the amodes are dropped in...
-       ,a1 ,a2 ... ,aN
-   then a close brace:
-       };
--}
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
+  = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
 
 
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
   = vcat [
   = 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,
-
-           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 ");"
-       ],
-       pp_slow,
-       case maybe_fast of
-           Nothing -> empty
-           Just fast -> let stuff = CCodeBlock fast_lbl fast in
-                        pprAbsC stuff (costs stuff)
+       ptext SLIT("START_MOD_INIT") <> 
+           parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
+       case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
+       pprAbsC code (costs code),
+       hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
     ]
     ]
-  where
-    info_lbl   = infoTableLabelFromCI cl_info
-    fast_lbl    = fastLabelFromCI cl_info
-    sm_rep     = closureSMRep    cl_info
-
-    (slow_lbl, pp_slow)
-      = case (nonemptyAbsC slow) of
-         Nothing -> (mkErrorStdEntryLabel, empty)
-         Just xx -> (entryLabelFromCI cl_info,
-                      let stuff = CCodeBlock slow_lbl xx in
-                      pprAbsC stuff (costs stuff))
-
-    maybe_selector = maybeSelectorInfo cl_info
-    is_selector = maybeToBool 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))
-
-    pp_tag = int (closureSemiTag cl_info)
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs
+\end{code}
 
 
-    is_phantom = isPhantomRep sm_rep
+Info tables... just arrays of words (the translation is done in
+ClosureInfo).
 
 
-    pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
-                int (closureNonHdrSize cl_info)
+\begin{code}
+pprWordArray lbl amodes
+  = (case snd (initTE (ppr_decls_Amodes amodes)) of
+       Just pp -> pp
+       Nothing -> empty)
+  $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), 
+           pprCLabel lbl, ptext SLIT("[] = {") ]
+  $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
+  $$ ptext SLIT("};")
+
+castToWord s = text "(W_)(" <> s <> char ')'
+\end{code}
 
 
-             else if is_phantom then   -- do not have sizes for these
-                empty
-             else
-                pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
-
-    pp_ptr_wds = if is_phantom then
-                    empty
-                 else
-                    int (closurePtrsSize 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 '"']
-
-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 '}']
+\begin{code}
+-- Print a CMachOp in a way suitable for emitting via C.
+pprMachOp_for_C MO_Nat_Add       = char '+'
+pprMachOp_for_C MO_Nat_Sub       = char '-'
+pprMachOp_for_C MO_Nat_Eq        = text "==" 
+pprMachOp_for_C MO_Nat_Ne        = text "!="
+
+pprMachOp_for_C MO_NatS_Ge       = text ">="
+pprMachOp_for_C MO_NatS_Le       = text "<="
+pprMachOp_for_C MO_NatS_Gt       = text ">"
+pprMachOp_for_C MO_NatS_Lt       = text "<"
+
+pprMachOp_for_C MO_NatU_Ge       = text ">="
+pprMachOp_for_C MO_NatU_Le       = text "<="
+pprMachOp_for_C MO_NatU_Gt       = text ">"
+pprMachOp_for_C MO_NatU_Lt       = text "<"
+
+pprMachOp_for_C MO_NatS_Mul      = char '*'
+pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo"
+pprMachOp_for_C MO_NatS_Quot     = char '/'
+pprMachOp_for_C MO_NatS_Rem      = char '%'
+pprMachOp_for_C MO_NatS_Neg      = char '-'
+
+pprMachOp_for_C MO_NatU_Mul      = char '*'
+pprMachOp_for_C MO_NatU_Quot     = char '/'
+pprMachOp_for_C MO_NatU_Rem      = char '%'
+
+pprMachOp_for_C MO_Nat_And       = text "&"
+pprMachOp_for_C MO_Nat_Or        = text "|"
+pprMachOp_for_C MO_Nat_Xor       = text "^"
+pprMachOp_for_C MO_Nat_Not       = text "~"
+pprMachOp_for_C MO_Nat_Shl       = text "<<"
+pprMachOp_for_C MO_Nat_Shr       = text ">>"
+pprMachOp_for_C MO_Nat_Sar       = text ">>"
+
+pprMachOp_for_C MO_32U_Eq        = text "=="
+pprMachOp_for_C MO_32U_Ne        = text "!="
+pprMachOp_for_C MO_32U_Ge        = text ">="
+pprMachOp_for_C MO_32U_Le        = text "<="
+pprMachOp_for_C MO_32U_Gt        = text ">"
+pprMachOp_for_C MO_32U_Lt        = text "<"
+
+pprMachOp_for_C MO_Dbl_Eq        = text "=="
+pprMachOp_for_C MO_Dbl_Ne        = text "!="
+pprMachOp_for_C MO_Dbl_Ge        = text ">="
+pprMachOp_for_C MO_Dbl_Le        = text "<="
+pprMachOp_for_C MO_Dbl_Gt        = text ">"
+pprMachOp_for_C MO_Dbl_Lt        = text "<"
+
+pprMachOp_for_C MO_Dbl_Add       = text "+"
+pprMachOp_for_C MO_Dbl_Sub       = text "-"
+pprMachOp_for_C MO_Dbl_Mul       = text "*"
+pprMachOp_for_C MO_Dbl_Div       = text "/"
+pprMachOp_for_C MO_Dbl_Pwr       = text "pow"
+
+pprMachOp_for_C MO_Dbl_Sin       = text "sin"
+pprMachOp_for_C MO_Dbl_Cos       = text "cos"
+pprMachOp_for_C MO_Dbl_Tan       = text "tan"
+pprMachOp_for_C MO_Dbl_Sinh      = text "sinh"
+pprMachOp_for_C MO_Dbl_Cosh      = text "cosh"
+pprMachOp_for_C MO_Dbl_Tanh      = text "tanh"
+pprMachOp_for_C MO_Dbl_Asin      = text "asin"
+pprMachOp_for_C MO_Dbl_Acos      = text "acos"
+pprMachOp_for_C MO_Dbl_Atan      = text "atan"
+pprMachOp_for_C MO_Dbl_Log       = text "log"
+pprMachOp_for_C MO_Dbl_Exp       = text "exp"
+pprMachOp_for_C MO_Dbl_Sqrt      = text "sqrt"
+pprMachOp_for_C MO_Dbl_Neg       = text "-"
+
+pprMachOp_for_C MO_Flt_Add       = text "+"
+pprMachOp_for_C MO_Flt_Sub       = text "-"
+pprMachOp_for_C MO_Flt_Mul       = text "*"
+pprMachOp_for_C MO_Flt_Div       = text "/"
+pprMachOp_for_C MO_Flt_Pwr       = text "pow"
+
+pprMachOp_for_C MO_Flt_Eq        = text "=="
+pprMachOp_for_C MO_Flt_Ne        = text "!="
+pprMachOp_for_C MO_Flt_Ge        = text ">="
+pprMachOp_for_C MO_Flt_Le        = text "<="
+pprMachOp_for_C MO_Flt_Gt        = text ">"
+pprMachOp_for_C MO_Flt_Lt        = text "<"
+
+pprMachOp_for_C MO_Flt_Sin       = text "sin"
+pprMachOp_for_C MO_Flt_Cos       = text "cos"
+pprMachOp_for_C MO_Flt_Tan       = text "tan"
+pprMachOp_for_C MO_Flt_Sinh      = text "sinh"
+pprMachOp_for_C MO_Flt_Cosh      = text "cosh"
+pprMachOp_for_C MO_Flt_Tanh      = text "tanh"
+pprMachOp_for_C MO_Flt_Asin      = text "asin"
+pprMachOp_for_C MO_Flt_Acos      = text "acos"
+pprMachOp_for_C MO_Flt_Atan      = text "atan"
+pprMachOp_for_C MO_Flt_Log       = text "log"
+pprMachOp_for_C MO_Flt_Exp       = text "exp"
+pprMachOp_for_C MO_Flt_Sqrt      = text "sqrt"
+pprMachOp_for_C MO_Flt_Neg       = text "-"
+
+pprMachOp_for_C MO_32U_to_NatS   = text "(StgInt)"
+pprMachOp_for_C MO_NatS_to_32U   = text "(StgWord32)"
+
+pprMachOp_for_C MO_NatS_to_Dbl   = text "(StgDouble)"
+pprMachOp_for_C MO_Dbl_to_NatS   = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_Flt   = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_NatS   = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatU  = text "(StgWord)"
+pprMachOp_for_C MO_NatU_to_NatS  = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatP  = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatS  = text "(StgInt)"
+pprMachOp_for_C MO_NatU_to_NatP  = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatU  = text "(StgWord)"
+
+pprMachOp_for_C MO_Dbl_to_Flt    = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_Dbl    = text "(StgDouble)"
+
+pprMachOp_for_C MO_8S_to_NatS    = text "(StgInt8)(StgInt)"
+pprMachOp_for_C MO_16S_to_NatS   = text "(StgInt16)(StgInt)"
+pprMachOp_for_C MO_32S_to_NatS   = text "(StgInt32)(StgInt)"
+
+pprMachOp_for_C MO_8U_to_NatU    = text "(StgWord8)(StgWord)"
+pprMachOp_for_C MO_16U_to_NatU   = text "(StgWord16)(StgWord)"
+pprMachOp_for_C MO_32U_to_NatU   = text "(StgWord32)(StgWord)"
+
+pprMachOp_for_C MO_8U_to_32U     = text "(StgWord32)"
+pprMachOp_for_C MO_32U_to_8U     = text "(StgWord8)"
+
+
+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_")
+         RetInfoTblType     -> ptext SLIT("RI_")
+         ClosureTblType     -> ptext SLIT("CP_")
+         DataType           -> ptext SLIT("D_")
+     ]
   where
   where
-    ppr_maybe_amode Nothing  = ptext SLIT("/*default*/")
-    ppr_maybe_amode (Just a) = pprAmode a
+   is_visible = externallyVisibleCLabel clabel
+   label_type = labelType clabel
 
 
-pprAbsC stmt@(CRetUnVector label amode) _
-  = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
-           pprAmode amode, rparen]
-  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 "};" ] }
-  where
-    ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
+   visiblity_prefix
+     | is_visible = char 'E'
+     | otherwise  = char 'I'
 
 
-pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
-\end{code}
+   dyn_prefix
+     | include_dyn_prefix && labelDynamic clabel = char 'D'
+     | otherwise                                = empty
 
 
-\begin{code}
-ppLocalness label
-  = (<>) static const
-  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)]
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -452,6 +693,15 @@ non_void amode
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
+ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
+ppr_maybe_vol_regs Nothing
+   = (empty, empty)
+ppr_maybe_vol_regs (Just vrs)
+   = case ppr_vol_regs vrs of
+        (saves, restores) 
+           -> (pp_basic_saves $$ saves,
+               pp_basic_restores $$ restores)
+
 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
 
 ppr_vol_regs [] = (empty, empty)
 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
 
 ppr_vol_regs [] = (empty, empty)
@@ -465,36 +715,20 @@ 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, 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}
+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}
@@ -510,20 +744,27 @@ if_profiling pretty
 -- ---------------------------------------------------------------------------
 
 do_if_stmt discrim tag alt_code deflt c
 -- ---------------------------------------------------------------------------
 
 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.
-      MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
-                                     deflt alt_code
-                                     (addrModeCosts discrim Rhs) c
-      other              -> let
-                              cond = hcat [ pprAmode discrim,
-                                         ptext SLIT(" == "),
-                                         pprAmode (CLit tag) ]
-                           in
-                           ppr_if_stmt cond
-                                        alt_code deflt
-                                        (addrModeCosts discrim Rhs) c
+   = 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 tag of
+                  MachInt _  -> ptext SLIT("(I_)")
+                  _          -> empty
+     in
+     ppr_if_stmt cond
+                alt_code deflt
+                (addrModeCosts discrim Rhs) c
 
 ppr_if_stmt pp_pred then_part else_part discrim_costs c
   = vcat [
 
 ppr_if_stmt pp_pred then_part else_part discrim_costs c
   = vcat [
@@ -564,11 +805,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
@@ -592,133 +828,137 @@ 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 [
-      char '{',
-      declare_fun_extern,   -- declare expected function type.
-      declare_local_vars,   -- local var for *result*
-      vcat local_arg_decls,
-      pp_save_context,
-        process_casm local_vars pp_non_void_args casm_str,
-      pp_restore_context,
-      assign_results,
-      char '}'
-    ]
+pprFCall call uniq args results vol_regs
+  = case call of
+      CCall (CCallSpec target _cconv safety) ->
+        vcat [ char '{',
+               declare_local_vars,   -- local var for *result*
+               vcat local_arg_decls,
+               makeCall target safety 
+                        (process_casm local_vars pp_non_void_args (call_str target)),
+               assign_results,
+             char '}'
+            ]
+      DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
+         let
+         target    = StaticTarget (mkFastString nm)
+         resultVar = "_ccall_result"
+         
+         hasAssemArg = isStatic || kind == DNConstructor
+         invokeOp  = 
+           case kind of
+             DNMethod 
+               | isStatic  -> "DN_invokeStatic"
+               | otherwise -> "DN_invokeMethod"
+             DNField
+               | isStatic ->
+                  if resTy == DNUnit 
+                   then "DN_setStatic"
+                   else "DN_getStatic"
+                | otherwise ->
+                  if resTy == DNUnit 
+                   then "DN_setField"
+                   else "DN_getField"
+             DNConstructor -> "DN_createObject"
+
+         (methArrDecl, methArrInit, methArrName, methArrLen) 
+           | null argTys = (empty, empty, text "NULL", text "0")
+           | otherwise   = 
+             ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
+             , vcat (zipWith3 (\ idx arg argTy -> 
+                                text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
+                                text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
+                              [0..]
+                              non_void_args
+                              argTys)
+             , text "__meth_args"
+             , int (length non_void_args)
+             )
+        in
+         vcat [ char '{',
+                 declare_local_vars,
+                 vcat local_arg_decls,
+                 vcat [ methArrDecl
+                      , methArrInit
+                      , text "_ccall_result1 =" <+> text invokeOp <> parens (
+                         hcat (punctuate comma $
+                                    (if hasAssemArg then
+                                       ((if null assem then 
+                                           text "NULL" 
+                                        else 
+                                           doubleQuotes (text assem)):)
+                                     else
+                                        id) $
+                                    [ doubleQuotes $ text nm
+                                    , methArrName
+                                    , methArrLen
+                                    , text (toDotnetTy resTy)
+                                    , text "(void*)&" <> text resultVar 
+                                    ])) <> semi
+                       ],
+                 assign_results,
+               char '}'
+              ]
   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)
-       | 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)
+    
+    makeCall target safety theCall = 
+        vcat [ pp_save_context,        theCall, pp_restore_context ]
+     where
+      (pp_save_context, pp_restore_context)
+       | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <> 
+                               text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+                           , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
+                           )
+       | otherwise = ( pp_basic_saves $$ pp_saves,
+                       pp_basic_restores $$ pp_restores)
+          where
+           thread_macro_args = ppr_uniq_token <> comma <+> 
+                               text "rts" <> ppr (playThreadSafe safety)
+           ppr_uniq_token = text "tok_" <> ppr uniq
+
+
+    non_void_args = 
+       let nvas = init args
+       in ASSERT2 ( all non_void nvas, ppr 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 =
        let nvrs = grab_non_void_amodes results
     -- all others should be non-void
 
     non_void_results =
        let nvrs = grab_non_void_amodes results
-       in ASSERT (length nvrs <= 1) nvrs
+       in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs
     -- there will usually be two results: a (void) state which we
     -- should ignore and a (possibly void) result.
 
     (local_arg_decls, pp_non_void_args)
       = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
 
     -- there will usually be two results: a (void) state which we
     -- should ignore and a (possibly void) result.
 
     (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_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")
-
     (declare_local_vars, local_vars, assign_results)
     (declare_local_vars, local_vars, assign_results)
-      = ppr_casm_results non_void_results pp_liveness
+      = ppr_casm_results non_void_results forDotnet
 
 
-    (Just asm_str) = op_str
-    is_dynamic = not (maybeToBool op_str)
+    forDotnet
+      = case call of
+          DNCall{} -> True
+         _ -> False
 
 
-    casm_str = if is_asm then _UNPK_ asm_str else ccall_str
-
-    -- Remainder only used for ccall
+    call_str tgt 
+      = case tgt of
+         CasmTarget str  -> unpackFS str
+         StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
+         DynamicTarget   -> mk_ccall_str dyn_fun              (tail ccall_args)
 
 
-    fun_name 
-      | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
-      | otherwise  = ptext asm_str
+    ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+    dyn_fun    = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+                                                
 
 
-    ccall_str = showSDoc
+    -- Remainder only used for ccall
+    mk_ccall_str fun_name ccall_fun_args = showSDoc
        (hcat [
                if null non_void_results
                  then empty
        (hcat [
                if null non_void_results
                  then empty
@@ -728,19 +968,50 @@ 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_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
-
-\end{code}
-
-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.
+toDotnetTy :: DNType -> String
+toDotnetTy x = 
+  case x of 
+    DNByte -> "Dotnet_Byte"
+    DNBool -> "Dotnet_Bool"
+    DNChar -> "Dotnet_Char"
+    DNDouble -> "Dotnet_Double"
+    DNFloat  -> "Dotnet_Float"
+    DNInt    -> "Dotnet_Int"
+    DNInt8   -> "Dotnet_Int8"
+    DNInt16  -> "Dotnet_Int16"
+    DNInt32  -> "Dotnet_Int32"
+    DNInt64  -> "Dotnet_Int64"
+    DNWord8  -> "Dotnet_Word8"
+    DNWord16 -> "Dotnet_Word16"
+    DNWord32 -> "Dotnet_Word32"
+    DNWord64 -> "Dotnet_Word64"
+    DNPtr    -> "Dotnet_Ptr"
+    DNUnit   -> "Dotnet_Unit"
+    DNObject -> "Dotnet_Object"
+    DNString -> "Dotnet_String"
+
+toDotnetArgField :: DNType -> String
+toDotnetArgField x = 
+  case x of 
+    DNByte -> "arg_byte"
+    DNBool -> "arg_bool"
+    DNChar -> "arg_char"
+    DNDouble -> "arg_double"
+    DNFloat  -> "arg_float"
+    DNInt    -> "arg_int"
+    DNInt8   -> "arg_int8"
+    DNInt16  -> "arg_int16"
+    DNInt32  -> "arg_int32"
+    DNInt64  -> "arg_int64"
+    DNWord8  -> "arg_word8"
+    DNWord16 -> "arg_word16"
+    DNWord32 -> "arg_word32"
+    DNWord64 -> "arg_word64"
+    DNPtr    -> "arg_ptr"
+    DNUnit   -> "arg_ptr" -- can't happen
+    DNObject -> "arg_obj"
+    DNString -> "arg_str"
 
 
-\begin{code}
 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
     -- (a) decl and assignment, (b) local var to be used later
 
 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
     -- (a) decl and assignment, (b) local var to be used later
 
@@ -752,24 +1023,8 @@ ppr_casm_arg amode a_num
 
        local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 
 
        local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 
-       (arg_type, pp_amode2)
-         = case a_kind of
-
-             -- for array arguments, pass a pointer to the body of the array
-             -- (PTRS_ARR_CTS skips over all the header nonsense)
-             ArrayRep      -> (pp_kind,
-                               hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
-             ByteArrayRep -> (pp_kind,
-                               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 ')'])
-             other         -> (pp_kind, pp_amode)
-
        declare_local_var
        declare_local_var
-         = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
+         = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]
     in
     (declare_local_var, local_var)
 \end{code}
     in
     (declare_local_var, local_var)
 \end{code}
@@ -780,58 +1035,38 @@ 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
+       -> Bool         -- True => multiple results OK.
        ->
        ( 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
-  = let
+ppr_casm_results (r:rs) multiResultsOK
+  | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
+  | otherwise
+  = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
+         (empty,[],empty)
+         (zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
+    where
+      pprRes r suf = (declare_local_var, [local_var], assign_result)
+       where
        result_reg = ppr_amode r
        r_kind     = getAmodeRep r
 
        result_reg = ppr_amode r
        r_kind     = getAmodeRep r
 
-       local_var  = ptext SLIT("_ccall_result")
+       local_var  = ptext SLIT("_ccall_result") <> text suf
 
        (result_type, assign_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 ]
 
        declare_local_var = hcat [ result_type, space, local_var, semi ]
-    in
-    (declare_local_var, [local_var], assign_result)
 
 
-ppr_casm_results rs liveness
-  = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 
 
 \end{code}
 
 
@@ -850,7 +1085,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
@@ -858,12 +1095,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 ->
@@ -873,14 +1110,13 @@ process_casm results args string = process results args string
          in
          case (read_int other) of
            [(num,css)] ->
          in
          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")
+                 if num >= 0 && args `lengthExceeds` num
+                 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}
 
 %************************************************************************
@@ -906,27 +1142,27 @@ Special treatment for floats and doubles, to avoid unwanted conversions.
 
 \begin{code}
 pprAssign FloatRep dest@(CVal reg_rel _) src
 
 \begin{code}
 pprAssign FloatRep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+  = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
 
 pprAssign DoubleRep dest@(CVal reg_rel _) src
 
 pprAssign DoubleRep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+  = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
 
 pprAssign Int64Rep dest@(CVal reg_rel _) src
 
 pprAssign Int64Rep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+  = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
 pprAssign Word64Rep dest@(CVal reg_rel _) src
 pprAssign Word64Rep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+  = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
 \end{code}
 
 Lastly, the question is: will the C compiler think the types of the
 two sides of the assignment match?
 
 \end{code}
 
 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))
@@ -947,13 +1183,6 @@ pprAssign kind dest src
                text "(P_)(",   -- Here is the cast
                ppr_amode src, pp_paren_semi ]
 
                text "(P_)(",   -- Here is the cast
                ppr_amode src, pp_paren_semi ]
 
-pprAssign ByteArrayRep dest src
-  | mixedPtrLocn src
-    -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
-  = hcat [ ppr_amode dest, equals,
-               text "(B_)(",   -- Here is the cast
-               ppr_amode src, pp_paren_semi ]
-
 pprAssign kind other_dest src
   = hcat [ ppr_amode other_dest, equals,
                pprAmode  src, semi ]
 pprAssign kind other_dest src
   = hcat [ ppr_amode other_dest, equals,
                pprAmode  src, semi ]
@@ -983,13 +1212,13 @@ question.)
 
 \begin{code}
 pprAmode (CVal reg_rel FloatRep)
 
 \begin{code}
 pprAmode (CVal reg_rel FloatRep)
-  = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
+  = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
 pprAmode (CVal reg_rel DoubleRep)
 pprAmode (CVal reg_rel DoubleRep)
-  = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+  = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
 pprAmode (CVal reg_rel Int64Rep)
 pprAmode (CVal reg_rel Int64Rep)
-  = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+  = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
 pprAmode (CVal reg_rel Word64Rep)
 pprAmode (CVal reg_rel Word64Rep)
-  = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
+  = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
 \end{code}
 
 Next comes the case where there is some other cast need, and the
 \end{code}
 
 Next comes the case where there is some other cast need, and the
@@ -1004,6 +1233,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}
@@ -1015,53 +1267,78 @@ ppr_amode (CVal reg_rel _)
 ppr_amode (CAddr reg_rel)
   = case (pprRegRelative True{-sign wanted-} reg_rel) of
        (pp_reg, Nothing)     -> pp_reg
 ppr_amode (CAddr reg_rel)
   = case (pprRegRelative True{-sign wanted-} reg_rel) of
        (pp_reg, Nothing)     -> pp_reg
-       (pp_reg, Just offset) -> (<>) pp_reg offset
+       (pp_reg, Just offset) -> pp_reg <> offset
 
 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 (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
 
 
-ppr_amode (CLbl label kind) = pprCLabel label
-
-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}
+
+\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")
+cExprMacroText BYTE_ARR_CTS            = SLIT("BYTE_ARR_CTS")
+cExprMacroText PTRS_ARR_CTS            = SLIT("PTRS_ARR_CTS")
+cExprMacroText ForeignObj_CLOSURE_DATA  = SLIT("ForeignObj_CLOSURE_DATA")
+
+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 SET_TAG                 = SLIT("SET_TAG")
+cStmtMacroText DATA_TO_TAGZH            = SLIT("dataToTagzh")
+cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT         = SLIT("REGISTER_IMPORT")
+cStmtMacroText REGISTER_DIMPORT                = SLIT("REGISTER_DIMPORT")
+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_FUN              = SLIT("HP_CHK_FUN")
+cCheckMacroText        STK_CHK_FUN             = SLIT("STK_CHK_FUN")
+cCheckMacroText        HP_STK_CHK_FUN          = SLIT("HP_STK_CHK_FUN")
+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_UNBX_TUPLE       = SLIT("HP_CHK_UNBX_TUPLE")
+\end{code}
 
 
-ppr_amode (CCostCentre cc print_as_string)
-  = uppCostCentre print_as_string cc
+%************************************************************************
+%*                                                                     *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -1089,31 +1366,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 (SpRel off)
+  = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
 
 
-pprRegRelative sign_wanted (SpBRel spB off)
-  = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB 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
@@ -1124,51 +1400,41 @@ 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 (I# n)
+pprMagicId (DoubleReg n)           = ptext SLIT("D") <> int (I# n)
+pprMagicId (LongReg _ n)           = ptext SLIT("L") <> int (I# n)
+pprMagicId Sp                      = ptext SLIT("Sp")
+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!"
 
 pprMagicId VoidReg                 = panic "pprMagicId:VoidReg!"
 
-pprVanillaReg :: FAST_INT -> SDoc
-
-pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
+pprVanillaReg :: Int# -> SDoc
+pprVanillaReg n = char 'R' <> int (I# n)
 
 pprUnionTag :: PrimRep -> SDoc
 
 pprUnionTag PtrRep             = char 'p'
 pprUnionTag CodePtrRep         = ptext SLIT("fp")
 pprUnionTag DataPtrRep         = char 'd'
 
 pprUnionTag :: PrimRep -> SDoc
 
 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 CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
+pprUnionTag Int8Rep            = ptext SLIT("i8")
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
-pprUnionTag AddrRep            = char 'v'
+pprUnionTag Int32Rep           = char 'i'
+pprUnionTag Word32Rep          = char 'w'
+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 ForeignObjRep      = char 'p'
-
-pprUnionTag ArrayRep           = char 'p'
-pprUnionTag ByteArrayRep       = char 'b'
+pprUnionTag StablePtrRep       = char 'p'
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}
@@ -1269,33 +1535,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}
@@ -1308,9 +1571,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)
@@ -1332,22 +1592,33 @@ 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 (CSimultaneous abc)         = ppr_decls_AbsC abc
+ppr_decls_AbsC (CMachOpStmt res        _ args _) = ppr_decls_Amodes (res : args)
+ppr_decls_AbsC (COpStmt        results _ args _) = ppr_decls_Amodes (results ++ args)
+
+ppr_decls_AbsC (CSimultaneous abc)       = ppr_decls_AbsC abc
+
+ppr_decls_AbsC (CSequential abcs) 
+  = mapTE ppr_decls_AbsC abcs  `thenTE` \ t_and_e_s ->
+    returnTE (maybe_vcat t_and_e_s)
+
+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 (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
@@ -1357,48 +1628,45 @@ ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
   -- no real reason to, anyway.
 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)  = ppr_decls_Amodes amodes
 
   -- no real reason to, anyway.
 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)  = ppr_decls_Amodes amodes
 
-ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
+ppr_decls_AbsC (CStaticClosure _ 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 slow                                `thenTE` \ p2 ->
-    (case maybe_fast of
-       Nothing   -> returnTE (Nothing, Nothing)
-       Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
-    returnTE (maybe_vcat [p1, p2, p3])
-  where
-    entry_lbl = CLbl slow_lbl CodePtrRep
-    slow_lbl    = case (nonemptyAbsC slow) of
-                   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 ->
+ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
+  = ppr_decls_Amodes [entry_lbl]               `thenTE` \ p1 ->
+    ppr_decls_AbsC entry                       `thenTE` \ p2 ->
     returnTE (maybe_vcat [p1, p2])
     returnTE (maybe_vcat [p1, p2])
+  where
+    entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
+
+ppr_decls_AbsC (CSRT _ 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)
 
--- CCharLike may have be arbitrary value -- may have decls
-ppr_decls_Amode (CCharLike char)
-  = ppr_decls_Amode char
+-- CCharLike too
+ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)
 
 -- now, the only place where we actually print temps/externs...
 ppr_decls_Amode (CTemp uniq kind)
 
 -- now, the only place where we actually print temps/externs...
 ppr_decls_Amode (CTemp uniq kind)
@@ -1409,47 +1677,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 ->
+ppr_decls_Amode (CLbl lbl kind)
+  = labelSeenTE lbl `thenTE` \ label_seen ->
     returnTE (Nothing,
     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
-    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
@@ -1473,3 +1707,102 @@ 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
+     RetInfoTblType -> addr_of_label
+     ClosureType    -> addr_of_label
+     VecTblType     -> addr_of_label
+     DataType      -> 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
+
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
+castFloatToIntArray = castSTUArray
+
+castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
+castDoubleToIntArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readIntArray :: STUArray s Int Int -> Int -> ST s Int
+readIntArray = readArray
+
+#else
+
+castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToIntArray = return
+
+castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToIntArray = return
+
+#endif
+
+-- floats are always 1 word
+floatToWord :: CAddrMode -> CAddrMode
+floatToWord (CLit (MachFloat r))
+  = runST (do
+       arr <- newFloatArray ((0::Int),0)
+       writeFloatArray arr 0 (fromRational r)
+       arr' <- castFloatToIntArray arr
+       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)
+       arr' <- castDoubleToIntArray arr
+       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)
+       arr' <- castDoubleToIntArray arr
+       i <- readIntArray arr' 0
+       return [ CLit (MachInt (toInteger i)) ]
+    )
+\end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)