projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1999-01-15 15:57:33 by simonm]
[ghc-hetmet.git] / ghc / compiler / absCSyn / PprAbsC.lhs
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index fe822b4..9143b3b 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
 %
 %************************************************************************
 %*                                                                     *
 %
 %************************************************************************
 %*                                                                     *
@@ -8,61 +8,54 @@
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-#include "HsVersions.h"
-
 module PprAbsC (
        writeRealC,
 module PprAbsC (
        writeRealC,
-       dumpRealC
-#ifdef DEBUG
-       , pprAmode -- otherwise, not exported
-#endif
+       dumpRealC,
+       pprAmode,
+       pprMagicId
     ) where
 
     ) where
 
-IMP_Ubiq(){-uitous-}
-
-IMPORT_1_3(IO(Handle))
-IMPORT_1_3(Char(isDigit,isPrint))
-#if __GLASGOW_HASKELL__ == 201
-IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
-#elif __GLASGOW_HASKELL__ >= 202
-import GlaExts (Addr(..))
-#endif
+#include "HsVersions.h"
 
 
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(AbsCLoop)              -- break its dependence on ClosureInfo
-#else
-#endif
+import IO      ( Handle )
 
 import AbsCSyn
 import ClosureInfo
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
 
 import AbsCSyn
 import ClosureInfo
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
-import Constants       ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+
+import Constants       ( mIN_UPD_SIZE )
+import CallConv                ( CallConv, callConvAttribute, cCallConv )
 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
                          isReadOnly, needsCDecl, pprCLabel,
 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
                          isReadOnly, needsCDecl, pprCLabel,
-                         CLabel{-instance Ord-}
+                         mkReturnInfoLabel, mkReturnPtLabel,
+                         CLabel, CLabelType(..), labelType
                        )
                        )
-import CmdLineOpts     ( opt_SccProfilingOn )
-import CostCentre      ( uppCostCentre, uppCostCentreDecl )
+
+import CmdLineOpts     ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
+import CostCentre      ( pprCostCentreDecl, pprCostCentreStackDecl )
+
 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )
 import CStrings                ( stringToC )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )
 import CStrings                ( stringToC )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
-import HeapOffs                ( isZeroOff, subOff, pprHeapOffset )
-import Literal         ( showLiteral, Literal(..) )
+import Const           ( Literal(..) )
 import Maybes          ( maybeToBool, catMaybes )
 import Maybes          ( maybeToBool, catMaybes )
-import Pretty
 import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
 import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep         ( isFloatingRep, showPrimRep, PrimRep(..) )
-import SMRep           ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-                         isConstantRep, isSpecRep, isPhantomRep
-                       )
+import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
+import SMRep           ( getSMRepStr )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
 import UniqSet         ( emptyUniqSet, elementOfUniqSet,
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
 import UniqSet         ( emptyUniqSet, elementOfUniqSet,
-                         addOneToUniqSet, SYN_IE(UniqSet)
+                         addOneToUniqSet, UniqSet
                        )
                        )
-import Outputable      ( PprStyle(..), printDoc )
-import Util            ( nOfThem, panic, assertPanic )
+import StgSyn          ( SRT(..) )
+import BitSet          ( intBS )
+import Outputable
+import Util            ( nOfThem )
+import Addr            ( Addr )
+
+import ST
+import MutableArray
 
 infixr 9 `thenTE`
 \end{code}
 
 infixr 9 `thenTE`
 \end{code}
@@ -73,67 +66,86 @@ 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 -> IO ()
 writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
+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))
+
+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"))
 
 
-dumpRealC :: AbstractC -> Doc
-dumpRealC absC = pprAbsC PprForC absC (costs absC)
 \end{code}
 
 This emits the macro,  which is used in GrAnSim  to compute the total costs
 from a cost 5 tuple. %%  HWL
 
 \begin{code}
 \end{code}
 
 This emits the macro,  which is used in GrAnSim  to compute the total costs
 from a cost 5 tuple. %%  HWL
 
 \begin{code}
-emitMacro :: CostRes -> Doc
+emitMacro :: CostRes -> SDoc
+
+emitMacro _ | not opt_GranMacros = empty
 
 
--- ToDo: Check a compile time flag to decide whether a macro should be emitted
 emitMacro (Cost (i,b,l,s,f))
   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                           int i, comma, int b, comma, int l, comma,
                          int s, comma, int f, pp_paren_semi ]
 emitMacro (Cost (i,b,l,s,f))
   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                           int i, comma, int b, comma, int l, comma,
                          int s, comma, int f, pp_paren_semi ]
-\end{code}
 
 
-\begin{code}
 pp_paren_semi = text ");"
 pp_paren_semi = text ");"
+\end{code}
 
 
--- ---------------------------------------------------------------------------
--- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
--- code as an argument (that's needed when spitting out the GRAN_EXEC macro
--- which must be done before the return i.e. inside absC code)   HWL
--- ---------------------------------------------------------------------------
-
-pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
-
-pprAbsC sty AbsCNop _ = empty
-pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
+New type: Now pprAbsC also takes the costs for evaluating the Abstract C
+code as an argument (that's needed when spitting out the GRAN_EXEC macro
+which must be done before the return i.e. inside absC code)   HWL
 
 
-pprAbsC sty (CClosureUpdInfo info) c
-  = pprAbsC sty info c
+\begin{code}
+pprAbsC :: AbstractC -> CostRes -> SDoc
+pprAbsC AbsCNop _ = empty
+pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
 
 
-pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
+pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
 
 
-pprAbsC sty (CJump target) c
+pprAbsC (CJump target) c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
-            (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
+            (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 
 
-pprAbsC sty (CFallThrough target) c
+pprAbsC (CFallThrough target) c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
-            (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
+            (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
 
 -- --------------------------------------------------------------------------
 -- Spit out GRAN_EXEC macro immediately before the return                 HWL
 
 
 -- --------------------------------------------------------------------------
 -- Spit out GRAN_EXEC macro immediately before the return                 HWL
 
-pprAbsC sty (CReturn am return_info)  c
+pprAbsC (CReturn am return_info)  c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
             (hcat [text jmp_lit, target, pp_paren_semi ])
   where
    target = case return_info of
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
             (hcat [text jmp_lit, target, pp_paren_semi ])
   where
    target = case return_info of
-       DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
-       DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
+       DirectReturn -> hcat [char '(', pprAmode am, rparen]
+       DynamicVectoredReturn am' -> mk_vector (pprAmode am')
        StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
        StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
-   mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
+   mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
+                      x, rparen ]
 
 
-pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
+pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
 
 -- we optimise various degenerate cases of CSwitches.
 
 
 -- we optimise various degenerate cases of CSwitches.
 
@@ -145,60 +157,64 @@ pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
 --                                                                       HWL
 -- --------------------------------------------------------------------------
 
 --                                                                       HWL
 -- --------------------------------------------------------------------------
 
-pprAbsC sty (CSwitch discrim [] deflt) c
-  = pprAbsC sty deflt (c + costs deflt)
+pprAbsC (CSwitch discrim [] deflt) c
+  = pprAbsC deflt (c + costs deflt)
     -- Empty alternative list => no costs for discrim as nothing cond. here HWL
 
     -- Empty alternative list => no costs for discrim as nothing cond. here HWL
 
-pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
+pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
   = case (nonemptyAbsC deflt) of
       Nothing ->               -- one alt and no default
   = case (nonemptyAbsC deflt) of
       Nothing ->               -- one alt and no default
-                pprAbsC sty alt_code (c + costs alt_code)
+                pprAbsC alt_code (c + costs alt_code)
                 -- Nothing conditional in here either  HWL
 
       Just dc ->               -- make it an "if"
                 -- Nothing conditional in here either  HWL
 
       Just dc ->               -- make it an "if"
-                do_if_stmt sty discrim tag alt_code dc c
+                do_if_stmt discrim tag alt_code dc c
 
 
-pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
+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
                              (tag2@(MachInt i2 _), alt_code2)] deflt) c
   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
   = if (i1 == 0) then
-       do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
+       do_if_stmt discrim tag1 alt_code1 alt_code2 c
     else
     else
