X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=2793d0f758af833a5b048f016eb4917a1091a2d1;hb=5cd3527da623a25b9ace2995f9d2e7f6c90c611f;hp=d98048c0b4f6445a7752a85d17f7e5d940fe60aa;hpb=567b2505b2d3d5874f3bf3641fd8d82b3207ea94;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index d98048c..2793d0f 100644 --- 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 ( callConvAttribute ) +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute ) import CLabel ( externallyVisibleCLabel, needsCDecl, pprCLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, @@ -38,28 +38,28 @@ 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 ) import Name ( NamedThing(..) ) -import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId ) +import DataCon ( dataConWrapId ) import Maybes ( maybeToBool, catMaybes ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, - PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep ) +import PrimOp ( primOpNeedsWrapper ) +import ForeignCall ( ForeignCall(..) ) +import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) import SMRep ( pprSMRep ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) -import StgSyn ( SRT(..) ) -import BitSet ( intBS ) +import StgSyn ( StgOp(..) ) +import BitSet ( BitSet, intBS ) import Outputable +import GlaExts import Util ( nOfThem ) import ST -import MutableArray infixr 9 `thenTE` \end{code} @@ -213,10 +213,10 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) -pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _ - = pprCCall ccall args results vol_regs +pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _ + = pprFCall fcall uniq args results vol_regs -pprAbsC stmt@(COpStmt results op args 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 @@ -239,7 +239,7 @@ pprAbsC stmt@(COpStmt results op args vol_regs) _ the_op where ppr_op_call results args - = hcat [ pprPrimOp op, lparen, + = 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)), @@ -258,14 +258,11 @@ pprAbsC stmt@(CSRT lbl closures) c } pprAbsC stmt@(CBitmap lbl mask) c - = vcat [ - hcat [ ptext SLIT("BITMAP"), lparen, - pprCLabel lbl, comma, - int (length mask), - rparen ], - hcat (punctuate comma (map (int.intBS) mask)), - ptext SLIT("}};") - ] + = pp_bitmap_switch mask semi $ + hcat [ ptext SLIT("BITMAP"), lparen, + pprCLabel lbl, comma, + int (length mask), comma, + pp_bitmap mask, rparen ] pprAbsC (CSimultaneous abs_c) c = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] @@ -284,7 +281,7 @@ pprAbsC (CCallProfCtrMacro op as) _ pprAbsC (CCallProfCCMacro op as) _ = hcat [ptext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _ +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 @@ -322,25 +319,25 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar -} fun_nm - | is_tdef = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty) - | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty + | is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty) + | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty ccall_fun_ty = case op_str of - DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u - StaticTarget x -> pprCLabelString x + DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq + StaticTarget x -> pprCLabelString x ccall_res_ty = case non_void_results of [] -> ptext SLIT("void") - [amode] -> text (showPrimRep (getAmodeRep amode)) + [amode] -> ppr (getAmodeRep amode) _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty" ccall_decl_ty_args | is_tdef = tail ccall_arg_tys | otherwise = ccall_arg_tys - ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args + ccall_arg_tys = map (ppr . getAmodeRep) non_void_args -- the first argument will be the "I/O world" token (a VoidRep) -- all others should be non-void @@ -418,16 +415,18 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ where rep = getAmodeRep 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 + upd_reqd = closureUpdReqd cl_info + + padding_wds + | not upd_reqd = [] + | otherwise = case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed -> + nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s + -- always have a static link field, it's used to save the closure's + -- info pointer when we're reverting CAFs (see comment in Storage.c) static_link_field - | staticClosureNeedsLink cl_info = [mkIntCLit 0] - | otherwise = [] + | upd_reqd || staticClosureNeedsLink cl_info = [mkIntCLit 0] + | otherwise = [] pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ = vcat [ @@ -477,8 +476,11 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ is_constr = maybeToBool maybe_tag (Just tag) = maybe_tag - needs_srt = infoTblNeedsSRT cl_info - srt = getSRTInfo cl_info + srt = closureSRT cl_info + needs_srt = case srt of + NoC_SRT -> False + other -> True + size = closureNonHdrSize cl_info @@ -498,8 +500,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 ( @@ -518,7 +520,7 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _ pprCLabel entry_lbl, comma, pp_liveness liveness, comma, -- bitmap pp_srt_info srt, -- SRT - ptext type_str, comma, -- closure type + closure_type, comma, -- closure type ppLocalness info_lbl, comma, -- info table storage class ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class int 0, comma, @@ -527,15 +529,15 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _ pp_code ] where - info_lbl = mkReturnInfoLabel uniq - entry_lbl = mkReturnPtLabel uniq + info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq - pp_code = let stuff = CCodeBlock entry_lbl code in - pprAbsC stuff (costs stuff) + pp_code = let stuff = CCodeBlock entry_lbl code in + pprAbsC stuff (costs stuff) - type_str = case liveness of - LvSmall _ -> SLIT("RET_SMALL") - LvLarge _ -> SLIT("RET_BIG") + closure_type = pp_liveness_switch liveness + (ptext SLIT("RET_SMALL")) + (ptext SLIT("RET_BIG")) pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> @@ -547,7 +549,7 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ pprCLabel lbl, comma, pp_liveness liveness, comma, -- bitmap liveness mask pp_srt_info srt, -- SRT - ptext type_str, comma, + closure_type, comma, ppLocalness lbl, comma ], nest 2 (sep (punctuate comma (map ppr_item amodes))), @@ -559,9 +561,9 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ ppr_item item = (<>) (text "(F_) ") (ppr_amode item) size = length amodes - type_str = case liveness of - LvSmall _ -> SLIT("RET_VEC_SMALL") - LvLarge _ -> SLIT("RET_VEC_BIG") + closure_type = pp_liveness_switch liveness + (ptext SLIT("RET_VEC_SMALL")) + (ptext SLIT("RET_VEC_BIG")) pprAbsC stmt@(CModuleInitBlock lbl code) _ @@ -647,19 +649,12 @@ pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -has_srt (_, NoSRT) = False -has_srt _ = True - -pp_srt_info srt = - case srt of - (lbl, NoSRT) -> - hcat [ int 0, comma, - int 0, comma, - int 0, comma ] - (lbl, SRT off len) -> - hcat [ pprCLabel lbl, comma, - int off, comma, - int len, comma ] +pp_srt_info NoC_SRT = hcat [ int 0, comma, + int 0, comma, + int 0, comma ] +pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma, + int off, comma, + int len, comma ] \end{code} \begin{code} @@ -776,13 +771,13 @@ 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 call@(CCall op_str is_asm may_gc cconv) args results vol_regs +pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs = vcat [ char '{', declare_local_vars, -- local var for *result* vcat local_arg_decls, pp_save_context, - process_casm local_vars pp_non_void_args casm_str, + process_casm local_vars pp_non_void_args call_str, pp_restore_context, assign_results, char '}' @@ -790,15 +785,15 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs where (pp_saves, pp_restores) = ppr_vol_regs vol_regs (pp_save_context, pp_restore_context) - | may_gc = ( text "{ I_ id; SUSPEND_THREAD(id);" - , text "RESUME_THREAD(id);}" - ) + | playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);" + , text "RESUME_THREAD(id);}" + ) | otherwise = ( pp_basic_saves $$ pp_saves, pp_basic_restores $$ pp_restores) non_void_args = let nvas = init args - in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode 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 @@ -815,16 +810,17 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs (declare_local_vars, local_vars, assign_results) = ppr_casm_results non_void_results - 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 + call_str = case target of + CasmTarget str -> _UNPK_ str + StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args + DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) - fun_name = case op_str of - DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0") - StaticTarget st -> pprCLabelString st + ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] + dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0") + - ccall_str = showSDoc + -- Remainder only used for ccall + mk_ccall_str fun_name ccall_fun_args = showSDoc (hcat [ if null non_void_results then empty @@ -833,12 +829,6 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs hcat (punctuate comma ccall_fun_args), text "));" ]) - - ccall_fun_args | isDynamicTarget op_str = tail ccall_args - | otherwise = ccall_args - - ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] - \end{code} If the argument is a heap object, we need to reach inside and pull out @@ -1193,15 +1183,37 @@ cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") %************************************************************************ \begin{code} +pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc +pp_bitmap_switch ([ ]) small large = small +pp_bitmap_switch ([_ ]) small large = small +pp_bitmap_switch ([_,_]) small large = hcat + [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen] +pp_bitmap_switch (_ ) small large = large + +pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc +pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask + +pp_bitset :: BitSet -> SDoc +pp_bitset s + | i < -1 = int (i + 1) <> text "-1" + | otherwise = int i + where i = intBS s + +pp_bitmap :: [BitSet] -> SDoc +pp_bitmap [] = int 0 +pp_bitmap ss = hcat (punctuate delayed_comma (bundle ss)) where + delayed_comma = hcat [space, ptext SLIT("COMMA"), space] + bundle [] = [] + bundle [s] = [hcat bitmap32] + where bitmap32 = [ptext SLIT("BITMAP32"), lparen, + pp_bitset s, rparen] + bundle (s1:s2:ss) = hcat bitmap64 : bundle ss + where bitmap64 = [ptext SLIT("BITMAP64"), lparen, + pp_bitset s1, comma, pp_bitset s2, rparen] + pp_liveness :: Liveness -> SDoc -pp_liveness lv = - case lv of - LvLarge lbl -> char '&' <> pprCLabel lbl - LvSmall mask -- Avoid gcc bug when printing minInt - | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1" - | otherwise -> int bitmap_int - where - bitmap_int = intBS mask +pp_liveness (Liveness lbl mask) + = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl) \end{code} %************************************************************************ @@ -1266,9 +1278,9 @@ pprMagicId BaseReg = ptext SLIT("BaseReg") pprMagicId (VanillaReg pk n) = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n)) -pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n)) -pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n)) +pprMagicId (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 Su = ptext SLIT("Su") pprMagicId SpLim = ptext SLIT("SpLim") @@ -1277,8 +1289,8 @@ pprMagicId HpLim = ptext SLIT("HpLim") pprMagicId CurCostCentre = ptext SLIT("CCCS") pprMagicId VoidReg = panic "pprMagicId:VoidReg!" -pprVanillaReg :: FAST_INT -> SDoc -pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) +pprVanillaReg :: Int# -> SDoc +pprVanillaReg n = char 'R' <> int (I# n) pprUnionTag :: PrimRep -> SDoc @@ -1289,8 +1301,11 @@ 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 Int32Rep = char 'i' +pprUnionTag Word32Rep = char 'w' pprUnionTag AddrRep = char 'a' pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" @@ -1299,11 +1314,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} @@ -1476,7 +1493,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre) 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 (CSimultaneous abc) = ppr_decls_AbsC abc ppr_decls_AbsC (CCheck _ amodes code) = ppr_decls_Amodes amodes `thenTE` \p1 -> @@ -1534,9 +1551,8 @@ ppr_decls_Amode (CLit _) = 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)