[project @ 2004-08-13 10:45:16 by simonmar]

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

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 18053a7..76b1f43 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,50 +8,67 @@
 %************************************************************************
 
 \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
 

-import Ubiq{-uitous-}
-import AbsCLoop                -- break its dependence on ClosureInfo
+#include "HsVersions.h"

 
 

-import AbsCSyn
+import IO      ( Handle )

 
 

+import PrimRep 
+import AbsCSyn
+import ClosureInfo

 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )
 import AbsCUtils       ( getAmodeRep, nonemptyAbsC,
                          mixedPtrLocn, mixedTypeLocn
                        )

-import CgCompInfo      ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
-import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
-                         isReadOnly, needsCDecl, pprCLabel,
-                         CLabel{-instance Ord-}
+
+import ForeignCall     ( CCallSpec(..), CCallTarget(..), playSafe,
+                         playThreadSafe, ccallConvAttribute,
+                         ForeignCall(..), DNCallSpec(..),
+                         DNType(..), DNKind(..) )
+import CLabel          ( externallyVisibleCLabel,
+                         needsCDecl, pprCLabel, mkClosureLabel,
+                         mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+                         CLabel, CLabelType(..), labelType, labelDynamic

                        )
                        )

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

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

-import CStrings                ( stringToC )
-import FiniteMap       ( addToFM, emptyFM, lookupFM )
-import HeapOffs                ( isZeroOff, subOff, pprHeapOffset )
-import Literal         ( showLiteral, Literal(..) )
-import Maybes          ( maybeToBool, catMaybes )
-import PprStyle                ( PprStyle(..) )
-import Pretty          ( prettyToUn )
-import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep         ( isFloatingRep, showPrimRep, PrimRep(..) )
-import SMRep           ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
-                         isConstantRep, isSpecRep, isPhantomRep
-                       )
+import CStrings                ( pprCLabelString )
+import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
+import Literal         ( Literal(..) )
+import TyCon           ( tyConDataCons )
+import Name            ( NamedThing(..) )
+import Maybes          ( catMaybes )
+import PrimOp          ( primOpNeedsWrapper )
+import MachOp          ( MachOp(..) )
+import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize )

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

-                         addOneToUniqSet, UniqSet(..)
+                         addOneToUniqSet, UniqSet

                        )
                        )

-import Unpretty                -- ********** NOTE **********
-import Util            ( nOfThem, panic, assertPanic )
+import StgSyn          ( StgOp(..) )
+import Outputable
+import FastString
+import Util            ( lengthExceeds )
+
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+
+#ifdef DEBUG
+import Util            ( listLengthCmp )
+#endif
+
+import Maybe           ( isJust )
+import GLAEXTS
+import MONAD_ST

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

@@ -62,75 +79,87 @@ 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 :: _FILE -> AbstractC -> IO ()
+{-
+writeRealC :: Handle -> AbstractC -> IO ()
+writeRealC handle absC
+     -- avoid holding on to the whole of absC in the !Gransim case.
+     if opt_GranMacros
+       then printForCFast fp (pprAbsC absC (costs absC))
+       else printForCFast fp (pprAbsC absC (panic "costs"))
+            --printForC handle (pprAbsC absC (panic "costs"))
+dumpRealC :: AbstractC -> SDoc
+dumpRealC absC = pprAbsC absC (costs absC)
+-}

 
 

-writeRealC file absC
-  = uppAppendFile file 80 (
-      uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
-    )
+writeRealC :: Handle -> AbstractC -> IO ()
+--writeRealC handle absC = 
+-- _scc_ "writeRealC" 
+-- printDoc LeftMode handle (pprAbsC absC (costs absC))

 
 

-dumpRealC :: AbstractC -> String
+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
 dumpRealC absC

-  = uppShow 80 (
-      uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
-    )
+ | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
+ | otherwise     = pprCode CStyle (pprAbsC absC (panic "costs"))
+

 \end{code}
 
 This emits the macro,  which is used in GrAnSim  to compute the total costs
 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 -> Unpretty
+emitMacro :: CostRes -> SDoc

 
 

--- ToDo: Check a compile time flag to decide whether a macro should be emitted
-emitMacro (Cost (i,b,l,s,f))
-  = uppBesides [ uppStr "GRAN_EXEC(",
-                          uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
-                         uppInt s, uppComma, uppInt f, pp_paren_semi ]
-\end{code}
-
-\begin{code}
-pp_paren_semi = uppStr ");"
+emitMacro _ | not opt_GranMacros = empty

 
 

--- ---------------------------------------------------------------------------
--- 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
--- ---------------------------------------------------------------------------
+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 ]

 
 

-pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
+pp_paren_semi = text ");"
+\end{code}

 
 

-pprAbsC sty AbsCNop _ = uppNil
-pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (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
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CJump */"-} ])
-            (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+pprAbsC (CJump target) c
+  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
+            (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])

 
 

-pprAbsC sty (CFallThrough target) c
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++  CFallThrough */"-} ])
-            (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+pprAbsC (CFallThrough target) c
+  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
+            (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
-  = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <----  CReturn */"-} ])
-            (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
+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
   where
    target = case return_info of

-       DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
-       DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
-       StaticVectoredReturn n -> mk_vector (uppInt n)  -- Always positive
-   mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
+       DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
+                             pprAmode am, rparen]
+       DynamicVectoredReturn am' -> mk_vector (pprAmode am')
+       StaticVectoredReturn n -> mk_vector (int n)     -- Always positive
+   mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
+                      x, rparen ]

 
 

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

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

@@ -142,60 +171,61 @@ pprAbsC sty (CSplitMarker) _ = uppPStr 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),
-                             (tag2@(MachInt i2 _), alt_code2)] deflt) c
+-- What problem is the re-ordering trying to solve ?
+pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
+                         (tag2@(MachInt i2), alt_code2)] deflt) c

   | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
   = if (i1 == 0) then
   | 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
   where

-    empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
+    empty_deflt = not (isJust (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
   | otherwise

-    = uppAboves [
-       uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
-       uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
+    = vcat [
+       hcat [text "switch (", pp_discrim, text ") {"],
+       nest 2 (vcat (map ppr_alt alts)),

        (case (nonemptyAbsC deflt) of
        (case (nonemptyAbsC deflt) of

-          Nothing -> uppNil
+          Nothing -> empty

           Just dc ->
           Just dc ->

-           uppNest 2 (uppAboves [uppPStr SLIT("default:"),
-                                 pprAbsC sty dc (c + switch_head_cost
+           nest 2 (vcat [ptext SLIT("default:"),
+                                 pprAbsC dc (c + switch_head_cost

                                                    + costs dc),
                                                    + costs dc),

-                                 uppPStr SLIT("break;")])),
-       uppChar '}' ]
+                                 ptext SLIT("break;")])),
+       char '}' ]

   where
     pp_discrim
   where
     pp_discrim

-      = pprAmode sty discrim
+      = pprAmode discrim

 
 

-    ppr_alt sty (lit, absC)
-      = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
-                  uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
-                                      (uppPStr SLIT("break;"))) ]
+    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))
 
 
     -- 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 (StgFCallOp fcall uniq) args vol_regs) _
+  = pprFCall fcall uniq args results vol_regs

 
 

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

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

@@ -207,247 +237,452 @@ 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) ->

     if primOpNeedsWrapper op then
     if primOpNeedsWrapper op then

-       uppAboves [  pp_saves,
-                   the_op,
-                   pp_restores
-                ]
+       case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
+       vcat [  pp_saves,
+               the_op,
+               pp_restores
+            ]
+       }

     else
        the_op
     else
        the_op

-    }

   where
     ppr_op_call results args
   where
     ppr_op_call results args

