)
import Constants ( mIN_UPD_SIZE )
-import CallConv ( CallConv, callConvAttribute )
+import CallConv ( callConvAttribute )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
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 Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
+ PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import BitSet ( intBS )
import Outputable
import Util ( nOfThem )
-import Addr ( Addr )
import ST
import MutableArray
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.
-- 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
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)),
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}
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
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
| 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, pprCCallOp 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 =
[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 [
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..]
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
= 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}
ppr_amode (CLit lit) = pprBasicLit lit
-ppr_amode (CLitLit str _) = ptext str
-
ppr_amode (CJoinPoint _)
= panic "ppr_amode: CJoinPoint"
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")
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'
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)
projects / ghc-hetmet.git / blobdiff