X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=ce7180e447d41caaa3079bbb88cc751ab92aa731;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=070cc7e380cfd12efdf557976fc16e1630b79a43;hpb=aa4f16def50ad9cbe5fff935a5cb91156150f5f1;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 070cc7e..ce7180e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -25,12 +25,13 @@ import ClosureInfo 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 ) @@ -39,7 +40,7 @@ import HeapOffs ( isZeroOff, subOff, pprHeapOffset ) 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 ) @@ -59,11 +60,18 @@ call to a cost evaluation function @GRAN_EXEC@. For that, @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 @@ -77,19 +85,16 @@ emitMacro (Cost (i,b,l,s,f)) = 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) @@ -97,7 +102,6 @@ pprAbsC (CClosureUpdInfo info) 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 ]) @@ -181,7 +185,7 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case -- 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) _ @@ -199,9 +203,9 @@ 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 } @@ -229,6 +233,39 @@ pprAbsC stmt@(CCallProfCtrMacro op as) _ 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) ) @@ -498,7 +535,6 @@ if_profiling pretty = 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; @@ -554,15 +590,15 @@ Some rough notes on generating code for @CCallOp@: 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. -} @@ -594,7 +630,7 @@ Amendment to the above: if we can GC, we have to: 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) @@ -603,21 +639,25 @@ pprCCall op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_re 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 @@ -636,24 +676,104 @@ pprCCall op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_re 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 @@ -708,7 +828,7 @@ For l-values, the critical questions are: \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) @@ -762,12 +882,10 @@ ToDo: Any chance of giving line numbers when process-casm fails? 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 @@ -832,6 +950,11 @@ pprAssign FloatRep dest@(CVal reg_rel _) src 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 @@ -903,6 +1026,10 @@ pprAmode (CVal reg_rel FloatRep) = 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 @@ -1043,6 +1170,7 @@ pprMagicId (VanillaReg pk n) 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") @@ -1138,6 +1266,7 @@ type CLabelSet = FiniteMap CLabel (){-any type will do-} 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)