[project @ 2000-10-12 13:11:45 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 f3dd000..2ad4595 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -26,19 +26,19 @@ import AbsCUtils    ( getAmodeRep, nonemptyAbsC,
                        )
 
 import Constants       ( mIN_UPD_SIZE )
-import CallConv                ( CallConv, callConvAttribute )
-import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
+import CallConv                ( callConvAttribute )
+import CLabel          ( externallyVisibleCLabel,
                          needsCDecl, pprCLabel,
                          mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
-                         mkClosureLabel,
+                         mkClosureLabel, 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(..) )
-import CStrings                ( stringToC, pprCLabelString )
+import CStrings                ( pprStringInCStyle, pprCLabelString )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import Literal         ( Literal(..) )
 import TyCon           ( tyConDataCons )
@@ -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
@@ -499,8 +498,8 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
 
     type_str = pprSMRep (closureSMRep cl_info)
 
-    pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
-    pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
+    pp_descr = pprStringInCStyle cl_descr
+    pp_type  = pprStringInCStyle (closureTypeDescr cl_info)
 
 pprAbsC stmt@(CClosureTbl tycon) _
   = vcat (
@@ -813,36 +812,17 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
     (local_arg_decls, pp_non_void_args)
       = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
 
-    ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
-
-    ccall_res_ty = 
-       case non_void_results of
-          []       -> ptext SLIT("void")
-         [amode]  -> text (showPrimRep (getAmodeRep amode))
-         _        -> panic "pprCCall: ccall_res_ty"
-
-    ccall_fun_ty = 
-       ptext SLIT("_ccall_fun_ty") <>
-       case op_str of
-         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 +834,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..]
 
@@ -1157,14 +1136,11 @@ ppr_amode (CIntLike int)
 
 ppr_amode (CLit lit) = pprBasicLit lit
 
-ppr_amode (CLitLit str _) = ptext str
-
 ppr_amode (CJoinPoint _)
   = panic "ppr_amode: CJoinPoint"
 
 ppr_amode (CMacroExpr pk macro as)
-  = parens (pprPrimKind pk) <> 
-    parens (ptext (cExprMacroText macro) <> 
+  = parens (ptext (cExprMacroText macro) <> 
            parens (hcat (punctuate comma (map pprAmode as))))
 \end{code}
 
@@ -1173,6 +1149,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")
@@ -1185,6 +1162,7 @@ cStmtMacroText UPDATE_SU_FROM_UPD_FRAME   = SLIT("UPDATE_SU_FROM_UPD_FRAME")
 cStmtMacroText SET_TAG                 = SLIT("SET_TAG")
 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")
@@ -1299,7 +1277,7 @@ pprMagicId HpLim              = ptext SLIT("HpLim")
 pprMagicId CurCostCentre           = ptext SLIT("CCCS")
 pprMagicId VoidReg                 = panic "pprMagicId:VoidReg!"
 
-pprVanillaReg :: FAST_INT -> SDoc
+pprVanillaReg :: FastInt -> SDoc
 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
 
 pprUnionTag :: PrimRep -> SDoc
@@ -1311,6 +1289,7 @@ pprUnionTag RetRep                = char 'p'
 pprUnionTag CostCentreRep      = panic "pprUnionTag:CostCentre?"
 
 pprUnionTag CharRep            = char 'c'
+pprUnionTag Int8Rep            = ptext SLIT("i8")
 pprUnionTag IntRep             = char 'i'
 pprUnionTag WordRep            = char 'w'
 pprUnionTag AddrRep            = char 'a'
@@ -1321,11 +1300,13 @@ pprUnionTag StablePtrRep        = char 'p'
 pprUnionTag StableNameRep      = char 'p'
 pprUnionTag WeakPtrRep         = char 'p'
 pprUnionTag ForeignObjRep      = char 'p'
+pprUnionTag PrimPtrRep         = char 'p'
 
 pprUnionTag ThreadIdRep                = char 't'
 
 pprUnionTag ArrayRep           = char 'p'
 pprUnionTag ByteArrayRep       = char 'b'
+pprUnionTag BCORep             = char 'p'
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}
@@ -1530,7 +1511,7 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
                    Nothing -> mkErrorStdEntryLabel
                    Just _  -> entryLabelFromCI cl_info
 
-ppr_decls_AbsC (CSRT lbl closure_lbls)
+ppr_decls_AbsC (CSRT _ closure_lbls)
   = mapTE labelSeenTE closure_lbls             `thenTE` \ seen ->
     returnTE (Nothing, 
              if and seen then Nothing
@@ -1552,14 +1533,12 @@ 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)
 
--- 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)