import IO ( Handle )
+import PrimRep
import AbsCSyn
import ClosureInfo
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import Constants ( mIN_UPD_SIZE )
-import CallConv ( CallConv, callConvAttribute )
-import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute )
+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 )
+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, PrimOp(..), CCall(..), CCallTarget(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
+import PrimOp ( primOpNeedsWrapper )
+import MachOp ( MachOp(..) )
+import ForeignCall ( ForeignCall(..) )
+import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize )
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 Util ( nOfThem )
-import Addr ( Addr )
+import GlaExts
+import Util ( lengthExceeds, listLengthCmp )
import ST
-import MutableArray
infixr 9 `thenTE`
\end{code}
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.
-- 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
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)),
-- primop macros do their own casting of result;
-- hence we can toss the provided cast...
+-- NEW CASES FOR EXPANDED PRIMOPS
+
+pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
+ = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
+ in
+ case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+ saves $$
+ hcat (
+ [ppr_amode res, equals]
+ ++ (if prefix_fn
+ then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
+ else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
+ ++ [semi]
+ )
+ $$ restores
+ }
+
+pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
+ = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+ saves $$
+ hcat [ppr_amode res, equals,
+ pprMachOp_for_C mop, parens (pprAmode arg1),
+ semi]
+ $$ restores
+ }
+
+pprAbsC stmt@(CSequential stuff) c
+ = vcat (map (flip pprAbsC c) stuff)
+
+-- end of NEW CASES FOR EXPANDED PRIMOPS
+
pprAbsC stmt@(CSRT lbl closures) c
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
pp_exts
}
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 -> ptext 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
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
-- 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
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)),
}
-pprAbsC (CInitHdr cl_info amode cost_centre) _
+pprAbsC (CInitHdr cl_info amode cost_centre size) _
= hcat [ ptext SLIT("SET_HDR_"), char '(',
ppr_amode amode, comma,
pprCLabelAddr info_lbl, comma,
- if_profiling (pprAmode cost_centre),
+ if_profiling (pprAmode cost_centre), comma,
+ if_profiling (int size),
pp_paren_semi ]
where
info_lbl = infoTableLabelFromCI cl_info
-pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
+
+pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
pp_exts,
ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
- nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
+ nest 2 (ppr_payload amodes),
ptext SLIT("};") ]
}
where
- info_lbl = infoTableLabelFromCI cl_info
+ closure_lbl = closureLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
ppr_payload ls = comma <+>
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
-
- static_link_field
- | staticClosureNeedsLink cl_info = [mkIntCLit 0]
- | otherwise = []
pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
= vcat [
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
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 (
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}
+-- Print a CMachOp in a way suitable for emitting via C.
+pprMachOp_for_C MO_Nat_Add = char '+'
+pprMachOp_for_C MO_Nat_Sub = char '-'
+pprMachOp_for_C MO_Nat_Eq = text "=="
+pprMachOp_for_C MO_Nat_Ne = text "!="
+
+pprMachOp_for_C MO_NatS_Ge = text ">="
+pprMachOp_for_C MO_NatS_Le = text "<="
+pprMachOp_for_C MO_NatS_Gt = text ">"
+pprMachOp_for_C MO_NatS_Lt = text "<"
+
+pprMachOp_for_C MO_NatU_Ge = text ">="
+pprMachOp_for_C MO_NatU_Le = text "<="
+pprMachOp_for_C MO_NatU_Gt = text ">"
+pprMachOp_for_C MO_NatU_Lt = text "<"
+
+pprMachOp_for_C MO_NatS_Mul = char '*'
+pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo"
+pprMachOp_for_C MO_NatS_Quot = char '/'
+pprMachOp_for_C MO_NatS_Rem = char '%'
+pprMachOp_for_C MO_NatS_Neg = char '-'
+
+pprMachOp_for_C MO_NatU_Mul = char '*'
+pprMachOp_for_C MO_NatU_Quot = char '/'
+pprMachOp_for_C MO_NatU_Rem = char '%'
+
+pprMachOp_for_C MO_Nat_And = text "&"
+pprMachOp_for_C MO_Nat_Or = text "|"
+pprMachOp_for_C MO_Nat_Xor = text "^"
+pprMachOp_for_C MO_Nat_Not = text "~"
+pprMachOp_for_C MO_Nat_Shl = text "<<"
+pprMachOp_for_C MO_Nat_Shr = text ">>"
+pprMachOp_for_C MO_Nat_Sar = text ">>"
+
+pprMachOp_for_C MO_32U_Eq = text "=="
+pprMachOp_for_C MO_32U_Ne = text "!="
+pprMachOp_for_C MO_32U_Ge = text ">="
+pprMachOp_for_C MO_32U_Le = text "<="
+pprMachOp_for_C MO_32U_Gt = text ">"
+pprMachOp_for_C MO_32U_Lt = text "<"
+
+pprMachOp_for_C MO_Dbl_Eq = text "=="
+pprMachOp_for_C MO_Dbl_Ne = text "!="
+pprMachOp_for_C MO_Dbl_Ge = text ">="
+pprMachOp_for_C MO_Dbl_Le = text "<="
+pprMachOp_for_C MO_Dbl_Gt = text ">"
+pprMachOp_for_C MO_Dbl_Lt = text "<"
+
+pprMachOp_for_C MO_Dbl_Add = text "+"
+pprMachOp_for_C MO_Dbl_Sub = text "-"
+pprMachOp_for_C MO_Dbl_Mul = text "*"
+pprMachOp_for_C MO_Dbl_Div = text "/"
+pprMachOp_for_C MO_Dbl_Pwr = text "pow"
+
+pprMachOp_for_C MO_Dbl_Sin = text "sin"
+pprMachOp_for_C MO_Dbl_Cos = text "cos"
+pprMachOp_for_C MO_Dbl_Tan = text "tan"
+pprMachOp_for_C MO_Dbl_Sinh = text "sinh"
+pprMachOp_for_C MO_Dbl_Cosh = text "cosh"
+pprMachOp_for_C MO_Dbl_Tanh = text "tanh"
+pprMachOp_for_C MO_Dbl_Asin = text "asin"
+pprMachOp_for_C MO_Dbl_Acos = text "acos"
+pprMachOp_for_C MO_Dbl_Atan = text "atan"
+pprMachOp_for_C MO_Dbl_Log = text "log"
+pprMachOp_for_C MO_Dbl_Exp = text "exp"
+pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt"
+pprMachOp_for_C MO_Dbl_Neg = text "-"
+
+pprMachOp_for_C MO_Flt_Add = text "+"
+pprMachOp_for_C MO_Flt_Sub = text "-"
+pprMachOp_for_C MO_Flt_Mul = text "*"
+pprMachOp_for_C MO_Flt_Div = text "/"
+pprMachOp_for_C MO_Flt_Pwr = text "pow"
+
+pprMachOp_for_C MO_Flt_Eq = text "=="
+pprMachOp_for_C MO_Flt_Ne = text "!="
+pprMachOp_for_C MO_Flt_Ge = text ">="
+pprMachOp_for_C MO_Flt_Le = text "<="
+pprMachOp_for_C MO_Flt_Gt = text ">"
+pprMachOp_for_C MO_Flt_Lt = text "<"
+
+pprMachOp_for_C MO_Flt_Sin = text "sin"
+pprMachOp_for_C MO_Flt_Cos = text "cos"
+pprMachOp_for_C MO_Flt_Tan = text "tan"
+pprMachOp_for_C MO_Flt_Sinh = text "sinh"
+pprMachOp_for_C MO_Flt_Cosh = text "cosh"
+pprMachOp_for_C MO_Flt_Tanh = text "tanh"
+pprMachOp_for_C MO_Flt_Asin = text "asin"
+pprMachOp_for_C MO_Flt_Acos = text "acos"
+pprMachOp_for_C MO_Flt_Atan = text "atan"
+pprMachOp_for_C MO_Flt_Log = text "log"
+pprMachOp_for_C MO_Flt_Exp = text "exp"
+pprMachOp_for_C MO_Flt_Sqrt = text "sqrt"
+pprMachOp_for_C MO_Flt_Neg = text "-"
+
+pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)"
+pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)"
+
+pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)"
+pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)"
+pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatP = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)"
+pprMachOp_for_C MO_NatU_to_NatP = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)"
+
+pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)"
+
+pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)"
+pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)"
+pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)"
+
+pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)"
+pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)"
+pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)"
+
+pprMachOp_for_C MO_8U_to_32U = text "(StgWord32)"
+pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)"
+
+
ppLocalness lbl
= if (externallyVisibleCLabel lbl)
then empty
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}
\end{code}
\begin{code}
+ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
+ppr_maybe_vol_regs Nothing
+ = (empty, empty)
+ppr_maybe_vol_regs (Just vrs)
+ = case ppr_vol_regs vrs of
+ (saves, restores)
+ -> (pp_basic_saves $$ saves,
+ pp_basic_restores $$ restores)
+
ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
ppr_vol_regs [] = (empty, empty)
\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}
-- ---------------------------------------------------------------------------
do_if_stmt discrim tag alt_code deflt c
- = case tag of
- -- This special case happens when testing the result of a comparison.
- -- We can just avoid some redundant clutter in the output.
- MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
- deflt alt_code
- (addrModeCosts discrim Rhs) c
- other -> let
- cond = hcat [ pprAmode discrim
- , ptext SLIT(" == ")
- , tcast
- , pprAmode (CLit tag)
- ]
- -- to be absolutely sure that none of the
- -- conversion rules hit, e.g.,
- --
- -- minInt is different to (int)minInt
- --
- -- in C (when minInt is a number not a constant
- -- expression which evaluates to it.)
- --
- tcast = case other of
- MachInt _ -> ptext SLIT("(I_)")
- _ -> empty
- in
- ppr_if_stmt cond
- alt_code deflt
- (addrModeCosts discrim Rhs) c
+ = let
+ cond = hcat [ pprAmode discrim
+ , ptext SLIT(" == ")
+ , tcast
+ , pprAmode (CLit tag)
+ ]
+ -- to be absolutely sure that none of the
+ -- conversion rules hit, e.g.,
+ --
+ -- minInt is different to (int)minInt
+ --
+ -- in C (when minInt is a number not a constant
+ -- expression which evaluates to it.)
+ --
+ tcast = case tag of
+ MachInt _ -> ptext SLIT("(I_)")
+ _ -> empty
+ in
+ ppr_if_stmt cond
+ alt_code deflt
+ (addrModeCosts discrim Rhs) c
ppr_if_stmt pp_pred then_part else_part discrim_costs c
= vcat [
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
+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
+
+ thread_macro_args = ppr_uniq_token <> comma <+>
+ text "rts" <> ppr (playThreadSafe safety)
+ ppr_uniq_token = text "tok_" <> ppr uniq
(pp_save_context, pp_restore_context)
- | may_gc = ( text "{ I_ id; SUSPEND_THREAD(id);"
- , text "RESUME_THREAD(id);}"
- )
+ | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
+ text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+ , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
+ )
| 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, 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.
(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
+ 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)
- casm_str = if is_asm then _UNPK_ asm_str else ccall_str
+ ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+ dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+
-- Remainder only used for ccall
-
- fun_name
- | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
- | otherwise = ptext asm_str
-
- ccall_str = showSDoc
+ 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
- | is_dynamic = 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
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
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}
pprAssign FloatRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign DoubleRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign Int64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign Word64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
\end{code}
Lastly, the question is: will the C compiler think the types of the
\begin{code}
pprAmode (CVal reg_rel FloatRep)
- = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel DoubleRep)
- = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Int64Rep)
- = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Word64Rep)
- = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
\end{code}
Next comes the case where there is some other cast need, and the
= 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 CBytesPerWord
+ = text "(sizeof(void*))"
+
+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}
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}
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")
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
+cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh")
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")
cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN")
\end{code}
+\begin{code}
+\end{code}
+
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
%************************************************************************
\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}
%************************************************************************
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")
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
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?"
-pprUnionTag StablePtrRep = char 'i'
+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}
ppr_decls_AbsC (CCodeBlock lbl absC)
= ppr_decls_AbsC absC
-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
+ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= labelSeenTE info_lbl `thenTE` \ label_seen ->
returnTE (Nothing,
where
info_lbl = infoTableLabelFromCI cl_info
+ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args)
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 (CSequential abcs)
+ = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s ->
+ returnTE (maybe_vcat t_and_e_s)
ppr_decls_AbsC (CCheck _ amodes code) =
ppr_decls_Amodes amodes `thenTE` \p1 ->
-- no real reason to, anyway.
ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
+ppr_decls_AbsC (CStaticClosure closure_info cost_centre amodes)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
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
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)
projects / ghc-hetmet.git / blobdiff