[project @ 2000-05-11 11:54:56 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 4c147c4..c90b9b4 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -38,14 +38,15 @@ import CmdLineOpts  ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
 import CostCentre      ( pprCostCentreDecl, pprCostCentreStackDecl )
 
 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings                ( stringToC )
+import CStrings                ( stringToC, pprCLabelString )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import Literal         ( Literal(..) )
 import TyCon           ( tyConDataCons )
 import Name            ( NamedThing(..) )
 import DataCon         ( DataCon{-instance NamedThing-}, dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )
-import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp          ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
+                         PrimOp(..), CCall(..), CCallTarget(..) )
 import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
 import SMRep           ( pprSMRep )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
@@ -328,7 +329,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar
      ccall_fun_ty = 
         case op_str of
          DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
-         StaticTarget x  -> ptext x
+         StaticTarget x  -> pprCLabelString x
 
      ccall_res_ty = 
        case non_void_results of
@@ -345,7 +346,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar
       -- the first argument will be the "I/O world" token (a VoidRep)
       -- all others should be non-void
      non_void_args =
-       let nvas = tail args
+       let nvas = init args
        in ASSERT (all non_void nvas) nvas
 
       -- there will usually be two results: a (void) state which we
@@ -360,13 +361,14 @@ pprAbsC (CCodeBlock lbl abs_C) _
     else
     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [
-        char ' ',
+        empty,
+       pp_exts, 
        hcat [text (if (externallyVisibleCLabel lbl)
                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),
                   pprCLabel lbl, text ") {"],
 
-       pp_exts, pp_temps,
+       pp_temps,
 
        nest 8 (ptext SLIT("FB_")),
        nest 8 (pprAbsC abs_C (costs abs_C)),
@@ -598,16 +600,14 @@ ppLocalnessMacro include_dyn_prefix clabel =
   where
    is_visible = externallyVisibleCLabel clabel
    label_type = labelType clabel
-   is_dynamic = labelDynamic clabel
 
    visiblity_prefix
      | is_visible = char 'E'
      | otherwise  = char 'I'
 
    dyn_prefix
-     | not include_dyn_prefix = empty
-     | is_dynamic            = char 'D'
-     | otherwise             = empty
+     | include_dyn_prefix && labelDynamic clabel = char 'D'
+     | otherwise                                = empty
 
 \end{code}
 
@@ -777,7 +777,7 @@ Amendment to the above: if we can GC, we have to:
   that the runtime check that PerformGC is being used sensibly will work.
 
 \begin{code}
-pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
   = vcat [
       char '{',
       declare_local_vars,   -- local var for *result*
@@ -797,10 +797,11 @@ pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
        | otherwise = ( pp_basic_saves $$ pp_saves,
                        pp_basic_restores $$ pp_restores)
 
-    non_void_args =
-       let nvas = tail args
-       in ASSERT (all non_void nvas) nvas
-    -- the first argument will be the "I/O world" token (a VoidRep)
+    non_void_args = 
+       let nvas = init args
+       in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+       nvas
+    -- the last argument will be the "I/O world" token (a VoidRep)
     -- all others should be non-void
 
     non_void_results =
@@ -954,7 +955,7 @@ process_casm results args string = process results args string
   process []    _ "" = empty
   process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ 
                              string ++ 
-                             "\"\n(Try changing result type to PrimIO ()\n")
+                             "\"\n(Try changing result type to IO ()\n")
 
   process ress args ('%':cs)
     = case cs of
@@ -1293,7 +1294,7 @@ pprUnionTag AddrRep               = char 'a'
 pprUnionTag FloatRep           = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
-pprUnionTag StablePtrRep       = char 'i'
+pprUnionTag StablePtrRep       = char 'p'
 pprUnionTag StableNameRep      = char 'p'
 pprUnionTag WeakPtrRep         = char 'p'
 pprUnionTag ForeignObjRep      = char 'p'