-      = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
-       uppIntersperse uppComma (map ppr_op_result results),
-       if null results || null args then uppNil else uppComma,
-       uppIntersperse uppComma (map (pprAmode sty) args),
+      = hcat [ ppr op, lparen,
+       hcat (punctuate comma (map ppr_op_result results)),
+       if null results || null args then empty else comma,
+       hcat (punctuate comma (map pprAmode args)),

        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
-  = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"]
-
-pprAbsC sty stmt@(CMacroStmt macro as) _
-  = uppBesides [uppStr (show macro), uppLparen,
-       uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
-pprAbsC sty stmt@(CCallProfCtrMacro op as) _
-  = uppBesides [uppPStr op, uppLparen,
-       uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
-pprAbsC sty stmt@(CCallProfCCMacro op as) _
-  = uppBesides [uppPStr op, uppLparen,
-       uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
-
-pprAbsC sty (CCodeBlock label abs_C) _
-  = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
-    case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
-    uppAboves [
-       uppBesides [uppStr (if (externallyVisibleCLabel label)
-                         then "FN_("   -- abbreviations to save on output
-                         else "IFN_("),
-                  pprCLabel sty label, uppStr ") {"],
-       case sty of
-         PprForC -> uppAbove pp_exts pp_temps
-         _ -> uppNil,
-       uppNest 8 (uppPStr SLIT("FB_")),
-       uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
-       uppNest 8 (uppPStr SLIT("FE_")),
-       uppChar '}' ]
+-- NEW CASES FOR EXPANDED PRIMOPS
+
+pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
+  = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
+    in
+    case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+    saves $$
+    hcat (
+       [ppr_amode res, equals]
+       ++ (if prefix_fn 
+           then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
+           else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
+       ++ [semi]
+    )
+    $$ restores

     }
 
     }
 

-pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
-  = uppBesides [ pp_init_hdr, uppStr "_HDR(",
-               ppr_amode sty (CAddr reg_rel), uppComma,
-               pprCLabel sty info_lbl, uppComma,
-               if_profiling sty (pprAmode sty cost_centre), uppComma,
-               pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
-  where
-    info_lbl   = infoTableLabelFromCI cl_info
-    sm_rep     = closureSMRep     cl_info
-    size       = closureSizeWithoutFixedHdr cl_info
-    ptr_wds    = closurePtrsSize  cl_info
+pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
+  = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+    saves $$
+    hcat [ppr_amode res, equals, 
+          pprMachOp_for_C mop, parens (pprAmode arg1),
+          semi]
+    $$ restores
+    }

 
 

-    pp_init_hdr = uppStr (if inplace_upd then
-                           getSMUpdInplaceHdrStr sm_rep
-                       else
-                           getSMInitHdrStr sm_rep)
+pprAbsC stmt@(CSequential stuff) c
+  = vcat (map (flip pprAbsC c) stuff)

 
 

-pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
+-- end of NEW CASES FOR EXPANDED PRIMOPS
+
+pprAbsC stmt@(CSRT lbl closures) c

   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
   = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->

-    uppAboves [
-       case sty of
-         PprForC -> pp_exts
-         _ -> uppNil,
-       uppBesides [
-               uppStr "SET_STATIC_HDR(",
-               pprCLabel sty closure_lbl,                      uppComma,
-               pprCLabel sty info_lbl,                         uppComma,
-               if_profiling sty (pprAmode sty cost_centre),    uppComma,
-               ppLocalness closure_lbl,                        uppComma,
-               ppLocalnessMacro False{-for data-} info_lbl,
-               uppChar ')'
-               ],
-       uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
-       uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
-       uppStr "};" ]
-    }
-  where
-    info_lbl = infoTableLabelFromCI cl_info
+         pp_exts
+      $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
+      $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
+         <> ptext SLIT("};")
+  }
+
+pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
+  = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)
+
+pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
+  = pprWordArray desc_lbl (
+       CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
+       mkWordCLit (fromIntegral len) :
+       bitmapAddrModes bitmap
+     )
+
+pprAbsC (CSimultaneous abs_c) c
+  = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
+
+pprAbsC (CCheck macro as code) c
+  = hcat [ptext (cCheckMacroText macro), lparen,
+       hcat (punctuate comma (map ppr_amode as)), comma,
+       pprAbsC code c, pp_paren_semi
+    ]
+pprAbsC (CMacroStmt macro as) _
+  = hcat [ptext (cStmtMacroText macro), lparen,
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
+pprAbsC (CCallProfCtrMacro op as) _
+  = hcat [ftext op, lparen,
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC (CCallProfCCMacro op as) _
+  = hcat [ftext op, lparen,
+       hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
+  =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
+         , ccall_res_ty
+         , fun_nm
+         , parens (hsep (punctuate comma ccall_decl_ty_args))
+         ] <> semi
+    where
+    {-
+      In the non-casm case, to ensure that we're entering the given external
+      entry point using the correct calling convention, we have to do the following:
+
+       - When entering via a function pointer (the `dynamic' case) using the specified
+         calling convention, we emit a typedefn declaration attributed with the
+         calling convention to use together with the result and parameter types we're
+         assuming. Coerce the function pointer to this type and go.
+
+        - to enter the function at a given code label, we emit an extern declaration
+         for the label here, stating the calling convention together with result and
+          argument types we're assuming. 
+
+          The C compiler will hopefully use this extern declaration to good effect,
+          reporting any discrepancies between our extern decl and any other that
+         may be in scope.
+    
+         Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
+         the external function `foo' use the calling convention of the first `foo'
+         prototype it encounters (nor does it complain about conflicting attribute
+         declarations). The consequence of this is that you cannot override the
+         calling convention of `foo' using an extern declaration (you'd have to use
+         a typedef), but why you would want to do such a thing in the first place
+         is totally beyond me.
+         
+         ToDo: petition the gcc folks to add code to warn about conflicting attribute
+         declarations.

 
 

-    ppr_item sty item
-      = if getAmodeRep item == VoidRep
-       then uppStr ", (W_) 0" -- might not even need this...
-       else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
+    -}

 
 

-    padding_wds =
-       if not (closureUpdReqd cl_info) then
-           []
-       else
-           case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
-           nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
+     fun_nm
+       | is_tdef   = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+       | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty

 
 

-{-
-   STATIC_INIT_HDR(c,i,localness) blows into:
-       localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
+     ccall_fun_ty = 
+        case op_str of
+         DynamicTarget  -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
+         StaticTarget x -> pprCLabelString x

 
 

-   then *NO VarHdr STUFF FOR STATIC*...
+     ccall_res_ty = 
+       case non_void_results of
+          []       -> ptext SLIT("void")
+         [amode]  -> ppr (getAmodeRep amode)
+         _        -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"

 
 

-   then the amodes are dropped in...
-       ,a1 ,a2 ... ,aN
-   then a close brace:
-       };
--}
+     ccall_decl_ty_args 
+       | is_tdef   = tail ccall_arg_tys
+       | otherwise = ccall_arg_tys

 
 

-pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
-  = uppAboves [
-       uppBesides [
-           pp_info_rep,
-           uppStr "_ITBL(",
-           pprCLabel sty info_lbl,                     uppComma,
-
-               -- CONST_ITBL needs an extra label for
-               -- the static version of the object.
-           if isConstantRep sm_rep
-           then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
-           else uppNil,
-
-           pprCLabel sty slow_lbl,     uppComma,
-           pprAmode sty upd,           uppComma,
-           uppInt liveness,            uppComma,
-
-           pp_tag,                     uppComma,
-           pp_size,                    uppComma,
-           pp_ptr_wds,                 uppComma,
-
-           ppLocalness info_lbl,                               uppComma,
-           ppLocalnessMacro True{-function-} slow_lbl,         uppComma,
-
-           if is_selector
-           then uppBeside (uppInt select_word_i) uppComma
-           else uppNil,
-
-           if_profiling sty pp_kind, uppComma,
-           if_profiling sty pp_descr, uppComma,
-           if_profiling sty pp_type,
-           uppStr ");"
-       ],
-       pp_slow,
-       case maybe_fast of
-           Nothing -> uppNil
-           Just fast -> let stuff = CCodeBlock fast_lbl fast in
-                        pprAbsC sty stuff (costs stuff)
-    ]
-  where
-    info_lbl   = infoTableLabelFromCI cl_info
-    fast_lbl    = fastLabelFromCI cl_info
-    sm_rep     = closureSMRep    cl_info
+     ccall_arg_tys      = map (ppr . getAmodeRep) non_void_args

 
 

-    (slow_lbl, pp_slow)
-      = case (nonemptyAbsC slow) of
-         Nothing -> (mkErrorStdEntryLabel, uppNil)
-         Just xx -> (entryLabelFromCI cl_info,
-                      let stuff = CCodeBlock slow_lbl xx in
-                      pprAbsC sty stuff (costs stuff))
+      -- the first argument will be the "I/O world" token (a VoidRep)
+      -- all others should be non-void
+     non_void_args =
+       let nvas = init args
+       in ASSERT (all non_void nvas) nvas

 
 

-    maybe_selector = maybeSelectorInfo cl_info
-    is_selector = maybeToBool maybe_selector
-    (Just (_, select_word_i)) = maybe_selector
+      -- there will usually be two results: a (void) state which we
+      -- should ignore and a (possibly void) result.
+     non_void_results =
+       let nvrs = grab_non_void_amodes results
+       in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs

 
 

-    pp_info_rep            -- special stuff if it's a selector; otherwise, just the SMrep
-      = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
+pprAbsC (CCodeBlock lbl abs_C) _
+  = if not (isJust(nonemptyAbsC abs_C)) then
+       pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
+    else
+    case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
+    vcat [
+        empty,
+       pp_exts, 
+       hcat [text (if (externallyVisibleCLabel lbl)
+                         then "FN_("   -- abbreviations to save on output
+                         else "IF_("),
+                  pprCLabel lbl, text ") {"],

 
 

-    pp_tag = uppInt (closureSemiTag cl_info)
+       pp_temps,

 
 

-    is_phantom = isPhantomRep sm_rep
+       nest 8 (ptext SLIT("FB_")),
+       nest 8 (pprAbsC abs_C (costs abs_C)),
+       nest 8 (ptext SLIT("FE_")),
+       char '}',
+        char ' ' ]
+    }

 
 

-    pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
-                uppInt (closureNonHdrSize cl_info)

 
 

-             else if is_phantom then   -- do not have sizes for these
-                uppNil
-             else
-                pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
-
-    pp_ptr_wds = if is_phantom then
-                    uppNil
-                 else
-                    uppInt (closurePtrsSize cl_info)
-
-    pp_kind  = uppStr (closureKind cl_info)
-    pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
-    pp_type  = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
-
-pprAbsC sty (CRetVector lbl maybes deflt) c
-  = uppAboves [ uppStr "{ // CRetVector (lbl????)",
-              uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
-              uppStr "} /*default=*/ {", pprAbsC sty deflt c,
-              uppStr "}"]
+pprAbsC (CInitHdr cl_info amode cost_centre size) _
+  = hcat [ ptext SLIT("SET_HDR_"), char '(',
+               ppr_amode amode, comma,
+               pprCLabelAddr info_lbl, comma,
+               if_profiling (pprAmode cost_centre), comma,
+               if_profiling (int size),
+               pp_paren_semi ]

   where
   where

-    ppr_maybe_amode sty Nothing  = uppPStr SLIT("/*default*/")
-    ppr_maybe_amode sty (Just a) = pprAmode sty a
+    info_lbl   = infoTableLabelFromCI cl_info
+

 
 

-pprAbsC sty stmt@(CRetUnVector label amode) _
-  = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma,
-           pprAmode sty amode, uppRparen]
+pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
+  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+    vcat [
+       pp_exts,
+       hcat [
+               ptext SLIT("SET_STATIC_HDR"), char '(',
+               pprCLabel closure_lbl,                          comma,
+               pprCLabel info_lbl,                             comma,
+               if_profiling (pprAmode cost_centre),            comma,
+               ppLocalness closure_lbl,                        comma,
+               ppLocalnessMacro True{-include dyn-} info_lbl,
+               char ')'
+               ],
+       nest 2 (ppr_payload amodes),
+       ptext SLIT("};") ]
+    }

   where
   where

-    pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
-
-pprAbsC sty stmt@(CFlatRetVector label amodes) _
-  =    case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
-       uppAboves [
-           case sty of
-             PprForC -> pp_exts
-             _ -> uppNil,
-           uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
-                      pprCLabel sty label, uppStr "[] = {"],
-           uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
-           uppStr "};" ] }
+    info_lbl    = infoTableLabelFromCI cl_info
+
+    ppr_payload [] = empty
+    ppr_payload ls = 
+       comma <+> 
+         (braces $ hsep $ punctuate comma $
+          map (text "(L_)" <>) (foldr ppr_item [] ls))
+
+    ppr_item item rest
+      | rep == VoidRep   = rest
+      | rep == FloatRep  = ppr_amode (floatToWord item) : rest
+      | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
+      | otherwise       = ppr_amode item : rest
+      where 
+       rep  = getAmodeRep item
+
+pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
+  =  pprWordArray info_lbl (mkInfoTable cl_info)
+  $$ let stuff = CCodeBlock entry_lbl entry in
+     pprAbsC stuff (costs stuff)

   where
   where

-    ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
+       entry_lbl = entryLabelFromCI cl_info
+       info_lbl  = infoTableLabelFromCI cl_info
+
+pprAbsC stmt@(CClosureTbl tycon) _
+  = vcat (
+       ptext SLIT("CLOSURE_TBL") <> 
+          lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
+       punctuate comma (
+          map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
+       )
+   ) $$ ptext SLIT("};")
+
+pprAbsC stmt@(CRetDirect uniq code srt liveness) _
+  =  pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
+  $$ let stuff = CCodeBlock entry_lbl code in
+     pprAbsC stuff (costs stuff)
+  where
+     info_lbl  = mkReturnInfoLabel uniq
+     entry_lbl = mkReturnPtLabel uniq
+
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
+  = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
+
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
+  = vcat [
+       ptext SLIT("START_MOD_INIT") <> 
+           parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
+       case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
+       pprAbsC code (costs code),
+       hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
+    ]
+
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs
+\end{code}
+
+Info tables... just arrays of words (the translation is done in
+ClosureInfo).

 
 

-pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
+\begin{code}
+pprWordArray lbl amodes
+  = (case snd (initTE (ppr_decls_Amodes amodes)) of
+       Just pp -> pp
+       Nothing -> empty)
+  $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), 
+           pprCLabel lbl, ptext SLIT("[] = {") ]
+  $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
+  $$ ptext SLIT("};")
+
+castToWord s = text "(W_)(" <> s <> char ')'

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

-ppLocalness label
-  = uppBeside static const
+-- Print a CMachOp in a way suitable for emitting via C.
+pprMachOp_for_C MO_Nat_Add       = char '+'
+pprMachOp_for_C MO_Nat_Sub       = char '-'
+pprMachOp_for_C MO_Nat_Eq        = text "==" 
+pprMachOp_for_C MO_Nat_Ne        = text "!="
+
+pprMachOp_for_C MO_NatS_Ge       = text ">="
+pprMachOp_for_C MO_NatS_Le       = text "<="
+pprMachOp_for_C MO_NatS_Gt       = text ">"
+pprMachOp_for_C MO_NatS_Lt       = text "<"
+
+pprMachOp_for_C MO_NatU_Ge       = text ">="
+pprMachOp_for_C MO_NatU_Le       = text "<="
+pprMachOp_for_C MO_NatU_Gt       = text ">"
+pprMachOp_for_C MO_NatU_Lt       = text "<"
+
+pprMachOp_for_C MO_NatS_Mul      = char '*'
+pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo"
+pprMachOp_for_C MO_NatS_Quot     = char '/'
+pprMachOp_for_C MO_NatS_Rem      = char '%'
+pprMachOp_for_C MO_NatS_Neg      = char '-'
+
+pprMachOp_for_C MO_NatU_Mul      = char '*'
+pprMachOp_for_C MO_NatU_Quot     = char '/'
+pprMachOp_for_C MO_NatU_Rem      = char '%'
+
+pprMachOp_for_C MO_Nat_And       = text "&"
+pprMachOp_for_C MO_Nat_Or        = text "|"
+pprMachOp_for_C MO_Nat_Xor       = text "^"
+pprMachOp_for_C MO_Nat_Not       = text "~"
+pprMachOp_for_C MO_Nat_Shl       = text "<<"
+pprMachOp_for_C MO_Nat_Shr       = text ">>"
+pprMachOp_for_C MO_Nat_Sar       = text ">>"
+
+pprMachOp_for_C MO_32U_Eq        = text "=="
+pprMachOp_for_C MO_32U_Ne        = text "!="
+pprMachOp_for_C MO_32U_Ge        = text ">="
+pprMachOp_for_C MO_32U_Le        = text "<="
+pprMachOp_for_C MO_32U_Gt        = text ">"
+pprMachOp_for_C MO_32U_Lt        = text "<"
+
+pprMachOp_for_C MO_Dbl_Eq        = text "=="
+pprMachOp_for_C MO_Dbl_Ne        = text "!="
+pprMachOp_for_C MO_Dbl_Ge        = text ">="
+pprMachOp_for_C MO_Dbl_Le        = text "<="
+pprMachOp_for_C MO_Dbl_Gt        = text ">"
+pprMachOp_for_C MO_Dbl_Lt        = text "<"
+
+pprMachOp_for_C MO_Dbl_Add       = text "+"
+pprMachOp_for_C MO_Dbl_Sub       = text "-"
+pprMachOp_for_C MO_Dbl_Mul       = text "*"
+pprMachOp_for_C MO_Dbl_Div       = text "/"
+pprMachOp_for_C MO_Dbl_Pwr       = text "pow"
+
+pprMachOp_for_C MO_Dbl_Sin       = text "sin"
+pprMachOp_for_C MO_Dbl_Cos       = text "cos"
+pprMachOp_for_C MO_Dbl_Tan       = text "tan"
+pprMachOp_for_C MO_Dbl_Sinh      = text "sinh"
+pprMachOp_for_C MO_Dbl_Cosh      = text "cosh"
+pprMachOp_for_C MO_Dbl_Tanh      = text "tanh"
+pprMachOp_for_C MO_Dbl_Asin      = text "asin"
+pprMachOp_for_C MO_Dbl_Acos      = text "acos"
+pprMachOp_for_C MO_Dbl_Atan      = text "atan"
+pprMachOp_for_C MO_Dbl_Log       = text "log"
+pprMachOp_for_C MO_Dbl_Exp       = text "exp"
+pprMachOp_for_C MO_Dbl_Sqrt      = text "sqrt"
+pprMachOp_for_C MO_Dbl_Neg       = text "-"
+
+pprMachOp_for_C MO_Flt_Add       = text "+"
+pprMachOp_for_C MO_Flt_Sub       = text "-"
+pprMachOp_for_C MO_Flt_Mul       = text "*"
+pprMachOp_for_C MO_Flt_Div       = text "/"
+pprMachOp_for_C MO_Flt_Pwr       = text "pow"
+
+pprMachOp_for_C MO_Flt_Eq        = text "=="
+pprMachOp_for_C MO_Flt_Ne        = text "!="
+pprMachOp_for_C MO_Flt_Ge        = text ">="
+pprMachOp_for_C MO_Flt_Le        = text "<="
+pprMachOp_for_C MO_Flt_Gt        = text ">"
+pprMachOp_for_C MO_Flt_Lt        = text "<"
+
+pprMachOp_for_C MO_Flt_Sin       = text "sin"
+pprMachOp_for_C MO_Flt_Cos       = text "cos"
+pprMachOp_for_C MO_Flt_Tan       = text "tan"
+pprMachOp_for_C MO_Flt_Sinh      = text "sinh"
+pprMachOp_for_C MO_Flt_Cosh      = text "cosh"
+pprMachOp_for_C MO_Flt_Tanh      = text "tanh"
+pprMachOp_for_C MO_Flt_Asin      = text "asin"
+pprMachOp_for_C MO_Flt_Acos      = text "acos"
+pprMachOp_for_C MO_Flt_Atan      = text "atan"
+pprMachOp_for_C MO_Flt_Log       = text "log"
+pprMachOp_for_C MO_Flt_Exp       = text "exp"
+pprMachOp_for_C MO_Flt_Sqrt      = text "sqrt"
+pprMachOp_for_C MO_Flt_Neg       = text "-"
+
+pprMachOp_for_C MO_32U_to_NatS   = text "(StgInt)"
+pprMachOp_for_C MO_NatS_to_32U   = text "(StgWord32)"
+
+pprMachOp_for_C MO_NatS_to_Dbl   = text "(StgDouble)"
+pprMachOp_for_C MO_Dbl_to_NatS   = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_Flt   = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_NatS   = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatU  = text "(StgWord)"
+pprMachOp_for_C MO_NatU_to_NatS  = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatP  = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatS  = text "(StgInt)"
+pprMachOp_for_C MO_NatU_to_NatP  = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatU  = text "(StgWord)"
+
+pprMachOp_for_C MO_Dbl_to_Flt    = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_Dbl    = text "(StgDouble)"
+
+pprMachOp_for_C MO_8S_to_NatS    = text "(StgInt8)(StgInt)"
+pprMachOp_for_C MO_16S_to_NatS   = text "(StgInt16)(StgInt)"
+pprMachOp_for_C MO_32S_to_NatS   = text "(StgInt32)(StgInt)"
+
+pprMachOp_for_C MO_8U_to_NatU    = text "(StgWord8)(StgWord)"
+pprMachOp_for_C MO_16U_to_NatU   = text "(StgWord16)(StgWord)"
+pprMachOp_for_C MO_32U_to_NatU   = text "(StgWord32)(StgWord)"
+
+pprMachOp_for_C MO_8U_to_32U     = text "(StgWord32)"
+pprMachOp_for_C MO_32U_to_8U     = text "(StgWord8)"
+
+
+ppLocalness lbl
+  = if (externallyVisibleCLabel lbl) 
+               then empty 
+               else ptext SLIT("static ")
+
+-- Horrible macros for declaring the types and locality of labels (see
+-- StgMacros.h).
+
+ppLocalnessMacro include_dyn_prefix clabel =
+     hcat [
+        visiblity_prefix,
+       dyn_prefix,
+        case label_type of
+         ClosureType        -> ptext SLIT("C_")
+         CodeType           -> ptext SLIT("F_")
+         InfoTblType        -> ptext SLIT("I_")
+         RetInfoTblType     -> ptext SLIT("RI_")
+         ClosureTblType     -> ptext SLIT("CP_")
+         DataType           -> ptext SLIT("D_")
+     ]

   where
   where

-    static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
-    const  = if not (isReadOnly label)         then uppNil else uppPStr SLIT("const")
-
-ppLocalnessMacro for_fun{-vs data-} clabel
-  = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix ->
-    case (if isReadOnly clabel then "RO_" else "")           of { suffix ->
-    if for_fun
-       then uppStr (prefix ++ "F_")
-       else uppStr (prefix ++ "D_" ++ suffix)
-    } }
+   is_visible = externallyVisibleCLabel clabel
+   label_type = labelType clabel
+
+   visiblity_prefix
+     | is_visible = char 'E'
+     | otherwise  = char 'I'
+
+   dyn_prefix
+     | include_dyn_prefix && labelDynamic clabel = char 'D'
+     | otherwise                                = empty
+

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

+jmp_lit = "JMP_("
+

 grab_non_void_amodes amodes
   = filter non_void amodes
 
 grab_non_void_amodes amodes
   = filter non_void amodes
 

@@ -458,60 +693,49 @@ non_void amode
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
-
-ppr_vol_regs sty [] = (uppNil, uppNil)
-ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
-ppr_vol_regs sty (r:rs)
+ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
+ppr_maybe_vol_regs Nothing
+   = (empty, empty)
+ppr_maybe_vol_regs (Just vrs)
+   = case ppr_vol_regs vrs of
+        (saves, restores) 
+           -> (pp_basic_saves $$ saves,
+               pp_basic_restores $$ restores)
+
+ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
+
+ppr_vol_regs [] = (empty, empty)
+ppr_vol_regs (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
     in

-    (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
-     uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
+    (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
+     ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)

 
 

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

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

--- anything else.
-pp_basic_saves
-  = uppAboves [
-       uppPStr SLIT("CALLER_SAVE_Base"),
-       uppPStr SLIT("CALLER_SAVE_SpA"),
-       uppPStr SLIT("CALLER_SAVE_SuA"),
-       uppPStr SLIT("CALLER_SAVE_SpB"),
-       uppPStr SLIT("CALLER_SAVE_SuB"),
-       uppPStr SLIT("CALLER_SAVE_Ret"),
---     uppPStr SLIT("CALLER_SAVE_Activity"),
-       uppPStr SLIT("CALLER_SAVE_Hp"),
-       uppPStr SLIT("CALLER_SAVE_HpLim") ]
-
-pp_basic_restores
-  = uppAboves [
-       uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
-       uppPStr SLIT("CALLER_RESTORE_SpA"),
-       uppPStr SLIT("CALLER_RESTORE_SuA"),
-       uppPStr SLIT("CALLER_RESTORE_SpB"),
-       uppPStr SLIT("CALLER_RESTORE_SuB"),
-       uppPStr SLIT("CALLER_RESTORE_Ret"),
---     uppPStr SLIT("CALLER_RESTORE_Activity"),
-       uppPStr SLIT("CALLER_RESTORE_Hp"),
-       uppPStr SLIT("CALLER_RESTORE_HpLim"),
-       uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
-       uppPStr SLIT("CALLER_RESTORE_StkStub") ]
+-- anything else. The correct sequence of saves&restores are
+-- encoded by the CALLER_*_SYSTEM macros.
+pp_basic_saves    = ptext SLIT("CALLER_SAVE_SYSTEM")
+pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")

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

-if_profiling sty pretty
-  = case sty of
-      PprForC -> if  opt_SccProfilingOn
-                then pretty
-                else uppChar '0' -- leave it out!
-
-      _ -> {-print it anyway-} pretty
+pp_closure_lbl lbl
+      | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
+      | otherwise       = char '&' <> pprCLabel lbl
+\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;

@@ -519,33 +743,40 @@ 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
-  = 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)
-                                     deflt alt_code
-                                     (addrModeCosts discrim Rhs) c
-      other              -> let
-                              cond = uppBesides [ pprAmode sty discrim,
-                                         uppPStr SLIT(" == "),
-                                         pprAmode sty (CLit tag) ]
-                           in
-                           ppr_if_stmt sty cond
-                                        alt_code deflt
-                                        (addrModeCosts discrim Rhs) c
-
-ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
-  = uppAboves [
-      uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
-      uppNest 8 (pprAbsC sty then_part         (c + discrim_costs +
+do_if_stmt discrim tag alt_code deflt c
+   = let
+       cond = hcat [ pprAmode discrim
+                  , ptext SLIT(" == ")
+                  , tcast
+                  , pprAmode (CLit tag)
+                  ]
+       -- to be absolutely sure that none of the 
+       -- conversion rules hit, e.g.,
+       --
+       --     minInt is different to (int)minInt
+        --
+       -- in C (when minInt is a number not a constant
+       --  expression which evaluates to it.)
+       -- 
+       tcast = case tag of
+                  MachInt _  -> ptext SLIT("(I_)")
+                  _          -> empty
+     in
+     ppr_if_stmt cond
+                alt_code deflt
+                (addrModeCosts discrim Rhs) c
+
+ppr_if_stmt pp_pred then_part else_part discrim_costs c
+  = vcat [
+      hcat [text "if (", pp_pred, text ") {"],
+      nest 8 (pprAbsC then_part        (c + discrim_costs +

                                        (Cost (0, 2, 0, 0, 0)) +
                                        costs then_part)),
                                        (Cost (0, 2, 0, 0, 0)) +
                                        costs then_part)),

-      (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
-      uppNest 8 (pprAbsC sty else_part  (c + discrim_costs +
+      (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
+      nest 8 (pprAbsC else_part  (c + discrim_costs +

                                        (Cost (0, 1, 0, 0, 0)) +
                                        costs else_part)),
                                        (Cost (0, 1, 0, 0, 0)) +
                                        costs else_part)),

-      uppChar '}' ]
+      char '}' ]

     {- Total costs = inherited costs (before if) + costs for accessing discrim
                     + costs for cond branch ( = (0, 1, 0, 0, 0) )
                     + costs for that alternative
     {- Total costs = inherited costs (before if) + costs for accessing discrim
                     + costs for cond branch ( = (0, 1, 0, 0, 0) )
                     + costs for that alternative

@@ -567,18 +798,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

@@ -602,105 +828,200 @@ 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 ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
-    else
-    uppAboves [
-      uppChar '{',
-      declare_local_vars,   -- local var for *result*
-      uppAboves local_arg_decls,
-      -- if is_asm then uppNil else declareExtern,
-      pp_save_context,
-      process_casm local_vars pp_non_void_args casm_str,
-      pp_restore_context,
-      assign_results,
-      uppChar '}'
-    ]
+pprFCall call uniq args results vol_regs
+  = case call of
+      CCall (CCallSpec target _cconv safety) ->
+        vcat [ char '{',
+               declare_local_vars,   -- local var for *result*
+               vcat local_arg_decls,
+               makeCall target safety 
+                        (process_casm local_vars pp_non_void_args (call_str target)),
+               assign_results,
+             char '}'
+            ]
+      DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
+         let
+         resultVar = "_ccall_result"
+         hasAssemArg = isStatic || kind == DNConstructor
+         invokeOp  = 
+           case kind of
+             DNMethod 
+               | isStatic  -> "DN_invokeStatic"
+               | otherwise -> "DN_invokeMethod"
+             DNField
+               | isStatic ->
+                  if resTy == DNUnit 
+                   then "DN_setStatic"
+                   else "DN_getStatic"
+                | otherwise ->
+                  if resTy == DNUnit 
+                   then "DN_setField"
+                   else "DN_getField"
+             DNConstructor -> "DN_createObject"
+
+         (methArrDecl, methArrInit, methArrName, methArrLen) 
+           | null argTys = (empty, empty, text "NULL", text "0")
+           | otherwise   = 
+             ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
+             , vcat (zipWith3 (\ idx arg argTy -> 
+                                text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
+                                text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
+                              [0..]
+                              non_void_args
+                              argTys)
+             , text "__meth_args"
+             , int (length non_void_args)
+             )
+        in
+         vcat [ char '{',
+                 declare_local_vars,
+                 vcat local_arg_decls,
+                 vcat [ methArrDecl
+                      , methArrInit
+                      , text "_ccall_result1 =" <+> text invokeOp <> parens (
+                         hcat (punctuate comma $
+                                    (if hasAssemArg then
+                                       ((if null assem then 
+                                           text "NULL" 
+                                        else 
+                                           doubleQuotes (text assem)):)
+                                     else
+                                        id) $
+                                    [ doubleQuotes $ text nm
+                                    , methArrName
+                                    , methArrLen
+                                    , text (toDotnetTy resTy)
+                                    , text "(void*)&" <> text resultVar 
+                                    ])) <> semi
+                       ],
+                 assign_results,
+               char '}'
+              ]

   where
   where

-    (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
-    (pp_save_context, pp_restore_context) =
-       if may_gc
-       then (  uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
-               uppStr "inCCallGC--; RestoreAllStgRegs();")
-       else (  pp_basic_saves `uppAbove` pp_saves,
-               pp_basic_restores `uppAbove` pp_restores)
-
-    non_void_args =
-       let nvas = tail args
-       in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidRep)
+    (pp_saves, pp_restores) = ppr_vol_regs vol_regs
+    
+    makeCall target safety theCall = 
+        vcat [ pp_save_context,        theCall, pp_restore_context ]
+     where
+      (pp_save_context, pp_restore_context)
+       | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <> 
+                               text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+                           , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
+                           )
+       | otherwise = ( pp_basic_saves $$ pp_saves,
+                       pp_basic_restores $$ pp_restores)
+          where
+           thread_macro_args = ppr_uniq_token <> comma <+> 
+                               text "rts" <> ppr (playThreadSafe safety)
+           ppr_uniq_token = text "tok_" <> ppr uniq
+
+
+    non_void_args = 
+       let nvas = init args
+       in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) )
+       nvas
+    -- the last argument will be the "I/O world" token (a VoidRep)

     -- all others should be non-void
 
     non_void_results =
        let nvrs = grab_non_void_amodes results
     -- all others should be non-void
 
     non_void_results =
        let nvrs = grab_non_void_amodes results

-       in ASSERT (length nvrs <= 1) nvrs
+       in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs

     -- there will usually be two results: a (void) state which we
     -- should ignore and a (possibly void) result.
 
     (local_arg_decls, pp_non_void_args)
     -- there will usually be two results: a (void) state which we
     -- should ignore and a (possibly void) result.
 
     (local_arg_decls, pp_non_void_args)

-      = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
-
-    pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
+      = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]

 
     (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 forDotnet

 
 

-    casm_str = if is_asm then _UNPK_ op_str else ccall_str
+    forDotnet
+      = case call of
+          DNCall{} -> True
+         _ -> False

 
 

-    -- Remainder only used for ccall
+    call_str tgt 
+      = case tgt of
+         StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
+         DynamicTarget   -> mk_ccall_str dyn_fun              (tail ccall_args)

 
 

-    ccall_str = uppShow 80
-       (uppBesides [
+    ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+    dyn_fun    = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+                                                
+
+    -- Remainder only used for ccall
+    mk_ccall_str fun_name ccall_fun_args = showSDoc
+       (hcat [

                if null non_void_results
                if null non_void_results

-                 then uppNil
-                 else uppPStr SLIT("%r = "),
-               uppLparen, uppPStr op_str, uppLparen,
-                 uppIntersperse uppComma ccall_args,
-               uppStr "));"
+                 then empty
+                 else text "%r = ",
+               lparen, fun_name, lparen,
+                 hcat (punctuate comma ccall_fun_args),
+               text "));"

        ])
        ])

-    num_args = length non_void_args
-    ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
-\end{code}

 
 

-If the argument is a heap object, we need to reach inside and pull out
-the bit the C world wants to see.  The only heap objects which can be
-passed are @Array@s, @ByteArray@s and @ForeignObj@s.
-
-\begin{code}
-ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
+toDotnetTy :: DNType -> String
+toDotnetTy x = 
+  case x of 
+    DNByte -> "Dotnet_Byte"
+    DNBool -> "Dotnet_Bool"
+    DNChar -> "Dotnet_Char"
+    DNDouble -> "Dotnet_Double"
+    DNFloat  -> "Dotnet_Float"
+    DNInt    -> "Dotnet_Int"
+    DNInt8   -> "Dotnet_Int8"
+    DNInt16  -> "Dotnet_Int16"
+    DNInt32  -> "Dotnet_Int32"
+    DNInt64  -> "Dotnet_Int64"
+    DNWord8  -> "Dotnet_Word8"
+    DNWord16 -> "Dotnet_Word16"
+    DNWord32 -> "Dotnet_Word32"
+    DNWord64 -> "Dotnet_Word64"
+    DNPtr    -> "Dotnet_Ptr"
+    DNUnit   -> "Dotnet_Unit"
+    DNObject -> "Dotnet_Object"
+    DNString -> "Dotnet_String"
+
+toDotnetArgField :: DNType -> String
+toDotnetArgField x = 
+  case x of 
+    DNByte -> "arg_byte"
+    DNBool -> "arg_bool"
+    DNChar -> "arg_char"
+    DNDouble -> "arg_double"
+    DNFloat  -> "arg_float"
+    DNInt    -> "arg_int"
+    DNInt8   -> "arg_int8"
+    DNInt16  -> "arg_int16"
+    DNInt32  -> "arg_int32"
+    DNInt64  -> "arg_int64"
+    DNWord8  -> "arg_word8"
+    DNWord16 -> "arg_word16"
+    DNWord32 -> "arg_word32"
+    DNWord64 -> "arg_word64"
+    DNPtr    -> "arg_ptr"
+    DNUnit   -> "arg_ptr" -- can't happen
+    DNObject -> "arg_obj"
+    DNString -> "arg_str"
+
+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
-
-       local_var  = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
+       pp_amode = pprAmode amode
+       pp_kind  = pprPrimKind a_kind

 
 

-       (arg_type, pp_amode2)
-         = case a_kind of
-
-             -- for array arguments, pass a pointer to the body of the array
-             -- (PTRS_ARR_CTS skips over all the header nonsense)
-             ArrayRep      -> (pp_kind,
-                               uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
-             ByteArrayRep -> (pp_kind,
-                               uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
-
-             -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
-             ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
-                               uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"])
-             other         -> (pp_kind, pp_amode)
+       local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)

 
        declare_local_var
 
        declare_local_var

-         = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
+         = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]

     in
     (declare_local_var, local_var)
 \end{code}
     in
     (declare_local_var, local_var)
 \end{code}

@@ -711,57 +1032,38 @@ For l-values, the critical questions are:
 
    We only allow zero or one results.
 
 
    We only allow zero or one results.
 

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

 \begin{code}
 \begin{code}

-ppr_casm_results ::
-       PprStyle        -- style
-       -> [CAddrMode]  -- list of results (length <= 1)
-       -> Unpretty     -- liveness mask
+ppr_casm_results
+       :: [CAddrMode]  -- list of results (length <= 1)
+       -> Bool         -- True => multiple results OK.

        ->
        ->

-       ( Unpretty,     -- declaration of any local vars
-         [Unpretty],   -- list of result vars (same length as results)
-         Unpretty )    -- 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
-  = (uppNil, [], uppNil)       -- no results
+ppr_casm_results [] _
+  = (empty, [], empty)         -- no results

 
 

-ppr_casm_results sty [r] liveness
-  = let
-       result_reg = ppr_amode sty r
+ppr_casm_results (r:rs) multiResultsOK
+  | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
+  | otherwise
+  = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
+         (empty,[],empty)
+         (zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
+    where
+      pprRes r suf = (declare_local_var, [local_var], assign_result)
+       where
+       result_reg = ppr_amode r

        r_kind     = getAmodeRep r
 
        r_kind     = getAmodeRep r
 

-       local_var  = uppPStr SLIT("_ccall_result")
+       local_var  = ptext SLIT("_ccall_result") <> text suf

 
        (result_type, assign_result)
 
        (result_type, assign_result)

-         = case r_kind of
-{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
-   Instead, external references have to be 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 ->
-               (uppPStr SLIT("StgForeignObj"),
-                uppBesides [ uppStr "constructForeignObj(",
-                               liveness, uppComma,
-                               result_reg, uppComma,
-                               local_var,
-                            pp_paren_semi ]) -}
-             _ ->
-               (pprPrimKind sty r_kind,
-                uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
-
-       declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
-    in
-    (declare_local_var, [local_var], assign_result)
+         = (pprPrimKind r_kind,
+            hcat [ result_reg, equals, local_var, semi ])
+
+       declare_local_var = hcat [ result_type, space, local_var, semi ]

 
 

-ppr_casm_results sty rs liveness
-  = panic "ppr_casm_results: ccall/casm with many results"

 \end{code}
 
 
 \end{code}
 
 

@@ -772,17 +1074,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 ::
-       [Unpretty]              -- results (length <= 1)
-       -> [Unpretty]           -- arguments
-       -> String               -- format string (with embedded %'s)
-       ->
-       Unpretty                        -- 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_casm results args string = process results args string
  where

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

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

@@ -790,25 +1092,28 @@ 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) ->

-           uppBeside (uppChar '%') (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] -> uppBeside 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 ->

-         case readDec other of
+         let
+               read_int :: ReadS Int
+               read_int = reads
+         in
+         case (read_int other) of

            [(num,css)] ->
            [(num,css)] ->

-                 if 0 <= num && num < length args
-                 then uppBeside (uppParens (args !! num))
-                                (process ress args css)
-                   else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
+                 if num >= 0 && args `lengthExceeds` num
+                 then parens (args !! num) <> process ress args css
+                 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")

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

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

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

@@ -825,61 +1130,59 @@ 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 -> Unpretty
+pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc

 
 

-pprAssign sty VoidRep dest src = uppNil
+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
-  = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
+pprAssign FloatRep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
+
+pprAssign DoubleRep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]

 
 

-pprAssign sty DoubleRep dest@(CVal reg_rel _) src
-  = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
+pprAssign Int64Rep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
+pprAssign Word64Rep dest@(CVal reg_rel _) src
+  = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]

 \end{code}
 
 Lastly, the question is: will the C compiler think the types of the
 two sides of the assignment match?
 
 \end{code}
 
 Lastly, the question is: will the C compiler think the types of the
 two sides of the assignment match?
 

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

 
 

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

 
 \begin{code}
 
 \begin{code}

-pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
-  = uppBesides [ pprVanillaReg dest, uppEquals,
-               pprVanillaReg src, uppSemi ]
+pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
+  = 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

-  = uppBesides [ ppr_amode sty dest, uppEquals,
-               uppStr "(W_)(", -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
+  = hcat [ ppr_amode dest, equals,
+               text "(W_)(",   -- Here is the cast
+               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

-  = uppBesides [ ppr_amode sty dest, uppEquals,
-               uppStr "(P_)(", -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
-
-pprAssign sty ByteArrayRep dest src
-  | mixedPtrLocn src
-    -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
-  = uppBesides [ ppr_amode sty dest, uppEquals,
-               uppStr "(B_)(", -- Here is the cast
-               ppr_amode sty src, pp_paren_semi ]
-
-pprAssign sty kind other_dest src
-  = uppBesides [ ppr_amode sty other_dest, uppEquals,
-               pprAmode  sty src, uppSemi ]
+  = hcat [ ppr_amode dest, equals,
+               text "(P_)(",   -- 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}
 
 

@@ -894,7 +1197,7 @@ pprAssign sty kind other_dest src
 @pprAmode@.
 
 \begin{code}
 @pprAmode@.
 
 \begin{code}

-pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
+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

@@ -905,82 +1208,133 @@ similar to those in @pprAssign@:
 question.)
 
 \begin{code}
 question.)
 
 \begin{code}

-pprAmode sty (CVal reg_rel FloatRep)
-  = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
-pprAmode sty (CVal reg_rel DoubleRep)
-  = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
+pprAmode (CVal reg_rel FloatRep)
+  = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
+pprAmode (CVal reg_rel DoubleRep)
+  = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
+pprAmode (CVal reg_rel Int64Rep)
+  = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
+pprAmode (CVal reg_rel Word64Rep)
+  = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]

 \end{code}
 
 Next comes the case where there is some other cast need, and the
 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

-  = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(",
-               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}
 
 \end{code}
 

-Now the rest of the cases for ``workhorse'' @ppr_amode@:
+When we have an indirection through a CIndex, we have to be careful to
+get the type casts right.  

 
 

-\begin{code}
-ppr_amode sty (CVal reg_rel _)
-  = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
-       (pp_reg, Nothing)     -> uppBeside  (uppChar '*') pp_reg
-       (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
+this amode:

 
 

-ppr_amode sty (CAddr reg_rel)
-  = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
-       (pp_reg, Nothing)     -> pp_reg
-       (pp_reg, Just offset) -> uppBeside pp_reg offset
+       CVal (CIndex kind1 base offset) kind2

 
 

-ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
+means (in C speak): 
+       
+       *(kind2 *)((kind1 *)base + offset)

 
 

-ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
+That is, the indexing is done in units of kind1, but the resulting
+amode has kind2.

 
 

-ppr_amode sty (CLbl label kind) = pprCLabel sty label
+\begin{code}
+ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
+  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
+       (pp_reg, Nothing)     -> panic "ppr_amode: CIndex"
+       (pp_reg, Just offset) -> 
+          hcat [ char '*', parens (pprPrimKind kind <> char '*'),
+                 parens (pp_reg <> char '+' <> offset) ]
+\end{code}

 
 

-ppr_amode sty (CUnVecLbl direct vectored)
-  = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
-              pprCLabel sty vectored, uppRparen]
+Now the rest of the cases for ``workhorse'' @ppr_amode@:

 
 

-ppr_amode sty (CCharLike char)
-  = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
-ppr_amode sty (CIntLike int)
-  = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
+\begin{code}
+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 ]

 
 

-ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
-  -- ToDo: are these *used* for anything?
+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

 
 

-ppr_amode sty (CLit lit) = pprBasicLit sty lit
+ppr_amode (CReg magic_id) = pprMagicId magic_id

 
 

-ppr_amode sty (CLitLit str _) = uppPStr str
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'

 
 

-ppr_amode sty (COffset off) = pprHeapOffset sty off
+ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl 

 
 

-ppr_amode sty (CCode abs_C)
-  = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
+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 (CLabelledCode label abs_C)
-  = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"],
-              uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
+ppr_amode (CLit lit) = pprBasicLit lit

 
 

-ppr_amode sty (CJoinPoint _ _)
+ppr_amode (CJoinPoint _)

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

-ppr_amode sty (CTableEntry base index kind)
-  = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
-              ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
-              uppStr ")]"]
+ppr_amode (CMacroExpr pk macro as)
+  = parens (ptext (cExprMacroText macro) <> 
+           parens (hcat (punctuate comma (map pprAmode as))))
+\end{code}

 
 

-ppr_amode sty (CMacroExpr pk macro as)
-  = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
-              uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
+\begin{code}
+cExprMacroText ENTRY_CODE              = SLIT("ENTRY_CODE")
+cExprMacroText ARG_TAG                 = SLIT("ARG_TAG")
+cExprMacroText GET_TAG                 = SLIT("GET_TAG")
+cExprMacroText CCS_HDR                 = SLIT("CCS_HDR")
+cExprMacroText BYTE_ARR_CTS            = SLIT("BYTE_ARR_CTS")
+cExprMacroText PTRS_ARR_CTS            = SLIT("PTRS_ARR_CTS")
+cExprMacroText ForeignObj_CLOSURE_DATA  = SLIT("ForeignObj_CLOSURE_DATA")
+
+cStmtMacroText UPD_CAF                 = SLIT("UPD_CAF")
+cStmtMacroText UPD_BH_UPDATABLE                = SLIT("UPD_BH_UPDATABLE")
+cStmtMacroText UPD_BH_SINGLE_ENTRY     = SLIT("UPD_BH_SINGLE_ENTRY")
+cStmtMacroText PUSH_UPD_FRAME          = SLIT("PUSH_UPD_FRAME")
+cStmtMacroText SET_TAG                 = SLIT("SET_TAG")
+cStmtMacroText DATA_TO_TAGZH            = SLIT("dataToTagzh")
+cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT         = SLIT("REGISTER_IMPORT")
+cStmtMacroText REGISTER_DIMPORT                = SLIT("REGISTER_DIMPORT")
+cStmtMacroText GRAN_FETCH              = SLIT("GRAN_FETCH")
+cStmtMacroText GRAN_RESCHEDULE         = SLIT("GRAN_RESCHEDULE")
+cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
+cStmtMacroText THREAD_CONTEXT_SWITCH           = SLIT("THREAD_CONTEXT_SWITCH")
+cStmtMacroText GRAN_YIELD              = SLIT("GRAN_YIELD")
+
+cCheckMacroText        HP_CHK_NP               = SLIT("HP_CHK_NP")
+cCheckMacroText        STK_CHK_NP              = SLIT("STK_CHK_NP")
+cCheckMacroText        HP_STK_CHK_NP           = SLIT("HP_STK_CHK_NP")
+cCheckMacroText        HP_CHK_FUN              = SLIT("HP_CHK_FUN")
+cCheckMacroText        STK_CHK_FUN             = SLIT("STK_CHK_FUN")
+cCheckMacroText        HP_STK_CHK_FUN          = SLIT("HP_STK_CHK_FUN")
+cCheckMacroText        HP_CHK_NOREGS           = SLIT("HP_CHK_NOREGS")
+cCheckMacroText        HP_CHK_UNPT_R1          = SLIT("HP_CHK_UNPT_R1")
+cCheckMacroText        HP_CHK_UNBX_R1          = SLIT("HP_CHK_UNBX_R1")
+cCheckMacroText        HP_CHK_F1               = SLIT("HP_CHK_F1")
+cCheckMacroText        HP_CHK_D1               = SLIT("HP_CHK_D1")
+cCheckMacroText        HP_CHK_L1               = SLIT("HP_CHK_L1")
+cCheckMacroText        HP_CHK_UNBX_TUPLE       = SLIT("HP_CHK_UNBX_TUPLE")
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%*                                                                     *
+%************************************************************************

 
 

-ppr_amode sty (CCostCentre cc print_as_string)
-  = uppCostCentre sty print_as_string cc
+\begin{code}
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs

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

@@ -989,51 +1343,49 @@ ppr_amode sty (CCostCentre cc print_as_string)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@pprRegRelative@ returns a pair of the @Unpretty@ for the register
-(some casting may be required), and a @Maybe Unpretty@ for the offset
+@pprRegRelative@ returns a pair of the @Doc@ for the register
+(some casting may be required), and a @Maybe Doc@ for the offset

 (zero offset gives a @Nothing@).
 
 \begin{code}
 (zero offset gives a @Nothing@).
 
 \begin{code}

-addPlusSign :: Bool -> Unpretty -> Unpretty
+addPlusSign :: Bool -> SDoc -> SDoc

 addPlusSign False p = p
 addPlusSign False p = p

-addPlusSign True  p = uppBeside (uppChar '+') p
+addPlusSign True  p = (<>) (char '+') p

 
 

-pprSignedInt :: Bool -> Int -> Maybe Unpretty  -- Nothing => 0
+pprSignedInt :: Bool -> Int -> Maybe SDoc      -- Nothing => 0

 pprSignedInt sign_wanted n
  = if n == 0 then Nothing else
 pprSignedInt sign_wanted n
  = if n == 0 then Nothing else

-   if n > 0  then Just (addPlusSign sign_wanted (uppInt n))
-   else          Just (uppInt n)
+   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

-              -> (Unpretty, Maybe Unpretty)
-
-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 (uppBeside (uppChar '-') (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)))

 
 

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

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

@@ -1041,53 +1393,44 @@ 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 -> Unpretty
+pprMagicId :: MagicId -> SDoc

 
 

-pprMagicId sty BaseReg             = uppPStr SLIT("BaseReg")
-pprMagicId sty StkOReg             = uppPStr SLIT("StkOReg")
-pprMagicId sty (VanillaReg pk n)
-                                   = uppBesides [ pprVanillaReg n, uppChar '.',
+pprMagicId BaseReg                 = ptext SLIT("BaseReg")
+pprMagicId (VanillaReg pk n)
+                                   = hcat [ pprVanillaReg n, char '.',

                                                  pprUnionTag pk ]
                                                  pprUnionTag pk ]

-pprMagicId sty (FloatReg  n)        = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
-pprMagicId sty (DoubleReg n)       = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
-pprMagicId sty TagReg              = uppPStr SLIT("TagReg")
-pprMagicId sty RetReg              = uppPStr SLIT("RetReg")
-pprMagicId sty SpA                 = uppPStr SLIT("SpA")
-pprMagicId sty SuA                 = uppPStr SLIT("SuA")
-pprMagicId sty SpB                 = uppPStr SLIT("SpB")
-pprMagicId sty SuB                 = uppPStr SLIT("SuB")
-pprMagicId sty Hp                  = uppPStr SLIT("Hp")
-pprMagicId sty HpLim               = uppPStr SLIT("HpLim")
-pprMagicId sty LivenessReg         = uppPStr SLIT("LivenessReg")
-pprMagicId sty StdUpdRetVecReg      = uppPStr SLIT("StdUpdRetVecReg")
-pprMagicId sty StkStubReg          = uppPStr SLIT("StkStubReg")
-pprMagicId sty CurCostCentre       = uppPStr SLIT("CCC")
-pprMagicId sty VoidReg             = panic "pprMagicId:VoidReg!"
-
-pprVanillaReg :: FAST_INT -> Unpretty
-
-pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
-
-pprUnionTag :: PrimRep -> Unpretty
-
-pprUnionTag PtrRep             = uppChar 'p'
-pprUnionTag CodePtrRep         = uppPStr SLIT("fp")
-pprUnionTag DataPtrRep         = uppChar 'd'
-pprUnionTag RetRep             = uppChar 'r'
+pprMagicId (FloatReg  n)            = ptext SLIT("F") <> int (I# n)
+pprMagicId (DoubleReg n)           = ptext SLIT("D") <> int (I# n)
+pprMagicId (LongReg _ n)           = ptext SLIT("L") <> int (I# n)
+pprMagicId Sp                      = ptext SLIT("Sp")
+pprMagicId SpLim                   = ptext SLIT("SpLim")
+pprMagicId Hp                      = ptext SLIT("Hp")
+pprMagicId HpLim                   = ptext SLIT("HpLim")
+pprMagicId CurCostCentre           = ptext SLIT("CCCS")
+pprMagicId VoidReg                 = ptext SLIT("VoidReg")
+
+pprVanillaReg :: Int# -> SDoc
+pprVanillaReg n = char 'R' <> int (I# n)
+
+pprUnionTag :: PrimRep -> SDoc
+
+pprUnionTag PtrRep             = char 'p'
+pprUnionTag CodePtrRep         = ptext SLIT("fp")
+pprUnionTag DataPtrRep         = char 'd'
+pprUnionTag RetRep             = char 'p'

 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 

-pprUnionTag CharRep            = uppChar 'c'
-pprUnionTag IntRep             = uppChar 'i'
-pprUnionTag WordRep            = uppChar 'w'
-pprUnionTag AddrRep            = uppChar 'v'
-pprUnionTag FloatRep           = uppChar 'f'
+pprUnionTag CharRep            = char 'c'
+pprUnionTag Int8Rep            = ptext SLIT("i8")
+pprUnionTag IntRep             = char 'i'
+pprUnionTag WordRep            = char 'w'
+pprUnionTag Int32Rep           = char 'i'
+pprUnionTag Word32Rep          = char 'w'
+pprUnionTag AddrRep            = char 'a'
+pprUnionTag FloatRep           = char 'f'

 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 

-pprUnionTag StablePtrRep       = uppChar 'i'
-pprUnionTag ForeignObjRep      = uppChar 'p'
-
-pprUnionTag ArrayRep           = uppChar 'p'
-pprUnionTag ByteArrayRep       = uppChar 'b'
+pprUnionTag StablePtrRep       = char 'p'

 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}

@@ -1096,34 +1439,34 @@ 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 -> (Unpretty{-temps-}, Unpretty{-externs-})
-pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
+pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls AbsCNop = (empty, empty)

 
 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
   = initTE (ppr_decls_AbsC stmt1       `thenTE` \ (t_p1, e_p1) ->
            ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
            case (catMaybes [t_p1, t_p2])        of { real_temps ->
            case (catMaybes [e_p1, e_p2])        of { real_exts ->
 
 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
   = initTE (ppr_decls_AbsC stmt1       `thenTE` \ (t_p1, e_p1) ->
            ppr_decls_AbsC stmt2        `thenTE` \ (t_p2, e_p2) ->
            case (catMaybes [t_p1, t_p2])        of { real_temps ->
            case (catMaybes [e_p1, e_p2])        of { real_exts ->

-           returnTE (uppAboves real_temps, uppAboves real_exts) }}
+           returnTE (vcat real_temps, vcat real_exts) }}

           )
 
 pprTempAndExternDecls other_stmt
   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
            returnTE (
                case maybe_t of
           )
 
 pprTempAndExternDecls other_stmt
   = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
            returnTE (
                case maybe_t of

-                 Nothing -> uppNil
+                 Nothing -> empty

                  Just pp -> pp,
 
                case maybe_e of
                  Just pp -> pp,
 
                case maybe_e of

-                 Nothing -> uppNil
+                 Nothing -> empty

                  Just pp -> pp )
           )
 
                  Just pp -> pp )
           )
 

-pprBasicLit :: PprStyle -> Literal -> Unpretty
-pprPrimKind :: PprStyle -> PrimRep -> Unpretty
+pprBasicLit :: Literal -> SDoc
+pprPrimKind :: PrimRep -> SDoc

 
 

-pprBasicLit  sty lit = uppStr (showLiteral  sty lit)
-pprPrimKind  sty k   = uppStr (showPrimRep k)
+pprBasicLit  lit = ppr lit
+pprPrimKind  k   = ppr k

 \end{code}
 
 
 \end{code}
 
 

@@ -1145,6 +1488,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)

@@ -1187,54 +1531,48 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels)
          False)
 
 labelSeenTE :: CLabel -> TeM Bool
          False)
 
 labelSeenTE :: CLabel -> TeM Bool

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

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

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

          False)
 \end{code}
 
 \begin{code}
          False)
 \end{code}
 
 \begin{code}

-pprTempDecl :: Unique -> PrimRep -> Unpretty
+pprTempDecl :: Unique -> PrimRep -> SDoc

 pprTempDecl uniq kind
 pprTempDecl uniq kind

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

 
 

-       uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
-       }

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

-ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
+ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})

 
 ppr_decls_AbsC AbsCNop         = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
 
 ppr_decls_AbsC AbsCNop         = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
   = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
     ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->

-    returnTE (maybe_uppAboves [p1, p2])
-
-ppr_decls_AbsC (CClosureUpdInfo info)
-  = ppr_decls_AbsC info
+    returnTE (maybe_vcat [p1, p2])

 
 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (CAssign dest source)
   = ppr_decls_Amode dest    `thenTE` \ p1 ->
     ppr_decls_Amode source  `thenTE` \ p2 ->
 
 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
 
 ppr_decls_AbsC (CAssign dest source)
   = ppr_decls_Amode dest    `thenTE` \ p1 ->
     ppr_decls_Amode source  `thenTE` \ p2 ->

-    returnTE (maybe_uppAboves [p1, p2])
+    returnTE (maybe_vcat [p1, p2])

 
 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
 
 
 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
 

@@ -1246,26 +1584,37 @@ ppr_decls_AbsC (CSwitch discrim alts deflt)
   = ppr_decls_Amode discrim    `thenTE` \ pdisc ->
     mapTE ppr_alt_stuff alts   `thenTE` \ palts  ->
     ppr_decls_AbsC deflt       `thenTE` \ pdeflt ->
   = ppr_decls_Amode discrim    `thenTE` \ pdisc ->
     mapTE ppr_alt_stuff alts   `thenTE` \ palts  ->
     ppr_decls_AbsC deflt       `thenTE` \ pdeflt ->

-    returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
+    returnTE (maybe_vcat (pdisc:pdeflt:palts))

   where
     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
 
   where
     ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
 

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

   = ppr_decls_AbsC absC
 
   = ppr_decls_AbsC absC
 

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

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

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

   where
     info_lbl = infoTableLabelFromCI cl_info
 
   where
     info_lbl = infoTableLabelFromCI cl_info
 

-ppr_decls_AbsC (COpStmt        results _ args _ _) = ppr_decls_Amodes (results ++ args)
-ppr_decls_AbsC (CSimultaneous abc)         = ppr_decls_AbsC abc
+ppr_decls_AbsC (CMachOpStmt res        _ args _) = ppr_decls_Amodes (res : args)
+ppr_decls_AbsC (COpStmt        results _ args _) = ppr_decls_Amodes (results ++ args)
+
+ppr_decls_AbsC (CSimultaneous abc)       = ppr_decls_AbsC abc
+
+ppr_decls_AbsC (CSequential abcs) 
+  = mapTE ppr_decls_AbsC abcs  `thenTE` \ t_and_e_s ->
+    returnTE (maybe_vcat t_and_e_s)
+
+ppr_decls_AbsC (CCheck             _ amodes code) = 
+     ppr_decls_Amodes amodes `thenTE` \p1 ->
+     ppr_decls_AbsC code     `thenTE` \p2 ->
+     returnTE (maybe_vcat [p1,p2])

 
 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 
 
 ppr_decls_AbsC (CMacroStmt         _ amodes)   = ppr_decls_Amodes amodes
 

@@ -1275,48 +1624,45 @@ ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)   = ppr_decls_Amodes [] -- *****!!!
   -- no real reason to, anyway.
 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)  = ppr_decls_Amodes amodes
 
   -- no real reason to, anyway.
 ppr_decls_AbsC (CCallProfCCMacro    _ amodes)  = ppr_decls_Amodes amodes
 

-ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
+ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes)

        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 
        -- ToDo: strictly speaking, should chk "cost_centre" amode
   = ppr_decls_Amodes amodes
 

-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
-  = ppr_decls_Amodes [entry_lbl, upd_lbl]      `thenTE` \ p1 ->
-    ppr_decls_AbsC slow                                `thenTE` \ p2 ->
-    (case maybe_fast of
-       Nothing   -> returnTE (Nothing, Nothing)
-       Just fast -> ppr_decls_AbsC fast)       `thenTE` \ p3 ->
-    returnTE (maybe_uppAboves [p1, p2, p3])
+ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
+  = ppr_decls_Amodes [entry_lbl]               `thenTE` \ p1 ->
+    ppr_decls_AbsC entry                       `thenTE` \ p2 ->
+    returnTE (maybe_vcat [p1, p2])

   where
   where

-    entry_lbl = CLbl slow_lbl CodePtrRep
-    slow_lbl    = case (nonemptyAbsC slow) of
-                   Nothing -> mkErrorStdEntryLabel
-                   Just _  -> entryLabelFromCI cl_info
-
-ppr_decls_AbsC (CRetVector label maybe_amodes absC)
-  = ppr_decls_Amodes (catMaybes maybe_amodes)  `thenTE` \ p1 ->
-    ppr_decls_AbsC   absC                      `thenTE` \ p2 ->
-    returnTE (maybe_uppAboves [p1, p2])
-
-ppr_decls_AbsC (CRetUnVector   _ amode)  = ppr_decls_Amode amode
-ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
+    entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
+
+ppr_decls_AbsC (CSRT _ closure_lbls)
+  = mapTE labelSeenTE closure_lbls             `thenTE` \ seen ->
+    returnTE (Nothing, 
+             if and seen then Nothing
+               else Just (vcat [ pprExternDecl True{-in SRT decl-} l
+                               | (l,False) <- zip closure_lbls seen ]))
+
+ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
+ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CModuleInitBlock _ _ code)   = ppr_decls_AbsC code
+
+ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)

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

-ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
+ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
+ppr_decls_Amode (CVal  (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
+ppr_decls_Amode (CAddr (CIndex base offset _))   = ppr_decls_Amodes [base,offset]

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

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

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

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

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

--- CCharLike may have be arbitrary value -- may have decls
-ppr_decls_Amode (CCharLike char)
-  = ppr_decls_Amode char
+-- CCharLike too
+ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)

 
 -- now, the only place where we actually print temps/externs...
 ppr_decls_Amode (CTemp uniq kind)
 
 -- now, the only place where we actually print temps/externs...
 ppr_decls_Amode (CTemp uniq kind)

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

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

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

-ppr_decls_Amode (CLbl label kind)
-  = labelSeenTE label `thenTE` \ label_seen ->
-    returnTE (Nothing,
-             if label_seen then Nothing else Just (pprExternDecl label kind))
-
-{- WRONG:
-ppr_decls_Amode (CUnVecLbl direct vectored)
-  = labelSeenTE direct   `thenTE` \ dlbl_seen ->
-    labelSeenTE vectored `thenTE` \ vlbl_seen ->
-    let
-       ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
-       vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
-    in
-    returnTE (Nothing,
-               if (dlbl_seen || not (needsCDecl direct)) &&
-                  (vlbl_seen || not (needsCDecl vectored)) then Nothing
-               else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
--}
-
-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 uppNil else-} pprExternDecl direct CodePtrRep
-       vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
-    in
+ppr_decls_Amode (CLbl lbl kind)
+  = labelSeenTE lbl `thenTE` \ label_seen ->

     returnTE (Nothing,
     returnTE (Nothing,

-               if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
-                  ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
-               else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
-
-ppr_decls_Amode (CTableEntry base index _)
-  = ppr_decls_Amode base    `thenTE` \ p1 ->
-    ppr_decls_Amode index   `thenTE` \ p2 ->
-    returnTE (maybe_uppAboves [p1, p2])
+             if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))

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

@@ -1375,19 +1687,118 @@ ppr_decls_Amode (CMacroExpr _ _ amodes)
 ppr_decls_Amode other = returnTE (Nothing, Nothing)
 
 
 ppr_decls_Amode other = returnTE (Nothing, Nothing)
 
 

-maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
-maybe_uppAboves ps
+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  ->
     case (catMaybes es)        of { real_es  ->
   = case (unzip ps)    of { (ts, es) ->
     case (catMaybes ts)        of { real_ts  ->
     case (catMaybes es)        of { real_es  ->

-    (if (null real_ts) then Nothing else Just (uppAboves real_ts),
-     if (null real_es) then Nothing else Just (uppAboves real_es))
+    (if (null real_ts) then Nothing else Just (vcat real_ts),
+     if (null real_es) then Nothing else Just (vcat real_es))

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

-ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
+ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)

 ppr_decls_Amodes amodes
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
 ppr_decls_Amodes amodes
   = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->

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

 \end{code}
 \end{code}