-       do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
+       do_if_stmt discrim tag2 alt_code2 alt_code1 c
   where
     empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
 
   where
     empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
 
-pprAbsC sty (CSwitch discrim alts deflt) c -- general case
+pprAbsC (CSwitch discrim alts deflt) c -- general case
   | isFloatingRep (getAmodeRep discrim)
   | isFloatingRep (getAmodeRep discrim)
-    = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
+    = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
   | otherwise
     = vcat [
        hcat [text "switch (", pp_discrim, text ") {"],
   | otherwise
     = vcat [
        hcat [text "switch (", pp_discrim, text ") {"],
-       nest 2 (vcat (map (ppr_alt sty) alts)),
+       nest 2 (vcat (map ppr_alt alts)),
        (case (nonemptyAbsC deflt) of
           Nothing -> empty
           Just dc ->
            nest 2 (vcat [ptext SLIT("default:"),
        (case (nonemptyAbsC deflt) of
           Nothing -> empty
           Just dc ->
            nest 2 (vcat [ptext SLIT("default:"),
-                                 pprAbsC sty dc (c + switch_head_cost
+                                 pprAbsC dc (c + switch_head_cost
                                                    + costs dc),
                                  ptext SLIT("break;")])),
        char '}' ]
   where
     pp_discrim
                                                    + costs dc),
                                  ptext SLIT("break;")])),
        char '}' ]
   where
     pp_discrim
-      = pprAmode sty discrim
+      = pprAmode discrim
 
 
-    ppr_alt sty (lit, absC)
-      = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
-                  nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC))
+    ppr_alt (lit, absC)
+      = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
+                  nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
                                       (ptext SLIT("break;"))) ]
 
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 
                                       (ptext SLIT("break;"))) ]
 
     -- Costs for addressing header of switch and cond. branching        -- HWL
     switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
 
-pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
-  = pprCCall sty op args results liveness_mask vol_regs
+{-
+pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _) args vol_regs) _
+  = pprCCall op args results vol_regs
+-}
+pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
+  = pprCCall op args results vol_regs
 
 
-pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
+pprAbsC stmt@(COpStmt results op args vol_regs) _
   = let
        non_void_args = grab_non_void_amodes args
        non_void_results = grab_non_void_amodes results
   = let
        non_void_args = grab_non_void_amodes args
        non_void_results = grab_non_void_amodes results
@@ -210,247 +226,330 @@ pprAbsC sty 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 sty vol_regs) of { (pp_saves, pp_restores) ->
+    case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
     if primOpNeedsWrapper op then
        vcat [  pp_saves,
     if primOpNeedsWrapper op then
        vcat [  pp_saves,
-                   the_op,
-                   pp_restores
-                ]
+               the_op,
+               pp_restores
+            ]
     else
        the_op
     }
   where
     ppr_op_call results args
     else
        the_op
     }
   where
     ppr_op_call results args
-      = hcat [ pprPrimOp sty op, lparen,
+      = hcat [ pprPrimOp op, lparen,
        hcat (punctuate comma (map ppr_op_result results)),
        if null results || null args then empty else comma,
        hcat (punctuate comma (map ppr_op_result results)),
        if null results || null args then empty else comma,
-       hcat (punctuate comma (map (pprAmode sty) args)),
+       hcat (punctuate comma (map pprAmode args)),
        pp_paren_semi ]
 
        pp_paren_semi ]
 
-    ppr_op_result r = ppr_amode sty r
+    ppr_op_result r = ppr_amode r
       -- primop macros do their own casting of result;
       -- hence we can toss the provided cast...
 
       -- primop macros do their own casting of result;
       -- hence we can toss the provided cast...
 
