import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
+import CallConv ( CallConv, callConvAttribute, cCallConv )
import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
isReadOnly, needsCDecl, pprCLabel,
CLabel{-instance Ord-}
)
-import CmdLineOpts ( opt_SccProfilingOn )
+import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
import CostCentre ( uppCostCentre, uppCostCentreDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import Literal ( showLiteral, Literal(..) )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..) )
+import PrimRep ( isFloatingRep, PrimRep(..), showPrimRep )
import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
isConstantRep, isSpecRep, isPhantomRep
)
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC handle absC = printForC handle (pprAbsC absC (costs absC))
-
-dumpRealC :: AbstractC -> SDoc
-dumpRealC absC = pprAbsC absC (costs absC)
+writeRealC :: Handle -> AbstractC -> SDoc -> IO ()
+--writeRealC handle absC postlude =
+-- _scc_ "writeRealC"
+-- printDoc LeftMode handle (pprAbsC absC (costs absC))
+writeRealC handle absC postlude =
+ _scc_ "writeRealC"
+ printForC handle (pprAbsC absC (costs absC) $$ postlude)
+
+dumpRealC :: AbstractC -> SDoc -> SDoc
+dumpRealC absC postlude
+ | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC) $$ postlude)
+ | otherwise = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude)
\end{code}
This emits the macro, which is used in GrAnSim to compute the total costs
= hcat [ ptext SLIT("GRAN_EXEC"), char '(',
int i, comma, int b, comma, int l, comma,
int s, comma, int f, pp_paren_semi ]
-\end{code}
-\begin{code}
pp_paren_semi = text ");"
+\end{code}
--- ---------------------------------------------------------------------------
--- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
--- code as an argument (that's needed when spitting out the GRAN_EXEC macro
--- which must be done before the return i.e. inside absC code) HWL
--- ---------------------------------------------------------------------------
+New type: Now pprAbsC also takes the costs for evaluating the Abstract C
+code as an argument (that's needed when spitting out the GRAN_EXEC macro
+which must be done before the return i.e. inside absC code) HWL
+\begin{code}
pprAbsC :: AbstractC -> CostRes -> SDoc
-
pprAbsC AbsCNop _ = empty
pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
= pprAbsC info c
pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
-
pprAbsC (CJump target) c
= ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
(hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
-- 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 liveness_mask vol_regs) _
+pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _ _) args liveness_mask vol_regs) _
= pprCCall op args results liveness_mask vol_regs
pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
vcat [ pp_saves,
- the_op,
- pp_restores
- ]
+ the_op,
+ pp_restores
+ ]
else
the_op
}
pprAbsC stmt@(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")
+ , 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)
+
+ ccall_fun_ty =
+ case op_str of
+ Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+
+ ccall_res_ty =
+ case non_void_results of
+ [] -> ptext SLIT("void")
+ [amode] -> text (showPrimRep (getAmodeRep amode))
+ _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
+
+ ccall_decl_ty_args = tail 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
+ 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
pprAbsC (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
= if opt_SccProfilingOn
then pretty
else char '0' -- leave it out!
-
-- ---------------------------------------------------------------------------
-- Changes for GrAnSim:
-- draw costs for computation in head of if into both branches;
be restarted during the call.
3) Save any temporary registers that are currently in use.
-4) Do the call putting result into a local variable
+4) Do the call, putting result into a local variable
5) Restore essential registers
6) Restore temporaries
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
-{- Doesn't apply anymore with ForeignObj, structure create via primop.
- makeForeignObj (ForeignObj is not CReturnable)
+{- Doesn't apply anymore with ForeignObj, structure created via the primop.
+ makeForeignObj (i.e., ForeignObj is not CReturnable)
7) If returning Malloc Pointer, build a closure containing the
appropriate value.
-}
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
+pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask vol_regs
= if (may_gc && liveness_mask /= noLiveRegsMask)
then pprPanic "Live register in _casm_GC_ "
(doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
- -- if is_asm then empty else declareExtern,
pp_save_context,
- process_casm local_vars pp_non_void_args casm_str,
+ declare_fun_extern, -- declare expected function type.
+ process_casm local_vars pp_non_void_args casm_str,
pp_restore_context,
assign_results,
char '}'
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
- (pp_save_context, pp_restore_context) =
- if may_gc
- then ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
- text "inCCallGC--; RestoreAllStgRegs();} while(0);")
- else ( pp_basic_saves $$ pp_saves,
- pp_basic_restores $$ pp_restores)
+
+ (pp_save_context, pp_restore_context)
+ | may_gc =
+ ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;"
+ , text "inCCallGC--; RestoreAllStgRegs();} while(0);"
+ )
+ | otherwise =
+ ( pp_basic_saves $$ pp_saves
+ , pp_basic_restores $$ pp_restores
+ )
non_void_args =
let nvas = tail args
pp_liveness = pprAmode (mkIntCLit liveness_mask)
+ {-
+ 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 =
+ 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
+ Right u -> ppr u
+ _ -> empty
+
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results pp_liveness
- casm_str = if is_asm then _UNPK_ op_str else ccall_str
+ (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
-- Remainder only used for ccall
+ fun_name
+ | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
+ | otherwise = ptext asm_str
+
ccall_str = showSDoc
(hcat [
if null non_void_results
then empty
else text "%r = ",
- lparen, ptext op_str, lparen,
- hcat (punctuate comma ccall_args),
+ lparen, fun_name, lparen,
+ hcat (punctuate comma ccall_fun_args),
text "));"
])
- num_args = length non_void_args
- ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
+
+ 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
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
- -> SDoc -- liveness mask
+ -> SDoc -- liveness mask
->
( SDoc, -- declaration of any local vars
[SDoc], -- list of result vars (same length as results)
Or maybe we should do a check _much earlier_ in compiler. ADR
\begin{code}
-process_casm ::
- [SDoc] -- results (length <= 1)
- -> [SDoc] -- arguments
- -> String -- format string (with embedded %'s)
- ->
- SDoc -- code being generated
+process_casm :: [SDoc] -- results (length <= 1)
+ -> [SDoc] -- arguments
+ -> String -- format string (with embedded %'s)
+ -> SDoc -- code being generated
process_casm results args string = process results args string
where
pprAssign DoubleRep dest@(CVal reg_rel _) src
= hcat [ ptext SLIT("ASSIGN_DBL"),char '(', 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 ]
+pprAssign Word64Rep dest@(CVal reg_rel _) src
+ = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', 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
= hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
pprAmode (CVal reg_rel DoubleRep)
= hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel Int64Rep)
+ = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+pprAmode (CVal reg_rel Word64Rep)
+ = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
\end{code}
Next comes the case where there is some other cast need, and the
pprUnionTag pk ]
pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
+pprMagicId (LongReg _ n) = (<>) (ptext SLIT("LngReg")) (int IBOX(n))
pprMagicId TagReg = ptext SLIT("TagReg")
pprMagicId RetReg = ptext SLIT("RetReg")
pprMagicId SpA = ptext SLIT("SpA")
emptyCLabelSet = emptyFM
x `elementOfCLabelSet` labs
= case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
+
addToCLabelSet set x = addToFM set x ()
type TEenv = (UniqSet Unique, CLabelSet)
projects / ghc-hetmet.git / blobdiff