)
import Constants ( mIN_UPD_SIZE )
-import CallConv ( CallConv, callConvAttribute, cCallConv )
+import CallConv ( CallConv, callConvAttribute )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
- isReadOnly, needsCDecl, pprCLabel,
- mkReturnInfoLabel, mkReturnPtLabel,
- CLabel, CLabelType(..), labelType
+ needsCDecl, pprCLabel,
+ mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+ mkClosureLabel,
+ CLabel, CLabelType(..), labelType, labelDynamic
)
import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( stringToC )
+import CStrings ( stringToC, pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import Const ( Literal(..) )
+import Literal ( Literal(..) )
+import TyCon ( tyConDataCons )
+import Name ( NamedThing(..) )
+import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
+ PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
(hcat [text jmp_lit, target, pp_paren_semi ])
where
target = case return_info of
- DirectReturn -> hcat [char '(', pprAmode am, rparen]
+ DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
+ pprAmode am, rparen]
DynamicVectoredReturn am' -> mk_vector (pprAmode am')
StaticVectoredReturn n -> mk_vector (int n) -- Always positive
- mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
+ 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.
do_if_stmt discrim tag alt_code dc c
-- What problem is the re-ordering trying to solve ?
-pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
- (tag2@(MachInt i2 _), alt_code2)] deflt) c
+pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
+ (tag2@(MachInt i2), alt_code2)] deflt) c
| empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
= if (i1 == 0) then
do_if_stmt discrim tag1 alt_code1 alt_code2 c
-- 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 op@(CCallOp _ _ _ _) args vol_regs) _
- = pprCCall op args results vol_regs
+pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
+ = pprCCall ccall args results vol_regs
pprAbsC stmt@(COpStmt results op args vol_regs) _
= let
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
- case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
+ case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
vcat [ pp_saves,
the_op,
pp_restores
]
+ }
else
the_op
- }
where
ppr_op_call results args
= hcat [ pprPrimOp op, lparen,
$$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
<> ptext SLIT("};")
}
- where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
pprAbsC stmt@(CBitmap lbl mask) c
= vcat [
= hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
pprAbsC (CCheck macro as code) c
- = hcat [text (show macro), lparen,
+ = hcat [ptext (cCheckMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)), comma,
pprAbsC code c, pp_paren_semi
]
pprAbsC (CMacroStmt macro as) _
- = hcat [text (show macro), lparen,
+ = hcat [ptext (cStmtMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
pprAbsC (CCallProfCtrMacro op as) _
= hcat [ptext op, lparen,
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
- = hsep [ ptext SLIT("typedef")
+pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
+ = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
, parens (hsep (punctuate comma ccall_decl_ty_args))
] <> semi
where
- fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+ {-
+ In the non-casm case, to ensure that we're entering the given external
+ entry point using the correct calling convention, we have to do the following:
+
+ - When entering via a function pointer (the `dynamic' case) using the specified
+ calling convention, we emit a typedefn declaration attributed with the
+ calling convention to use together with the result and parameter types we're
+ assuming. Coerce the function pointer to this type and go.
+
+ - to enter the function at a given code label, we emit an extern declaration
+ for the label here, stating the calling convention together with result and
+ argument types we're assuming.
+
+ The C compiler will hopefully use this extern declaration to good effect,
+ reporting any discrepancies between our extern decl and any other that
+ may be in scope.
+
+ Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
+ the external function `foo' use the calling convention of the first `foo'
+ prototype it encounters (nor does it complain about conflicting attribute
+ declarations). The consequence of this is that you cannot override the
+ calling convention of `foo' using an extern declaration (you'd have to use
+ a typedef), but why you would want to do such a thing in the first place
+ is totally beyond me.
+
+ ToDo: petition the gcc folks to add code to warn about conflicting attribute
+ declarations.
+
+ -}
+
+ fun_nm
+ | is_tdef = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+ | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty
ccall_fun_ty =
case op_str of
- Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+ DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+ StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
- ccall_decl_ty_args = tail ccall_arg_tys
+ ccall_decl_ty_args
+ | is_tdef = tail ccall_arg_tys
+ | otherwise = ccall_arg_tys
+
ccall_arg_tys = map (text.showPrimRep.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
let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
-pprAbsC (CCodeBlock label abs_C) _
+pprAbsC (CCodeBlock lbl abs_C) _
= if not (maybeToBool(nonemptyAbsC abs_C)) then
- pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+ pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [
- hcat [text (if (externallyVisibleCLabel label)
+ empty,
+ pp_exts,
+ hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
else "IFN_("),
- pprCLabel label, text ") {"],
+ pprCLabel lbl, text ") {"],
- pp_exts, pp_temps,
+ pp_temps,
nest 8 (ptext SLIT("FB_")),
nest 8 (pprAbsC abs_C (costs abs_C)),
nest 8 (ptext SLIT("FE_")),
- char '}' ]
+ char '}',
+ char ' ' ]
}
-pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
+pprAbsC (CInitHdr cl_info amode cost_centre) _
= hcat [ ptext SLIT("SET_HDR_"), char '(',
- ppr_amode (CAddr reg_rel), comma,
+ ppr_amode amode, comma,
pprCLabelAddr info_lbl, comma,
if_profiling (pprAmode cost_centre),
pp_paren_semi ]
pprCLabel info_lbl, comma,
if_profiling (pprAmode cost_centre), comma,
ppLocalness closure_lbl, comma,
- ppLocalnessMacro info_lbl,
+ ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
- nest 2 (ppr_payload (amodes ++ padding_wds)),
+ nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
ptext SLIT("};") ]
}
where
where
rep = getAmodeRep item
- -- always at least one padding word: this is the static link field for
- -- the garbage collector.
padding_wds =
if not (closureUpdReqd cl_info) then
- [mkIntCLit 0]
+ []
else
- case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+ case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->
nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
+ static_link_field
+ | staticClosureNeedsLink cl_info = [mkIntCLit 0]
+ | otherwise = []
+
+pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
= vcat [
hcat [
ptext SLIT("INFO_TABLE"),
pprCLabel slow_lbl, comma,
pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
- ppLocalness info_lbl, comma,
- ppLocalnessMacro slow_lbl, comma,
+ ppLocalness info_lbl, comma,
+ ppLocalnessMacro True{-include dyn-} slow_lbl, comma,
if_profiling pp_descr, comma,
if_profiling pp_type,
is_constr = maybeToBool maybe_tag
(Just tag) = maybe_tag
- needs_srt = has_srt srt && needsSRT cl_info
+ needs_srt = infoTblNeedsSRT cl_info
+ srt = getSRTInfo cl_info
size = closureNonHdrSize cl_info
pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
+pprAbsC stmt@(CClosureTbl tycon) _
+ = vcat (
+ ptext SLIT("CLOSURE_TBL") <>
+ lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
+ punctuate comma (
+ map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
+ )
+ ) $$ ptext SLIT("};")
+
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
= vcat [
hcat [
pp_srt_info srt, -- SRT
ptext type_str, comma, -- closure type
ppLocalness info_lbl, comma, -- info table storage class
- ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
+ ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class
int 0, comma,
int 0, text ");"
],
LvSmall _ -> SLIT("RET_SMALL")
LvLarge _ -> SLIT("RET_BIG")
-pprAbsC stmt@(CRetVector label amodes srt liveness) _
- = vcat [
- pp_vector,
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+ vcat [
+ pp_exts,
hcat [
- ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
- lparen,
- pp_liveness liveness, comma, -- bitmap liveness mask
- pp_srt_info srt, -- SRT
- ptext type_str, -- or big, depending on the size
- -- of the liveness mask.
- rparen
- ],
- text "};"
+ ptext SLIT("VEC_INFO_") <> int size,
+ lparen,
+ pprCLabel lbl, comma,
+ pp_liveness liveness, comma, -- bitmap liveness mask
+ pp_srt_info srt, -- SRT
+ ptext type_str, comma,
+ ppLocalness lbl, comma
+ ],
+ nest 2 (sep (punctuate comma (map ppr_item amodes))),
+ text ");"
]
+ }
where
- pp_vector =
- case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [ppLocalness label,
- ptext SLIT(" vec_info_"), int size, space,
- pprCLabel label, text "= { {"
- ],
- nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
- ] }
-
ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
size = length amodes
LvLarge _ -> SLIT("RET_VEC_BIG")
+pprAbsC stmt@(CModuleInitBlock lbl code) _
+ = vcat [
+ ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
+ case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
+ pprAbsC code (costs code),
+ hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
+ ]
+
pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
\begin{code}
-ppLocalness label
- = (<>) static const
- where
- static = if (externallyVisibleCLabel label)
+ppLocalness lbl
+ = if (externallyVisibleCLabel lbl)
then empty
else ptext SLIT("static ")
- const = if not (isReadOnly label)
- then empty
- else ptext SLIT("const")
-- Horrible macros for declaring the types and locality of labels (see
-- StgMacros.h).
-ppLocalnessMacro clabel =
+ppLocalnessMacro include_dyn_prefix clabel =
hcat [
- char (if externallyVisibleCLabel clabel then 'E' else 'I'),
- case labelType clabel of
- InfoTblType -> ptext SLIT("I_")
- ClosureType -> ptext SLIT("C_")
- CodeType -> ptext SLIT("F_")
- DataType -> ptext SLIT("D_") <>
- if isReadOnly clabel
- then ptext SLIT("RO_")
- else empty
+ visiblity_prefix,
+ dyn_prefix,
+ case label_type of
+ ClosureType -> ptext SLIT("C_")
+ CodeType -> ptext SLIT("F_")
+ InfoTblType -> ptext SLIT("I_")
+ ClosureTblType -> ptext SLIT("CP_")
+ DataType -> ptext SLIT("D_")
]
+ where
+ is_visible = externallyVisibleCLabel clabel
+ label_type = labelType clabel
+
+ visiblity_prefix
+ | is_visible = char 'E'
+ | otherwise = char 'I'
+
+ dyn_prefix
+ | include_dyn_prefix && labelDynamic clabel = char 'D'
+ | otherwise = empty
+
\end{code}
\begin{code}
(($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
--- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
+-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- depending on the platform. (The "volatile regs" stuff handles all
-- other registers.) Just be *sure* BaseReg is OK before trying to do
-- anything else. The correct sequence of saves&restores are
-- encoded by the CALLER_*_SYSTEM macros.
-pp_basic_saves
- = vcat
- [ ptext SLIT("CALLER_SAVE_Base")
- , ptext SLIT("CALLER_SAVE_SYSTEM")
- ]
-
+pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM")
pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
\end{code}
\end{code}
\begin{code}
+pp_closure_lbl lbl
+ | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
+ | otherwise = char '&' <> pprCLabel lbl
+\end{code}
+
+\begin{code}
if_profiling pretty
= if opt_SccProfilingOn
then pretty
= 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)
+ MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
deflt alt_code
(addrModeCosts discrim Rhs) c
- other -> let
+ other -> let
cond = hcat [ pprAmode discrim
, ptext SLIT(" == ")
, tcast
-- in C (when minInt is a number not a constant
-- expression which evaluates to it.)
--
- tcast =
- case other of
- MachInt _ signed | signed -> ptext SLIT("(I_)")
- _ -> empty
+ tcast = case other of
+ MachInt _ -> ptext SLIT("(I_)")
+ _ -> empty
in
ppr_if_stmt cond
alt_code deflt
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall op@(CCallOp 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*
vcat local_arg_decls,
pp_save_context,
- declare_fun_extern, -- declare expected function type.
process_casm local_vars pp_non_void_args casm_str,
pp_restore_context,
assign_results,
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
- | may_gc = ( text "do { SaveThreadState();"
- , text "LoadThreadState();} while(0);"
+ | may_gc = ( 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 = 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 =
(local_arg_decls, pp_non_void_args)
= unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
-
- {-
- In the non-casm case, to ensure that we're entering the given external
- entry point using the correct calling convention, we have to do the following:
-
- - When entering via a function pointer (the `dynamic' case) using the specified
- calling convention, we emit a typedefn declaration attributed with the
- calling convention to use together with the result and parameter types we're
- assuming. Coerce the function pointer to this type and go.
-
- - to enter the function at a given code label, we emit an extern declaration
- for the label here, stating the calling convention together with result and
- argument types we're assuming.
-
- The C compiler will hopefully use this extern declaration to good effect,
- reporting any discrepancies between our extern decl and any other that
- may be in scope.
-
- Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
- the external function `foo' use the calling convention of the first `foo'
- prototype it encounters (nor does it complain about conflicting attribute
- declarations). The consequence of this is that you cannot override the
- calling convention of `foo' using an extern declaration (you'd have to use
- a typedef), but why you would want to do such a thing in the first place
- is totally beyond me.
-
- ToDo: petition the gcc folks to add code to warn about conflicting attribute
- declarations.
-
- -}
- declare_fun_extern
- | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
- | otherwise =
- hsep [ typedef_or_extern
- , ccall_res_ty
- , fun_nm
- , parens (hsep (punctuate comma ccall_decl_ty_args))
- ] <> semi
- where
- typedef_or_extern
- | is_dynamic = ptext SLIT("typedef")
- | otherwise = ptext SLIT("extern")
-
- fun_nm
- | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
- | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
-
- -- leave out function pointer
- ccall_decl_ty_args
- | is_dynamic = tail ccall_arg_tys
- | otherwise = ccall_arg_tys
-
ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
ccall_res_ty =
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
- ccall_fun_ty =
- ptext SLIT("_ccall_fun_ty") <>
- case op_str of
- Right u -> ppr u
- _ -> empty
-
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
- (Left asm_str) = op_str
- is_dynamic =
- case op_str of
- Left _ -> False
- _ -> 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 [
if null non_void_results
then empty
else text "%r = ",
- lparen, fun_name, lparen,
+ lparen, parens fun_name, lparen,
hcat (punctuate comma ccall_fun_args),
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
Lastly, the question is: will the C compiler think the types of the
two sides of the assignment match?
- We assume that the types will match
- if neither side is a @CVal@ addressing mode for any register
- which can point into the heap or B stack.
+ We assume that the types will match if neither side is a
+ @CVal@ addressing mode for any register which can point into
+ the heap or stack.
-Why? Because the heap and B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things
-of fixed type.
+Why? Because the heap and stack are used to store miscellaneous
+things, whereas the temporaries, registers, etc., are only used for
+things of fixed type.
\begin{code}
pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
= 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 (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode (CLbl label kind) = pprCLabelAddr label
+ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl
ppr_amode (CCharLike ch)
= hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
ppr_amode (CIntLike int)
= hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
-ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
- -- ToDo: are these *used* for anything?
-
ppr_amode (CLit lit) = pprBasicLit lit
ppr_amode (CLitLit str _) = ptext str
ppr_amode (CJoinPoint _)
= panic "ppr_amode: CJoinPoint"
-ppr_amode (CTableEntry base index kind)
- = hcat [text "((", pprPrimKind kind, text " *)(",
- ppr_amode base, text "))[(I_)(", ppr_amode index,
- ptext SLIT(")]")]
-
ppr_amode (CMacroExpr pk macro as)
- = parens (pprPrimKind pk) <+>
- parens (text (show macro) <>
+ = parens (pprPrimKind pk) <>
+ parens (ptext (cExprMacroText macro) <>
parens (hcat (punctuate comma (map pprAmode as))))
\end{code}
+\begin{code}
+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")
+
+cStmtMacroText ARGS_CHK = SLIT("ARGS_CHK")
+cStmtMacroText ARGS_CHK_LOAD_NODE = SLIT("ARGS_CHK_LOAD_NODE")
+cStmtMacroText UPD_CAF = SLIT("UPD_CAF")
+cStmtMacroText UPD_BH_UPDATABLE = SLIT("UPD_BH_UPDATABLE")
+cStmtMacroText UPD_BH_SINGLE_ENTRY = SLIT("UPD_BH_SINGLE_ENTRY")
+cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME")
+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 REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
+cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH")
+cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
+cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
+cStmtMacroText THREAD_CONTEXT_SWITCH = SLIT("THREAD_CONTEXT_SWITCH")
+cStmtMacroText GRAN_YIELD = SLIT("GRAN_YIELD")
+
+cCheckMacroText HP_CHK_NP = SLIT("HP_CHK_NP")
+cCheckMacroText STK_CHK_NP = SLIT("STK_CHK_NP")
+cCheckMacroText HP_STK_CHK_NP = SLIT("HP_STK_CHK_NP")
+cCheckMacroText HP_CHK_SEQ_NP = SLIT("HP_CHK_SEQ_NP")
+cCheckMacroText HP_CHK = SLIT("HP_CHK")
+cCheckMacroText STK_CHK = SLIT("STK_CHK")
+cCheckMacroText HP_STK_CHK = SLIT("HP_STK_CHK")
+cCheckMacroText HP_CHK_NOREGS = SLIT("HP_CHK_NOREGS")
+cCheckMacroText HP_CHK_UNPT_R1 = SLIT("HP_CHK_UNPT_R1")
+cCheckMacroText HP_CHK_UNBX_R1 = SLIT("HP_CHK_UNBX_R1")
+cCheckMacroText HP_CHK_F1 = SLIT("HP_CHK_F1")
+cCheckMacroText HP_CHK_D1 = SLIT("HP_CHK_D1")
+cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1")
+cCheckMacroText HP_CHK_UT_ALT = SLIT("HP_CHK_UT_ALT")
+cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN")
+\end{code}
+
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
pp_liveness :: Liveness -> SDoc
pp_liveness lv =
case lv of
- LvSmall mask -> int (intBS mask)
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
\end{code}
%************************************************************************
else
(pp_Node, Just (addPlusSign sign_wanted (int off)))
+pprRegRelative sign_wanted (CIndex base offset kind)
+ = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
+ , Just (hcat [if sign_wanted then char '+' else empty,
+ text "(I_)(", ppr_amode offset, ptext SLIT(")")])
+ )
\end{code}
@pprMagicId@ just prints the register name. @VanillaReg@ registers are
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'
False)
labelSeenTE :: CLabel -> TeM Bool
-labelSeenTE label env@(seen_uniqs, seen_labels)
- = if (label `elementOfCLabelSet` seen_labels)
+labelSeenTE lbl env@(seen_uniqs, seen_labels)
+ = if (lbl `elementOfCLabelSet` seen_labels)
then (env, True)
else ((seen_uniqs,
- addToCLabelSet seen_labels label),
+ addToCLabelSet seen_labels lbl),
False)
\end{code}
pprTempDecl uniq kind
= hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
-pprExternDecl :: CLabel -> PrimRep -> SDoc
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl in_srt clabel
+ | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
+ | otherwise =
+ hcat [ ppLocalnessMacro (not in_srt) clabel,
+ lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
+ where
+ dyn_wrapper d
+ | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
+ | otherwise = d
-pprExternDecl clabel kind
- = if not (needsCDecl clabel) then
- empty -- do not print anything for "known external" things
- else
- hcat [ ppLocalnessMacro clabel,
- lparen, pprCLabel clabel, pp_paren_semi ]
\end{code}
\begin{code}
where
ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
-ppr_decls_AbsC (CCodeBlock label absC)
+ppr_decls_AbsC (CCodeBlock lbl absC)
= ppr_decls_AbsC absC
ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
if label_seen then
Nothing
else
- Just (pprExternDecl info_lbl PtrRep))
+ Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
where
info_lbl = infoTableLabelFromCI cl_info
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
+ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
= ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
ppr_decls_AbsC slow `thenTE` \ p2 ->
(case maybe_fast of
= mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
returnTE (Nothing,
if and seen then Nothing
- else Just (vcat [ pprExternDecl l PtrRep
+ else Just (vcat [ pprExternDecl True{-in SRT decl-} l
| (l,False) <- zip closure_lbls seen ]))
ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code
+
+ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code}
\begin{code}
ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
+ppr_decls_Amode (CVal (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
+ppr_decls_Amode (CAddr (CIndex base offset _)) = ppr_decls_Amodes [base,offset]
ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
returnTE
(if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
-ppr_decls_Amode (CLbl label VoidRep)
+ppr_decls_Amode (CLbl lbl VoidRep)
= returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLbl label kind)
- = labelSeenTE label `thenTE` \ label_seen ->
+ppr_decls_Amode (CLbl lbl kind)
+ = labelSeenTE lbl `thenTE` \ label_seen ->
returnTE (Nothing,
- if label_seen then Nothing else Just (pprExternDecl label kind))
-
-ppr_decls_Amode (CTableEntry base index _)
- = ppr_decls_Amode base `thenTE` \ p1 ->
- ppr_decls_Amode index `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
+ if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))
ppr_decls_Amode (CMacroExpr _ _ amodes)
= ppr_decls_Amodes amodes
where
addr_of_label = ptext SLIT("(P_)&") <> pp_label
pp_label = pprCLabel clabel
+
\end{code}
-----------------------------------------------------------------------------
floatToWord :: CAddrMode -> CAddrMode
floatToWord (CLit (MachFloat r))
= runST (do
- arr <- newFloatArray (0,0)
+ arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 (fromRational r)
i <- readIntArray arr 0
- return (CLit (MachInt (toInteger i) True))
+ return (CLit (MachInt (toInteger i)))
)
doubleToWords :: CAddrMode -> [CAddrMode]
doubleToWords (CLit (MachDouble r))
| big_doubles -- doubles are 2 words
= runST (do
- arr <- newDoubleArray (0,1)
+ arr <- newDoubleArray ((0::Int),1)
writeDoubleArray arr 0 (fromRational r)
i1 <- readIntArray arr 0
i2 <- readIntArray arr 1
- return [ CLit (MachInt (toInteger i1) True)
- , CLit (MachInt (toInteger i2) True)
+ return [ CLit (MachInt (toInteger i1))
+ , CLit (MachInt (toInteger i2))
]
)
| otherwise -- doubles are 1 word
= runST (do
- arr <- newDoubleArray (0,0)
+ arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
i <- readIntArray arr 0
- return [ CLit (MachInt (toInteger i) True) ]
+ return [ CLit (MachInt (toInteger i)) ]
)
\end{code}
projects / ghc-hetmet.git / blobdiff