-pprAbsC sty (CSimultaneous abs_c) c
-  = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
+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("};")
+  }
+  where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
+
+pprAbsC stmt@(CBitmap lbl mask) c
+  = vcat [
+       hcat [ ptext SLIT("BITMAP"), lparen, 
+                       pprCLabel lbl, comma,
+                       int (length mask), 
+              rparen ],
+        hcat (punctuate comma (map (int.intBS) mask)),
+       ptext SLIT("}};")
+    ]
+
+pprAbsC (CSimultaneous abs_c) c
+  = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
 
 
-pprAbsC sty stmt@(CMacroStmt macro as) _
+pprAbsC (CCheck macro as code) c
   = hcat [text (show macro), lparen,
   = hcat [text (show macro), lparen,
-       hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
-pprAbsC sty stmt@(CCallProfCtrMacro op as) _
+       hcat (punctuate comma (map ppr_amode as)), comma,
+       pprAbsC code c, pp_paren_semi
+    ]
+pprAbsC (CMacroStmt macro as) _
+  = hcat [text (show macro), lparen,
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
+pprAbsC (CCallProfCtrMacro op as) _
   = hcat [ptext op, lparen,
   = hcat [ptext op, lparen,
-       hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
-pprAbsC sty stmt@(CCallProfCCMacro op as) _
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC (CCallProfCCMacro op as) _
   = hcat [ptext op, lparen,
   = hcat [ptext op, lparen,
-       hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
+  =  hsep [ ptext SLIT("typedef")
+         , ccall_res_ty
+         , fun_nm
+         , parens (hsep (punctuate comma ccall_decl_ty_args))
+         ] <> semi
+    where
+     fun_nm       = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+
+     ccall_fun_ty = 
+        case op_str of
+         Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+
+     ccall_res_ty = 
+       case non_void_results of
+          []       -> ptext SLIT("void")
+         [amode]  -> text (showPrimRep (getAmodeRep amode))
+         _        -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
+
+     ccall_decl_ty_args = tail ccall_arg_tys
+     ccall_arg_tys      = map (text.showPrimRep.getAmodeRep) non_void_args
+
+      -- the first argument will be the "I/O world" token (a VoidRep)
+      -- all others should be non-void
+     non_void_args =
+       let nvas = tail args
+       in ASSERT (all non_void nvas) nvas
 
 
-pprAbsC sty (CCodeBlock label abs_C) _
-  = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+      -- 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 (length nvrs <= 1) nvrs
+
+pprAbsC (CCodeBlock label abs_C) _
+  = if not (maybeToBool(nonemptyAbsC abs_C)) then
+       pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+    else
     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [
        hcat [text (if (externallyVisibleCLabel label)
                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),
     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [
        hcat [text (if (externallyVisibleCLabel label)
                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),
-                  pprCLabel sty label, text ") {"],
-       case sty of
-         PprForC -> ($$) pp_exts pp_temps
-         _ -> empty,
+                  pprCLabel label, text ") {"],
+
+       pp_exts, pp_temps,
+
        nest 8 (ptext SLIT("FB_")),
        nest 8 (ptext SLIT("FB_")),
-       nest 8 (pprAbsC sty abs_C (costs abs_C)),
+       nest 8 (pprAbsC abs_C (costs abs_C)),
        nest 8 (ptext SLIT("FE_")),
        char '}' ]
     }
 
        nest 8 (ptext SLIT("FE_")),
        char '}' ]
     }
 
-pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
-  = hcat [ pp_init_hdr, text "_HDR(",
-               ppr_amode sty (CAddr reg_rel), comma,
-               pprCLabel sty info_lbl, comma,
-               if_profiling sty (pprAmode sty cost_centre), comma,
-               pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ]
+
+pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
+  = hcat [ ptext SLIT("SET_HDR_"), char '(',
+               ppr_amode (CAddr reg_rel), comma,
+               pprCLabelAddr info_lbl, comma,
+               if_profiling (pprAmode cost_centre),
+               pp_paren_semi ]
   where
     info_lbl   = infoTableLabelFromCI cl_info
   where
     info_lbl   = infoTableLabelFromCI cl_info
-    sm_rep     = closureSMRep     cl_info
-    size       = closureSizeWithoutFixedHdr cl_info
-    ptr_wds    = closurePtrsSize  cl_info
-
-    pp_init_hdr = text (if inplace_upd then
-                           getSMUpdInplaceHdrStr sm_rep
-                       else
-                           getSMInitHdrStr sm_rep)
 
 
-pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
+pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
     vcat [
   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
     vcat [
-       case sty of
-         PprForC -> pp_exts
-         _ -> empty,
+       pp_exts,
        hcat [
        hcat [
-               ptext SLIT("SET_STATIC_HDR"),char '(',
-               pprCLabel sty closure_lbl,                      comma,
-               pprCLabel sty info_lbl,                         comma,
-               if_profiling sty (pprAmode sty cost_centre),    comma,
+               ptext SLIT("SET_STATIC_HDR"), char '(',
+               pprCLabel closure_lbl,                          comma,
+               pprCLabel info_lbl,                             comma,
+               if_profiling (pprAmode cost_centre),            comma,
                ppLocalness closure_lbl,                        comma,
                ppLocalness closure_lbl,                        comma,
-               ppLocalnessMacro False{-for data-} info_lbl,
+               ppLocalnessMacro info_lbl,
                char ')'
                ],
                char ')'
                ],
-       nest 2 (hcat (map (ppr_item sty) amodes)),
-       nest 2 (hcat (map (ppr_item sty) padding_wds)),
+       nest 2 (ppr_payload (amodes ++ padding_wds)),
        ptext SLIT("};") ]
     }
   where
     info_lbl = infoTableLabelFromCI cl_info
 
        ptext SLIT("};") ]
     }
   where
     info_lbl = infoTableLabelFromCI cl_info
 
-    ppr_item sty item
-      = if getAmodeRep item == VoidRep
-       then text ", (W_) 0" -- might not even need this...
-       else (<>) (text ", (W_)") (ppr_amode sty item)
-
+    ppr_payload [] = empty
+    ppr_payload ls = comma <+> 
+                    braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
+
+    ppr_item item
+      | rep == VoidRep   = text "0" -- might not even need this...
+      | rep == FloatRep  = ppr_amode (floatToWord item)
+      | rep == DoubleRep = hcat (punctuate (text ", (L_)")
+                                (map ppr_amode (doubleToWords item)))
+      | otherwise       = ppr_amode item
+      where 
+       rep = getAmodeRep item
+
+    -- always at least one padding word: this is the static link field for
+    -- the garbage collector.
     padding_wds =
        if not (closureUpdReqd cl_info) then
     padding_wds =
        if not (closureUpdReqd cl_info) then
-           []
+           [mkIntCLit 0]
        else
        else
-           case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+           case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
            nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 
            nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
 
-{-
-   STATIC_INIT_HDR(c,i,localness) blows into:
-       localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
-
-   then *NO VarHdr STUFF FOR STATIC*...
-
-   then the amodes are dropped in...
-       ,a1 ,a2 ... ,aN
-   then a close brace:
-       };
--}
-
-pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
+pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
   = vcat [
        hcat [
   = vcat [
        hcat [
-           pp_info_rep,
-           ptext SLIT("_ITBL"),char '(',
-           pprCLabel sty info_lbl,                     comma,
-
-               -- CONST_ITBL needs an extra label for
-               -- the static version of the object.
-           if isConstantRep sm_rep
-           then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
-           else empty,
-
-           pprCLabel sty slow_lbl,     comma,
-           pprAmode sty 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 sty pp_kind, comma,
-           if_profiling sty pp_descr, comma,
-           if_profiling sty pp_type,
+            ptext SLIT("INFO_TABLE"),
+            ( if is_selector then
+                ptext SLIT("_SELECTOR")
+              else if is_constr then
+                ptext SLIT("_CONSTR")
+              else if needs_srt then
+                ptext SLIT("_SRT")
+               else empty ), char '(',
+
+           pprCLabel info_lbl,                         comma,
+           pprCLabel slow_lbl,                         comma,
+           pp_rest, {- ptrs,nptrs,[srt,]type,-}        comma,
+
+           ppLocalness info_lbl,                       comma,
+           ppLocalnessMacro slow_lbl,                  comma,
+
+           if_profiling pp_descr, comma,
+           if_profiling pp_type,
            text ");"
            text ");"
-       ],
+            ],
        pp_slow,
        case maybe_fast of
            Nothing -> empty
            Just fast -> let stuff = CCodeBlock fast_lbl fast in
        pp_slow,
        case maybe_fast of
            Nothing -> empty
            Just fast -> let stuff = CCodeBlock fast_lbl fast in
-                        pprAbsC sty stuff (costs stuff)
+                        pprAbsC stuff (costs stuff)
     ]
   where
     info_lbl   = infoTableLabelFromCI cl_info
     fast_lbl    = fastLabelFromCI cl_info
     ]
   where
     info_lbl   = infoTableLabelFromCI cl_info
     fast_lbl    = fastLabelFromCI cl_info
-    sm_rep     = closureSMRep    cl_info
 
     (slow_lbl, pp_slow)
       = case (nonemptyAbsC slow) of
          Nothing -> (mkErrorStdEntryLabel, empty)
          Just xx -> (entryLabelFromCI cl_info,
                       let stuff = CCodeBlock slow_lbl xx in
 
     (slow_lbl, pp_slow)
       = case (nonemptyAbsC slow) of
          Nothing -> (mkErrorStdEntryLabel, empty)
          Just xx -> (entryLabelFromCI cl_info,
                       let stuff = CCodeBlock slow_lbl xx in
-                      pprAbsC sty stuff (costs stuff))
+                      pprAbsC stuff (costs stuff))
 
     maybe_selector = maybeSelectorInfo cl_info
     is_selector = maybeToBool maybe_selector
 
     maybe_selector = maybeSelectorInfo cl_info
     is_selector = maybeToBool maybe_selector
-    (Just (_, select_word_i)) = maybe_selector
+    (Just select_word_i) = maybe_selector
 
 
-    pp_info_rep            -- special stuff if it's a selector; otherwise, just the SMrep
-      = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
+    maybe_tag = closureSemiTag cl_info
+    is_constr = maybeToBool maybe_tag
+    (Just tag) = maybe_tag
 
 
-    pp_tag = int (closureSemiTag cl_info)
+    needs_srt = has_srt srt && needsSRT cl_info
 
 
-    is_phantom = isPhantomRep sm_rep
+    size = closureNonHdrSize cl_info
 
 
-    pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
-                int (closureNonHdrSize cl_info)
+    ptrs        = closurePtrsSize cl_info
+    nptrs      = size - ptrs
 
 
-             else if is_phantom then   -- do not have sizes for these
-                empty
-             else
-                pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
+    pp_rest | is_selector      = int select_word_i
+            | otherwise        = hcat [
+                 int ptrs,             comma,
+                 int nptrs,            comma,
+                 if is_constr then
+                       hcat [ int tag, comma ]
+                  else if needs_srt then
+                       pp_srt_info srt
+                 else empty,
+                 type_str ]
 
 
-    pp_ptr_wds = if is_phantom then
-                    empty
-                 else
-                    int (closurePtrsSize cl_info)
+    type_str = text (getSMRepStr (closureSMRep cl_info))
 
 
-    pp_kind  = text (closureKind cl_info)
     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 
     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 
-pprAbsC sty (CRetVector lbl maybes deflt) c
-  = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
-              nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
-              text "} /*default=*/ {", pprAbsC sty deflt c,
-              char '}']
+pprAbsC stmt@(CRetDirect uniq code srt liveness) _
+  = vcat [
+      hcat [
+         ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen, 
+         pprCLabel info_lbl,           comma,
+         pprCLabel entry_lbl,          comma,
+          pp_liveness liveness,                comma,    -- bitmap
+         pp_srt_info srt,                        -- SRT
+         ptext type_str,               comma,    -- closure type
+         ppLocalness info_lbl,         comma,    -- info table storage class
+         ppLocalnessMacro entry_lbl,   comma,    -- entry pt storage class
+         int 0, comma,
+         int 0, text ");"
+      ],
+      pp_code
+    ]
   where
   where
