)
import Constants ( mIN_UPD_SIZE )
-import CallConv ( callConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprCCallOp,
- PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
+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 Util ( nOfThem, lengthExceeds, listLengthCmp )
import ST
-- 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
}
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("}}")]
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
-}
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
-- should ignore and a (possibly void) result.
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (length nvrs <= 1) nvrs
+ in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
pprAbsC (CCodeBlock lbl abs_C) _
= if not (maybeToBool(nonemptyAbsC abs_C)) then
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
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,
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) ->
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))),
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) _
\end{code}
\begin{code}
-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}
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 '}'
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
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (length nvrs <= 1) nvrs
+ in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
(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
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
in
case (read_int other) of
[(num,css)] ->
- if 0 <= num && num < length args
+ 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")
%************************************************************************
\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}
%************************************************************************
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?"
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 ->
projects / ghc-hetmet.git / blobdiff