[project @ 2000-07-06 20:50:37 by panne]

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

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 8996adf..ab2aa34 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -26,7 +26,7 @@ import AbsCUtils      ( getAmodeRep, nonemptyAbsC,
                        )
 
 import Constants       ( mIN_UPD_SIZE )
-import CallConv                ( CallConv, callConvAttribute )
+import CallConv                ( callConvAttribute )
 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
                          needsCDecl, pprCLabel,
                          mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
@@ -34,7 +34,7 @@ import CLabel         ( externallyVisibleCLabel, mkErrorStdEntryLabel,
                          CLabel, CLabelType(..), labelType, labelDynamic
                        )
 
-import CmdLineOpts     ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
+import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
 import CostCentre      ( pprCostCentreDecl, pprCostCentreStackDecl )
 
 import Costs           ( costs, addrModeCosts, CostRes(..), Side(..) )
@@ -46,7 +46,7 @@ import Name           ( NamedThing(..) )
 import DataCon         ( DataCon{-instance NamedThing-}, dataConWrapId )
 import Maybes          ( maybeToBool, catMaybes )
 import PrimOp          ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
-                         PrimOp(..), CCall(..), CCallTarget(..) )
+                         PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
 import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
 import SMRep           ( pprSMRep )
 import Unique          ( pprUnique, Unique{-instance NamedThing-} )
@@ -57,7 +57,6 @@ import StgSyn         ( SRT(..) )
 import BitSet          ( intBS )
 import Outputable
 import Util            ( nOfThem )
-import Addr            ( Addr )
 
 import ST
 import MutableArray
@@ -151,7 +150,7 @@ pprAbsC (CReturn am return_info)  c
    mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
                       x, rparen ]
 
-pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
+pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")
 
 -- we optimise various degenerate cases of CSwitches.
 
@@ -821,28 +820,17 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
          [amode]  -> text (showPrimRep (getAmodeRep amode))
          _        -> panic "pprCCall: ccall_res_ty"
 
-    ccall_fun_ty = 
-       ptext SLIT("_ccall_fun_ty") <>
-       case op_str of
-         DynamicTarget u -> ppr u
-        _               -> empty
-
     (declare_local_vars, local_vars, assign_results)
       = ppr_casm_results non_void_results
 
-    (StaticTarget asm_str) = op_str
-    is_dynamic = 
-       case op_str of
-         StaticTarget _  -> False
-        DynamicTarget _ -> True
-
     casm_str = if is_asm then _UNPK_ asm_str else ccall_str
+    StaticTarget asm_str = op_str      -- Must be static if it's a casm
 
     -- Remainder only used for ccall
 
-    fun_name 
-      | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
-      | otherwise  = ptext asm_str
+    fun_name = case op_str of
+                DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+                StaticTarget st -> pprCLabelString st
 
     ccall_str = showSDoc
        (hcat [
@@ -854,9 +842,8 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
                text "));"
        ])
 
-    ccall_fun_args
-     | is_dynamic = tail ccall_args
-     | otherwise  = ccall_args
+    ccall_fun_args | isDynamicTarget op_str = tail ccall_args
+                  | otherwise              = ccall_args
 
     ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
 
@@ -1108,6 +1095,29 @@ pprAmode amode
   = ppr_amode amode
 \end{code}
 
+When we have an indirection through a CIndex, we have to be careful to
+get the type casts right.  
+
+this amode:
+
+       CVal (CIndex kind1 base offset) kind2
+
+means (in C speak): 
+       
+       *(kind2 *)((kind1 *)base + offset)
+
+That is, the indexing is done in units of kind1, but the resulting
+amode has kind2.
+
+\begin{code}
+ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
+  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
+       (pp_reg, Nothing)     -> panic "ppr_amode: CIndex"
+       (pp_reg, Just offset) -> 
+          hcat [ char '*', parens (pprPrimKind kind <> char '*'),
+                 parens (pp_reg <> char '+' <> offset) ]
+\end{code}
+
 Now the rest of the cases for ``workhorse'' @ppr_amode@:
 
 \begin{code}
@@ -1134,8 +1144,6 @@ ppr_amode (CIntLike int)
 
 ppr_amode (CLit lit) = pprBasicLit lit
 
-ppr_amode (CLitLit str _) = ptext str
-
 ppr_amode (CJoinPoint _)
   = panic "ppr_amode: CJoinPoint"
 
@@ -1150,6 +1158,7 @@ cExprMacroText ENTRY_CODE                 = SLIT("ENTRY_CODE")
 cExprMacroText ARG_TAG                 = SLIT("ARG_TAG")
 cExprMacroText GET_TAG                 = SLIT("GET_TAG")
 cExprMacroText UPD_FRAME_UPDATEE       = SLIT("UPD_FRAME_UPDATEE")
+cExprMacroText CCS_HDR                 = SLIT("CCS_HDR")
 
 cStmtMacroText ARGS_CHK                        = SLIT("ARGS_CHK")
 cStmtMacroText ARGS_CHK_LOAD_NODE      = SLIT("ARGS_CHK_LOAD_NODE")
@@ -1294,7 +1303,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'
@@ -1529,7 +1538,6 @@ ppr_decls_Amode (CVal _ _)        = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CAddr _)      = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CReg _)       = returnTE (Nothing, Nothing)
 ppr_decls_Amode (CLit _)       = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLitLit _ _)  = returnTE (Nothing, Nothing)
 
 -- CIntLike must be a literal -- no decls
 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)