-    ppr_maybe_amode sty Nothing  = ptext SLIT("/*default*/")
-    ppr_maybe_amode sty (Just a) = pprAmode sty a
+     info_lbl  = mkReturnInfoLabel uniq
+     entry_lbl = mkReturnPtLabel uniq
 
 
-pprAbsC sty stmt@(CRetUnVector label amode) _
-  = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
-           pprAmode sty amode, rparen]
-  where
-    pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
-
-pprAbsC sty stmt@(CFlatRetVector label amodes) _
-  =    case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
-       vcat [
-           case sty of
-             PprForC -> pp_exts
-             _ -> empty,
-           hcat [ppLocalness label, ptext SLIT(" W_ "),
-                      pprCLabel sty label, text "[] = {"],
-           nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
-           text "};" ] }
-  where
-    ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
+     pp_code   = let stuff = CCodeBlock entry_lbl code in
+                pprAbsC stuff (costs stuff)
+
+     type_str = case liveness of
+                  LvSmall _ -> SLIT("RET_SMALL")
+                  LvLarge _ -> SLIT("RET_BIG")
 
 
-pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
+pprAbsC stmt@(CRetVector label amodes srt liveness) _
+  = vcat [
+       pp_vector,
+       hcat [
+       ptext SLIT("  }"), comma, ptext SLIT("\n  VEC_INFO_TABLE"),
+       lparen, 
+       pp_liveness liveness, comma,    -- bitmap liveness mask
+       pp_srt_info srt,                -- SRT
+       ptext type_str,                 -- or big, depending on the size
+                                       -- of the liveness mask.
+       rparen 
+       ],
+       text "};"
+    ]
+
+  where
+    pp_vector = 
+        case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+        vcat [
+           pp_exts,
+           hcat [ppLocalness label,
+                 ptext SLIT(" vec_info_"), int size, space,
+                 pprCLabel label, text "= { {"
+                 ],
+           nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
+           ] }
+
+    ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
+    size = length amodes
+
+    type_str = case liveness of
+                  LvSmall _ -> SLIT("RET_VEC_SMALL")
+                  LvLarge _ -> SLIT("RET_VEC_BIG")
+
+
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs
 \end{code}
 
 \begin{code}
 ppLocalness label
   = (<>) static const
   where
 \end{code}
 
 \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)]
+    static = if (externallyVisibleCLabel label) 
+               then empty 
+               else ptext SLIT("static ")
+    const  = if not (isReadOnly label)         
+               then empty 
+               else ptext SLIT("const")
+
+-- Horrible macros for declaring the types and locality of labels (see
+-- StgMacros.h).
+
+ppLocalnessMacro clabel =
+     hcat [
+       char (if externallyVisibleCLabel clabel then 'E' else 'I'),
+       case labelType clabel of
+         InfoTblType -> ptext SLIT("I_")
+         ClosureType -> ptext SLIT("C_")
+         CodeType    -> ptext SLIT("F_")
+         DataType    -> ptext SLIT("D_") <>
+                                  if isReadOnly clabel 
+                                     then ptext SLIT("RO_") 
+                                     else empty 
+     ]
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -466,15 +565,15 @@ non_void amode
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
+ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
 
 
-ppr_vol_regs sty [] = (empty, empty)
-ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
-ppr_vol_regs sty (r:rs)
+ppr_vol_regs [] = (empty, empty)
+ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
+ppr_vol_regs (r:rs)
   = let pp_reg = case r of
                    VanillaReg pk n -> pprVanillaReg n
   = let pp_reg = case r of
                    VanillaReg pk n -> pprVanillaReg n
-                   _ -> pprMagicId sty r
-       (more_saves, more_restores) = ppr_vol_regs sty rs
+                   _ -> pprMagicId r
+       (more_saves, more_restores) = ppr_vol_regs rs
     in
     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
     in
     (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
      ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
@@ -483,43 +582,38 @@ ppr_vol_regs sty (r:rs)
 -- 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.
+-- anything else. The correct sequence of saves&restores are
+-- encoded by the CALLER_*_SYSTEM macros.
 pp_basic_saves
 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") ]
+  = vcat
+       [ ptext SLIT("CALLER_SAVE_Base")
+       , ptext SLIT("CALLER_SAVE_SYSTEM")
+       ]
+
+pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-if_profiling sty pretty
-  = case sty of
-      PprForC -> if  opt_SccProfilingOn
-                then pretty
-                else char '0' -- leave it out!
-
-      _ -> {-print it anyway-} pretty
+has_srt (_, NoSRT) = False
+has_srt _ = True
+
+pp_srt_info srt = 
+    case srt of
+       (lbl, NoSRT) -> 
+               hcat [  int 0, comma, 
+                       int 0, comma, 
+                       int 0, comma ]
+       (lbl, SRT off len) -> 
+               hcat [  pprCLabel lbl, comma,
+                       int off, comma,
+                       int len, comma ]
+\end{code}
 
 
+\begin{code}
+if_profiling pretty
+  = if  opt_SccProfilingOn
+    then pretty
+    else char '0' -- leave it out!
 -- ---------------------------------------------------------------------------
 -- Changes for GrAnSim:
 --  draw costs for computation in head of if into both branches;
 -- ---------------------------------------------------------------------------
 -- Changes for GrAnSim:
 --  draw costs for computation in head of if into both branches;
@@ -527,30 +621,30 @@ if_profiling sty pretty
 --  guessing unknown values and fed into the costs function
 -- ---------------------------------------------------------------------------
 
 --  guessing unknown values and fed into the costs function
 -- ---------------------------------------------------------------------------
 
-do_if_stmt sty 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.
   = 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 sty (pprAmode sty discrim)
+      MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
                                      deflt alt_code
                                      (addrModeCosts discrim Rhs) c
       other              -> let
                                      deflt alt_code
                                      (addrModeCosts discrim Rhs) c
       other              -> let
-                              cond = hcat [ pprAmode sty discrim,
+                              cond = hcat [ pprAmode discrim,
                                          ptext SLIT(" == "),
                                          ptext SLIT(" == "),
-                                         pprAmode sty (CLit tag) ]
+                                         pprAmode (CLit tag) ]
                            in
                            in
-                           ppr_if_stmt sty cond
+                           ppr_if_stmt cond
                                         alt_code deflt
                                         (addrModeCosts discrim Rhs) c
 
                                         alt_code deflt
                                         (addrModeCosts discrim Rhs) c
 
-ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
+ppr_if_stmt pp_pred then_part else_part discrim_costs c
   = vcat [
       hcat [text "if (", pp_pred, text ") {"],
   = vcat [
       hcat [text "if (", pp_pred, text ") {"],
-      nest 8 (pprAbsC sty then_part    (c + discrim_costs +
+      nest 8 (pprAbsC then_part        (c + discrim_costs +
                                        (Cost (0, 2, 0, 0, 0)) +
                                        costs then_part)),
       (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
                                        (Cost (0, 2, 0, 0, 0)) +
                                        costs then_part)),
       (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
-      nest 8 (pprAbsC sty else_part  (c + discrim_costs +
+      nest 8 (pprAbsC else_part  (c + discrim_costs +
                                        (Cost (0, 1, 0, 0, 0)) +
                                        costs else_part)),
       char '}' ]
                                        (Cost (0, 1, 0, 0, 0)) +
                                        costs else_part)),
       char '}' ]
@@ -575,18 +669,13 @@ Some rough notes on generating code for @CCallOp@:
    be restarted during the call.
 
 3) Save any temporary registers that are currently in use.
    be restarted during the call.
 
 3) Save any temporary registers that are currently in use.
-4) Do the call putting result into a local variable
+4) Do the call, putting result into a local variable
 5) Restore essential registers
 6) Restore temporaries
 
    (This happens after restoration of essential registers because we
    might need the @Base@ register to access all the others correctly.)
 
 5) Restore essential registers
 6) Restore temporaries
 
    (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 create via primop.
-   makeForeignObj (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
@@ -610,34 +699,31 @@ 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 sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
-  = if (may_gc && liveness_mask /= noLiveRegsMask)
-    then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
-    else
-    vcat [
+pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
+  = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*
       vcat local_arg_decls,
       char '{',
       declare_local_vars,   -- local var for *result*
       vcat local_arg_decls,
-      -- if is_asm then empty else declareExtern,
       pp_save_context,
       pp_save_context,
-      process_casm local_vars pp_non_void_args casm_str,
+        declare_fun_extern,   -- declare expected function type.
+        process_casm local_vars pp_non_void_args casm_str,
       pp_restore_context,
       assign_results,
       char '}'
     ]
   where
       pp_restore_context,
       assign_results,
       char '}'
     ]
   where
-    (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
-    (pp_save_context, pp_restore_context) =
-       if may_gc
-       then (  text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
-               text "inCCallGC--; RestoreAllStgRegs();} while(0);")
-       else (  pp_basic_saves $$ pp_saves,
-               pp_basic_restores $$ pp_restores)
+    (pp_saves, pp_restores) = ppr_vol_regs vol_regs
+    (pp_save_context, pp_restore_context)
+       | may_gc  = ( text "do { SaveThreadState();"
+                   , text "LoadThreadState();} while(0);"
+                   )
+       | otherwise = ( pp_basic_saves $$ pp_saves,
+                       pp_basic_restores $$ pp_restores)
 
     non_void_args =
        let nvas = tail args
 
     non_void_args =
        let nvas = tail args
@@ -652,43 +738,122 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo
     -- should ignore and a (possibly void) result.
 
     (local_arg_decls, pp_non_void_args)
     -- should ignore and a (possibly void) result.
 
     (local_arg_decls, pp_non_void_args)
-      = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
+      = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
+
+
+    {-
+      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.
 
 
-    pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
+    -}
+    declare_fun_extern
+      | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
+      | otherwise                          =
+         hsep [ typedef_or_extern
+             , ccall_res_ty
+             , fun_nm
+             , parens (hsep (punctuate comma ccall_decl_ty_args))
+             ] <> semi
+       where
+       typedef_or_extern
+         | is_dynamic     = ptext SLIT("typedef")
+         | otherwise      = ptext SLIT("extern")
+
+        fun_nm 
+         | is_dynamic     = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+         | otherwise      = text (callConvAttribute cconv) <+> ptext asm_str
+
+         -- leave out function pointer
+       ccall_decl_ty_args
+         | is_dynamic     = tail ccall_arg_tys
+         | otherwise      = ccall_arg_tys
+
+    ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
+
+    ccall_res_ty = 
+       case non_void_results of
+          []       -> ptext SLIT("void")
+         [amode]  -> text (showPrimRep (getAmodeRep amode))
+         _        -> panic "pprCCall: ccall_res_ty"
+
+    ccall_fun_ty = 
+       ptext SLIT("_ccall_fun_ty") <>
+       case op_str of
+         Right u -> ppr u
+        _       -> empty
 
     (declare_local_vars, local_vars, assign_results)
 
     (declare_local_vars, local_vars, assign_results)
-      = ppr_casm_results sty non_void_results pp_liveness
+      = ppr_casm_results non_void_results
+
+    (Left asm_str) = op_str
+    is_dynamic = 
+       case op_str of
+         Left _ -> False
+        _      -> True
 
 
-    casm_str = if is_asm then _UNPK_ op_str else ccall_str
+    casm_str = if is_asm then _UNPK_ asm_str else ccall_str
 
     -- Remainder only used for ccall
 
 
     -- Remainder only used for ccall
 
-    ccall_str = show
+    fun_name 
+      | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
+      | otherwise  = ptext asm_str
+
+    ccall_str = showSDoc
        (hcat [
                if null non_void_results
                  then empty
                  else text "%r = ",
        (hcat [
                if null non_void_results
                  then empty
                  else text "%r = ",
-               lparen, ptext op_str, lparen,
-                 hcat (punctuate comma ccall_args),
+               lparen, fun_name, lparen,
+                 hcat (punctuate comma ccall_fun_args),
                text "));"
        ])
                text "));"
        ])
-    num_args = length non_void_args
-    ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
+
+    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
 \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.
+passed are @Array@s and @ByteArray@s.
 
 \begin{code}
 
 \begin{code}
-ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
+ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
     -- (a) decl and assignment, (b) local var to be used later
 
     -- (a) decl and assignment, (b) local var to be used later
 
-ppr_casm_arg sty amode a_num
+ppr_casm_arg amode a_num
   = let
        a_kind   = getAmodeRep amode
   = let
        a_kind   = getAmodeRep amode
-       pp_amode = pprAmode sty amode
-       pp_kind  = pprPrimKind sty a_kind
+       pp_amode = pprAmode amode
+       pp_kind  = pprPrimKind a_kind
 
        local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 
 
        local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 
@@ -703,9 +868,10 @@ ppr_casm_arg sty amode a_num
                                hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 
              -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
                                hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
 
              -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
-             ForeignObjRep -> (ptext SLIT("StgForeignObj"),
-                               hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(', 
-                                           pp_amode, char ')'])
+             ForeignObjRep -> (pp_kind,
+                               hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
+                                     char '(', pp_amode, char ')'])
+
              other         -> (pp_kind, pp_amode)
 
        declare_local_var
              other         -> (pp_kind, pp_amode)
 
        declare_local_var
@@ -720,58 +886,33 @@ 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}
 \begin{code}
-ppr_casm_results ::
-       PprStyle        -- style
-       -> [CAddrMode]  -- list of results (length <= 1)
-       -> Doc  -- liveness mask
+ppr_casm_results
+       :: [CAddrMode]  -- list of results (length <= 1)
        ->
        ->
-       ( Doc,  -- declaration of any local vars
-         [Doc],        -- list of result vars (same length as results)
-         Doc ) -- 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 sty [] liveness
+ppr_casm_results []
   = (empty, [], empty)         -- no results
 
   = (empty, [], empty)         -- no results
 
-ppr_casm_results sty [r] liveness
+ppr_casm_results [r]
   = let
   = let
-       result_reg = ppr_amode sty r
+       result_reg = ppr_amode r
        r_kind     = getAmodeRep r
 
        local_var  = ptext SLIT("_ccall_result")
 
        (result_type, assign_result)
        r_kind     = getAmodeRep r
 
        local_var  = ptext SLIT("_ccall_result")
 
        (result_type, assign_result)
-         = case r_kind of
-{- 
-   @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
-   Instead, external references have to explicitly turned into ForeignObjs
-   using the primop makeForeignObj#. Benefit: Multiple finalisation
-   routines can be accommodated and the below special case is not needed.
-   Price is, of course, that you have to explicitly wrap `foreign objects'
-   with makeForeignObj#.
-
-             ForeignObjRep ->
-               (ptext SLIT("StgForeignObj"),
-                hcat [ ptext SLIT("constructForeignObj"),char '(',
-                               liveness, comma,
-                               result_reg, comma,
-                               local_var,
-                            pp_paren_semi ]) 
--}
-             _ ->
-               (pprPrimKind sty r_kind,
-                hcat [ result_reg, equals, local_var, semi ])
+         = (pprPrimKind r_kind,
+            hcat [ result_reg, equals, local_var, semi ])
 
        declare_local_var = hcat [ result_type, space, local_var, semi ]
     in
     (declare_local_var, [local_var], assign_result)
 
 
        declare_local_var = hcat [ result_type, space, local_var, semi ]
     in
     (declare_local_var, [local_var], assign_result)
 
-ppr_casm_results sty rs liveness
+ppr_casm_results rs
   = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 
   = panic "ppr_casm_results: ccall/casm with many results"
 \end{code}
 
@@ -783,17 +924,17 @@ ToDo: Any chance of giving line numbers when process-casm fails?
       Or maybe we should do a check _much earlier_ in compiler. ADR
 
 \begin{code}
       Or maybe we should do a check _much earlier_ in compiler. ADR
 
 \begin{code}
-process_casm ::
-       [Doc]           -- results (length <= 1)
-       -> [Doc]                -- arguments
-       -> String               -- format string (with embedded %'s)
-       ->
-       Doc                     -- code being generated
+process_casm :: [SDoc]         -- results (length <= 1)
+            -> [SDoc]          -- arguments
+            -> String          -- format string (with embedded %'s)
+            -> SDoc            -- code being generated
 
 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 PrimIO ()\n")
 
   process ress args ('%':cs)
     = case cs of
 
   process ress args ('%':cs)
     = case cs of
@@ -801,12 +942,12 @@ process_casm results args string = process results args string
            error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 
        ('%':css) ->
            error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
 
        ('%':css) ->
-           (<>) (char '%') (process ress args css)
+           char '%' <> process ress args css
 
        ('r':css)  ->
          case ress of
            []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
 
        ('r':css)  ->
          case ress of
            []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
-           [r] -> (<>) r (process [] args css)
+           [r] -> r <> (process [] args css)
            _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 
        other ->
            _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
 
        other ->
@@ -817,13 +958,12 @@ process_casm results args string = process results args string
          case (read_int other) of
            [(num,css)] ->
                  if 0 <= num && num < length args
          case (read_int other) of
            [(num,css)] ->
                  if 0 <= num && num < length args
-                 then (<>) (parens (args !! num))
-                                (process ress args css)
-                   else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
+                 then parens (args !! num) <> process ress args css
+                 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
            _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 
   process ress args (other_c:cs)
            _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
 
   process ress args (other_c:cs)
-    = (<>) (char other_c) (process ress args cs)
+    = char other_c <> process ress args cs
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -840,19 +980,24 @@ of the source addressing mode.)  If the kind of the assignment is of
 @VoidRep@, then don't generate any code at all.
 
 \begin{code}
 @VoidRep@, then don't generate any code at all.
 
 \begin{code}
-pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
+pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
 
 
-pprAssign sty VoidRep dest src = empty
+pprAssign VoidRep dest src = empty
 \end{code}
 
 Special treatment for floats and doubles, to avoid unwanted conversions.
 
 \begin{code}
 \end{code}
 
 Special treatment for floats and doubles, to avoid unwanted conversions.
 
 \begin{code}
-pprAssign sty FloatRep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
+pprAssign FloatRep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
 
 
-pprAssign sty DoubleRep dest@(CVal reg_rel _) src
-  = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
+pprAssign DoubleRep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+
+pprAssign Int64Rep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+pprAssign Word64Rep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', 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
 \end{code}
 
 Lastly, the question is: will the C compiler think the types of the
@@ -867,34 +1012,34 @@ whereas the A stack, temporaries, registers, etc., are only used for things
 of fixed type.
 
 \begin{code}
 of fixed type.
 
 \begin{code}
-pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
+pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
   = hcat [ pprVanillaReg dest, equals,
                pprVanillaReg src, semi ]
 
   = hcat [ pprVanillaReg dest, equals,
                pprVanillaReg src, semi ]
 
-pprAssign sty kind dest src
+pprAssign kind dest src
   | mixedTypeLocn dest
     -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
   | mixedTypeLocn dest
     -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
-  = hcat [ ppr_amode sty dest, equals,
+  = hcat [ ppr_amode dest, equals,
                text "(W_)(",   -- Here is the cast
                text "(W_)(",   -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
+               ppr_amode src, pp_paren_semi ]
 
 
-pprAssign sty kind dest src
+pprAssign kind dest src
   | mixedPtrLocn dest && getAmodeRep src /= PtrRep
     -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
   | mixedPtrLocn dest && getAmodeRep src /= PtrRep
     -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
-  = hcat [ ppr_amode sty dest, equals,
+  = hcat [ ppr_amode dest, equals,
                text "(P_)(",   -- Here is the cast
                text "(P_)(",   -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
+               ppr_amode src, pp_paren_semi ]
 
 
-pprAssign sty ByteArrayRep dest src
+pprAssign ByteArrayRep dest src
   | mixedPtrLocn src
   | mixedPtrLocn src
-    -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
-  = hcat [ ppr_amode sty dest, equals,
-               text "(B_)(",   -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
-
-pprAssign sty kind other_dest src
-  = hcat [ ppr_amode sty other_dest, equals,
-               pprAmode  sty src, semi ]
+    -- Add in a cast iff the source is mixed
+  = hcat [ ppr_amode dest, equals,
+               text "(StgByteArray)(", -- Here is the cast
+               ppr_amode src, pp_paren_semi ]
+
+pprAssign kind other_dest src
+  = hcat [ ppr_amode other_dest, equals,
+               pprAmode  src, semi ]
 \end{code}
 
 
 \end{code}
 
 
@@ -909,7 +1054,7 @@ pprAssign sty kind other_dest src
 @pprAmode@.
 
 \begin{code}
 @pprAmode@.
 
 \begin{code}
-pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
+pprAmode, ppr_amode :: CAddrMode -> SDoc
 \end{code}
 
 For reasons discussed above under assignments, @CVal@ modes need
 \end{code}
 
 For reasons discussed above under assignments, @CVal@ modes need
@@ -920,82 +1065,85 @@ similar to those in @pprAssign@:
 question.)
 
 \begin{code}
 question.)
 
 \begin{code}
-pprAmode sty (CVal reg_rel FloatRep)
-  = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
-pprAmode sty (CVal reg_rel DoubleRep)
-  = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel FloatRep)
+  = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel DoubleRep)
+  = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel Int64Rep)
+  = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel Word64Rep)
+  = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
 \end{code}
 
 Next comes the case where there is some other cast need, and the
 no-cast case:
 
 \begin{code}
 \end{code}
 
 Next comes the case where there is some other cast need, and the
 no-cast case:
 
 \begin{code}
-pprAmode sty amode
+pprAmode amode
   | mixedTypeLocn amode
   | mixedTypeLocn amode
-  = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
-               ppr_amode sty amode ])
+  = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
+               ppr_amode amode ])
   | otherwise  -- No cast needed
   | otherwise  -- No cast needed
-  = ppr_amode sty amode
+  = ppr_amode amode
 \end{code}
 
 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 
 \begin{code}
 \end{code}
 
 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 
 \begin{code}
-ppr_amode sty (CVal reg_rel _)
-  = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
+ppr_amode (CVal reg_rel _)
+  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
        (pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
        (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
 
        (pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
        (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
 
-ppr_amode sty (CAddr reg_rel)
-  = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
+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, Nothing)     -> pp_reg
        (pp_reg, Just offset) -> (<>) pp_reg offset
 
-ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
-
-ppr_amode sty (CTemp uniq kind) = pprUnique uniq <> char '_'
+ppr_amode (CReg magic_id) = pprMagicId magic_id
 
 
-ppr_amode sty (CLbl label kind) = pprCLabel sty label
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
 
 
-ppr_amode sty (CUnVecLbl direct vectored)
-  = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
-              pprCLabel sty vectored, rparen]
+ppr_amode (CLbl label kind) = pprCLabelAddr label
 
 
-ppr_amode sty (CCharLike ch)
-  = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
-ppr_amode sty (CIntLike int)
-  = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty 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 sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
+ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
   -- ToDo: are these *used* for anything?
 
   -- ToDo: are these *used* for anything?
 
-ppr_amode sty (CLit lit) = pprBasicLit sty lit
+ppr_amode (CLit lit) = pprBasicLit lit
 
 
-ppr_amode sty (CLitLit str _) = ptext str
+ppr_amode (CLitLit str _) = ptext str
 
 
-ppr_amode sty (COffset off) = pprHeapOffset sty off
-
-ppr_amode sty (CCode abs_C)
-  = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
-
-ppr_amode sty (CLabelledCode label abs_C)
-  = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
-              nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
-
-ppr_amode sty (CJoinPoint _ _)
+ppr_amode (CJoinPoint _)
   = panic "ppr_amode: CJoinPoint"
 
   = panic "ppr_amode: CJoinPoint"
 
-ppr_amode sty (CTableEntry base index kind)
-  = hcat [text "((", pprPrimKind sty kind, text " *)(",
-              ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
+ppr_amode (CTableEntry base index kind)
+  = hcat [text "((", pprPrimKind kind, text " *)(",
+              ppr_amode base, text "))[(I_)(", ppr_amode index,
               ptext SLIT(")]")]
 
               ptext SLIT(")]")]
 
-ppr_amode sty (CMacroExpr pk macro as)
-  = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
-              hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
+ppr_amode (CMacroExpr pk macro as)
+  = parens (pprPrimKind pk) <+> 
+    parens (text (show macro) <> 
+           parens (hcat (punctuate comma (map pprAmode as))))
+\end{code}
 
 
-ppr_amode sty (CCostCentre cc print_as_string)
-  = uppCostCentre sty print_as_string cc
+%************************************************************************
+%*                                                                     *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+pp_liveness :: Liveness -> SDoc
+pp_liveness lv = 
+   case lv of
+       LvSmall mask -> int (intBS mask)
+       LvLarge lbl  -> char '&' <> pprCLabel lbl
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -1009,45 +1157,38 @@ ppr_amode sty (CCostCentre cc print_as_string)
 (zero offset gives a @Nothing@).
 
 \begin{code}
 (zero offset gives a @Nothing@).
 
 \begin{code}
-addPlusSign :: Bool -> Doc -> Doc
+addPlusSign :: Bool -> SDoc -> SDoc
 addPlusSign False p = p
 addPlusSign True  p = (<>) (char '+') p
 
 addPlusSign False p = p
 addPlusSign True  p = (<>) (char '+') p
 
-pprSignedInt :: Bool -> Int -> Maybe Doc       -- Nothing => 0
+pprSignedInt :: Bool -> Int -> Maybe SDoc      -- Nothing => 0
 pprSignedInt sign_wanted n
  = if n == 0 then Nothing else
    if n > 0  then Just (addPlusSign sign_wanted (int n))
    else          Just (int n)
 
 pprSignedInt sign_wanted n
  = if n == 0 then Nothing else
    if n > 0  then Just (addPlusSign sign_wanted (int n))
    else          Just (int n)
 
-pprRegRelative :: PprStyle
-              -> Bool          -- True <=> Print leading plus sign (if +ve)
+pprRegRelative :: Bool         -- True <=> Print leading plus sign (if +ve)
               -> RegRelative
               -> RegRelative
-              -> (Doc, Maybe Doc)
-
-pprRegRelative sty sign_wanted (SpARel spA off)
-  = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
+              -> (SDoc, Maybe SDoc)
 
 
-pprRegRelative sty sign_wanted (SpBRel spB off)
-  = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
+pprRegRelative sign_wanted (SpRel off)
+  = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
 
 
-pprRegRelative sty sign_wanted r@(HpRel hp off)
-  = let to_print = hp `subOff` off
-       pp_Hp    = pprMagicId sty 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 sty to_print)))
-                               -- No parens needed because pprHeapOffset
-                               -- does them when necessary
+       (pp_Hp, Just ((<>) (char '-') (int off)))
 
 
-pprRegRelative sty sign_wanted (NodeRel off)
-  = let pp_Node = pprMagicId sty 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 sty off)))
+       (pp_Node, Just (addPlusSign sign_wanted (int off)))
 
 \end{code}
 
 
 \end{code}
 
@@ -1056,51 +1197,47 @@ represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
 to select the union tag.
 
 \begin{code}
 to select the union tag.
 
 \begin{code}
-pprMagicId :: PprStyle -> MagicId -> Doc
+pprMagicId :: MagicId -> SDoc
 
 
-pprMagicId sty BaseReg             = ptext SLIT("BaseReg")
-pprMagicId sty StkOReg             = ptext SLIT("StkOReg")
-pprMagicId sty (VanillaReg pk n)
+pprMagicId BaseReg                 = ptext SLIT("BaseReg")
+pprMagicId (VanillaReg pk n)
                                    = hcat [ pprVanillaReg n, char '.',
                                                  pprUnionTag pk ]
                                    = hcat [ pprVanillaReg n, char '.',
                                                  pprUnionTag pk ]
-pprMagicId sty (FloatReg  n)        = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
-pprMagicId sty (DoubleReg n)       = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
-pprMagicId sty TagReg              = ptext SLIT("TagReg")
-pprMagicId sty RetReg              = ptext SLIT("RetReg")
-pprMagicId sty SpA                 = ptext SLIT("SpA")
-pprMagicId sty SuA                 = ptext SLIT("SuA")
-pprMagicId sty SpB                 = ptext SLIT("SpB")
-pprMagicId sty SuB                 = ptext SLIT("SuB")
-pprMagicId sty Hp                  = ptext SLIT("Hp")
-pprMagicId sty HpLim               = ptext SLIT("HpLim")
-pprMagicId sty LivenessReg         = ptext SLIT("LivenessReg")
-pprMagicId sty StdUpdRetVecReg      = ptext SLIT("StdUpdRetVecReg")
-pprMagicId sty StkStubReg          = ptext SLIT("StkStubReg")
-pprMagicId sty CurCostCentre       = ptext SLIT("CCC")
-pprMagicId sty VoidReg             = panic "pprMagicId:VoidReg!"
-
-pprVanillaReg :: FAST_INT -> Doc
-
+pprMagicId (FloatReg  n)            = (<>) (ptext SLIT("F")) (int IBOX(n))
+pprMagicId (DoubleReg n)           = (<>) (ptext SLIT("D")) (int IBOX(n))
+pprMagicId (LongReg _ n)           = (<>) (ptext SLIT("L")) (int IBOX(n))
+pprMagicId Sp                      = ptext SLIT("Sp")
+pprMagicId Su                      = ptext SLIT("Su")
+pprMagicId SpLim                   = ptext SLIT("SpLim")
+pprMagicId Hp                      = ptext SLIT("Hp")
+pprMagicId HpLim                   = ptext SLIT("HpLim")
+pprMagicId CurCostCentre           = ptext SLIT("CCCS")
+pprMagicId VoidReg                 = panic "pprMagicId:VoidReg!"
+
+pprVanillaReg :: FAST_INT -> SDoc
 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
 
 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
 
-pprUnionTag :: PrimRep -> Doc
+pprUnionTag :: PrimRep -> SDoc
 
 pprUnionTag PtrRep             = char 'p'
 pprUnionTag CodePtrRep         = ptext SLIT("fp")
 pprUnionTag DataPtrRep         = char 'd'
 
 pprUnionTag PtrRep             = char 'p'
 pprUnionTag CodePtrRep         = ptext SLIT("fp")
 pprUnionTag DataPtrRep         = char 'd'
-pprUnionTag RetRep             = char 'r'
+pprUnionTag RetRep             = char 'p'
 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
-pprUnionTag AddrRep            = char 'v'
+pprUnionTag AddrRep            = char 'a'
 pprUnionTag FloatRep           = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag StablePtrRep       = char 'i'
 pprUnionTag FloatRep           = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag StablePtrRep       = char 'i'
+pprUnionTag WeakPtrRep         = char 'p'
 pprUnionTag ForeignObjRep      = char 'p'
 
 pprUnionTag ForeignObjRep      = char 'p'
 
+pprUnionTag ThreadIdRep                = char 't'
+
 pprUnionTag ArrayRep           = char 'p'
 pprUnionTag ByteArrayRep       = char 'b'
 
 pprUnionTag ArrayRep           = char 'p'
 pprUnionTag ByteArrayRep       = char 'b'
 
@@ -1111,7 +1248,7 @@ pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 Find and print local and external declarations for a list of
 Abstract~C statements.
 \begin{code}
 Find and print local and external declarations for a list of
 Abstract~C statements.
 \begin{code}
-pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
+pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls AbsCNop = (empty, empty)
 
 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
 pprTempAndExternDecls AbsCNop = (empty, empty)
 
 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
@@ -1134,11 +1271,11 @@ pprTempAndExternDecls other_stmt
                  Just pp -> pp )
           )
 
                  Just pp -> pp )
           )
 
-pprBasicLit :: PprStyle -> Literal -> Doc
-pprPrimKind :: PprStyle -> PrimRep -> Doc
+pprBasicLit :: Literal -> SDoc
+pprPrimKind :: PrimRep -> SDoc
 
 
-pprBasicLit  sty lit = text (showLiteral  sty lit)
-pprPrimKind  sty k   = text (showPrimRep k)
+pprBasicLit  lit = ppr lit
+pprPrimKind  k   = ppr k
 \end{code}
 
 
 \end{code}
 
 
@@ -1160,6 +1297,7 @@ type CLabelSet = FiniteMap CLabel (){-any type will do-}
 emptyCLabelSet = emptyFM
 x `elementOfCLabelSet` labs
   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
 emptyCLabelSet = emptyFM
 x `elementOfCLabelSet` labs
   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
+
 addToCLabelSet set x = addToFM set x ()
 
 type TEenv = (UniqSet Unique, CLabelSet)
 addToCLabelSet set x = addToFM set x ()
 
 type TEenv = (UniqSet Unique, CLabelSet)
@@ -1211,28 +1349,22 @@ labelSeenTE label env@(seen_uniqs, seen_labels)
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-pprTempDecl :: Unique -> PrimRep -> Doc
+pprTempDecl :: Unique -> PrimRep -> SDoc
 pprTempDecl uniq kind
 pprTempDecl uniq kind
-  = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, ptext SLIT("_;") ]
+  = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
 
 
-pprExternDecl :: CLabel -> PrimRep -> Doc
+pprExternDecl :: CLabel -> PrimRep -> SDoc
 
 pprExternDecl clabel kind
   = if not (needsCDecl clabel) then
 
 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 [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
-       }
+       empty -- do not print anything for "known external" things
+    else 
+       hcat [ ppLocalnessMacro clabel, 
+              lparen, pprCLabel clabel, pp_paren_semi ]
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
+ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
 
 ppr_decls_AbsC AbsCNop         = returnTE (Nothing, Nothing)
 
 
 ppr_decls_AbsC AbsCNop         = returnTE (Nothing, Nothing)
 
@@ -1241,9 +1373,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)
@@ -1268,7 +1397,7 @@ ppr_decls_AbsC (CSwitch discrim alts deflt)
 ppr_decls_AbsC (CCodeBlock label absC)
   = ppr_decls_AbsC absC
 
 ppr_decls_AbsC (CCodeBlock label 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,
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = labelSeenTE info_lbl     `thenTE` \  label_seen ->
     returnTE (Nothing,
@@ -1279,9 +1408,14 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
   where
     info_lbl = infoTableLabelFromCI cl_info
 
   where
     info_lbl = infoTableLabelFromCI cl_info
 
-ppr_decls_AbsC (COpStmt        results _ args _ _) = ppr_decls_Amodes (results ++ args)
+ppr_decls_AbsC (COpStmt        results _ args _) = ppr_decls_Amodes (results ++ args)
 ppr_decls_AbsC (CSimultaneous abc)         = ppr_decls_AbsC abc
 
 ppr_decls_AbsC (CSimultaneous abc)         = ppr_decls_AbsC abc
 
+ppr_decls_AbsC (CCheck             _ amodes code) = 
+     ppr_decls_Amodes amodes `thenTE` \p1 ->
+     ppr_decls_AbsC code     `thenTE` \p2 ->
+     returnTE (maybe_vcat [p1,p2])
+
 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)  = ppr_decls_Amodes [] -- *****!!!
 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
 ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)  = ppr_decls_Amodes [] -- *****!!!
@@ -1294,8 +1428,8 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 
-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
-  = ppr_decls_Amodes [entry_lbl, upd_lbl]      `thenTE` \ p1 ->
+ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
+  = ppr_decls_Amodes [entry_lbl]               `thenTE` \ p1 ->
     ppr_decls_AbsC slow                                `thenTE` \ p2 ->
     (case maybe_fast of
        Nothing   -> returnTE (Nothing, Nothing)
     ppr_decls_AbsC slow                                `thenTE` \ p2 ->
     (case maybe_fast of
        Nothing   -> returnTE (Nothing, Nothing)
@@ -1307,24 +1441,25 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
                    Nothing -> mkErrorStdEntryLabel
                    Just _  -> entryLabelFromCI cl_info
 
                    Nothing -> mkErrorStdEntryLabel
                    Just _  -> entryLabelFromCI cl_info
 
-ppr_decls_AbsC (CRetVector label maybe_amodes absC)
-  = ppr_decls_Amodes (catMaybes maybe_amodes)  `thenTE` \ p1 ->
-    ppr_decls_AbsC   absC                      `thenTE` \ p2 ->
-    returnTE (maybe_vcat [p1, p2])
+ppr_decls_AbsC (CSRT lbl closure_lbls)
+  = mapTE labelSeenTE closure_lbls             `thenTE` \ seen ->
+    returnTE (Nothing, 
+             if and seen then Nothing
+               else Just (vcat [ pprExternDecl l PtrRep
+                               | (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
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
+ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
 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 (CLitLit _ _)  = 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 (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)
@@ -1350,35 +1485,6 @@ ppr_decls_Amode (CLbl label kind)
     returnTE (Nothing,
              if label_seen then Nothing else Just (pprExternDecl label kind))
 
     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 ->
 ppr_decls_Amode (CTableEntry base index _)
   = ppr_decls_Amode base    `thenTE` \ p1 ->
     ppr_decls_Amode index   `thenTE` \ p2 ->
@@ -1390,7 +1496,7 @@ ppr_decls_Amode (CMacroExpr _ _ amodes)
 ppr_decls_Amode other = returnTE (Nothing, Nothing)
 
 
 ppr_decls_Amode other = returnTE (Nothing, Nothing)
 
 
-maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
+maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
 maybe_vcat ps
   = case (unzip ps)    of { (ts, es) ->
     case (catMaybes ts)        of { real_ts  ->
 maybe_vcat ps
   = case (unzip ps)    of { (ts, es) ->
     case (catMaybes ts)        of { real_ts  ->
@@ -1401,8 +1507,69 @@ maybe_vcat ps
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
+ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
 ppr_decls_Amodes amodes
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
     returnTE ( maybe_vcat ps )
 \end{code}
 ppr_decls_Amodes amodes
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
     returnTE ( maybe_vcat ps )
 \end{code}
+
+Print out a C Label where you want the *address* of the label, not the
+object it refers to.  The distinction is important when the label may
+refer to a C structure (info tables and closures, for instance).
+
+When just generating a declaration for the label, use pprCLabel.
+
+\begin{code}
+pprCLabelAddr :: CLabel -> SDoc
+pprCLabelAddr clabel =
+  case labelType clabel of
+     InfoTblType -> addr_of_label
+     ClosureType -> addr_of_label
+     VecTblType  -> addr_of_label
+     _           -> pp_label
+  where
+    addr_of_label = ptext SLIT("(P_)&") <> pp_label
+    pp_label = pprCLabel clabel
+\end{code}
+
+-----------------------------------------------------------------------------
+Initialising static objects with floating-point numbers.  We can't
+just emit the floating point number, because C will cast it to an int
+by rounding it.  We want the actual bit-representation of the float.
+
+This is a hack to turn the floating point numbers into ints that we
+can safely initialise to static locations.
+
+\begin{code}
+big_doubles = (getPrimRepSize DoubleRep) /= 1
+
+-- floatss are always 1 word
+floatToWord :: CAddrMode -> CAddrMode
+floatToWord (CLit (MachFloat r))
+  = runST (do
+       arr <- newFloatArray (0,0)
+       writeFloatArray arr 0 (fromRational r)
+       i <- readIntArray arr 0
+       return (CLit (MachInt (toInteger i) True))
+    )
+
+doubleToWords :: CAddrMode -> [CAddrMode]
+doubleToWords (CLit (MachDouble r))
+  | big_doubles                                -- doubles are 2 words
+  = runST (do
+       arr <- newDoubleArray (0,1)
+       writeDoubleArray arr 0 (fromRational r)
+       i1 <- readIntArray arr 0
+       i2 <- readIntArray arr 1
+       return [ CLit (MachInt (toInteger i1) True)
+              , CLit (MachInt (toInteger i2) True)
+              ]
+    )
+  | otherwise                          -- doubles are 1 word
+  = runST (do
+       arr <- newDoubleArray (0,0)
+       writeDoubleArray arr 0 (fromRational r)
+       i <- readIntArray arr 0
+       return [ CLit (MachInt (toInteger i) True) ]
+    )
+\end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)