X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=2ad4595788335c455c4c8af6142532ca0d7e9636;hb=30d559930fff086ad3a8ef4162e7d748d1e96b70;hp=e73bf1576f5e0090df3150e8a8d8de0899a024dc;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index e73bf15..2ad4595 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -8,53 +8,58 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module PprAbsC ( writeRealC, - dumpRealC -#ifdef DEBUG - , pprAmode -- otherwise, not exported -#endif + dumpRealC, + pprAmode, + pprMagicId ) where -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo -IMPORT_1_3(IO(Handle)) -IMPORT_1_3(Char(isDigit,isPrint)) -IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards +#include "HsVersions.h" -import AbsCSyn +import IO ( Handle ) +import AbsCSyn +import ClosureInfo import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE ) -import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, - isReadOnly, needsCDecl, pprCLabel, - CLabel{-instance Ord-} + +import Constants ( mIN_UPD_SIZE ) +import CallConv ( callConvAttribute ) +import CLabel ( externallyVisibleCLabel, + needsCDecl, pprCLabel, + mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, + mkClosureLabel, mkErrorStdEntryLabel, + CLabel, CLabelType(..), labelType, labelDynamic ) -import CmdLineOpts ( opt_SccProfilingOn ) -import CostCentre ( uppCostCentre, uppCostCentreDecl ) + +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 HeapOffs ( isZeroOff, subOff, pprHeapOffset ) -import Literal ( showLiteral, Literal(..) ) +import Literal ( Literal(..) ) +import TyCon ( tyConDataCons ) +import Name ( NamedThing(..) ) +import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId ) import Maybes ( maybeToBool, catMaybes ) -import PprStyle ( PprStyle(..) ) -import Pretty ( prettyToUn ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) -import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) ) -import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, - isConstantRep, isSpecRep, isPhantomRep - ) +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 UniqSet ( emptyUniqSet, elementOfUniqSet, - addOneToUniqSet, SYN_IE(UniqSet) + addOneToUniqSet, UniqSet ) -import Unpretty -- ********** NOTE ********** -import Util ( nOfThem, panic, assertPanic ) +import StgSyn ( SRT(..) ) +import BitSet ( intBS ) +import Outputable +import Util ( nOfThem ) + +import ST +import MutableArray infixr 9 `thenTE` \end{code} @@ -65,75 +70,87 @@ 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 - = uppPutStr handle 80 ( - uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') - ) + -- avoid holding on to the whole of absC in the !Gransim case. + if opt_GranMacros + then printForCFast fp (pprAbsC absC (costs absC)) + else printForCFast fp (pprAbsC absC (panic "costs")) + --printForC handle (pprAbsC absC (panic "costs")) +dumpRealC :: AbstractC -> SDoc +dumpRealC absC = pprAbsC absC (costs absC) +-} -dumpRealC :: AbstractC -> String +writeRealC :: Handle -> AbstractC -> IO () +--writeRealC handle absC = +-- _scc_ "writeRealC" +-- printDoc LeftMode handle (pprAbsC absC (costs absC)) +writeRealC handle absC + | opt_GranMacros = _scc_ "writeRealC" printForC handle $ + pprCode CStyle (pprAbsC absC (costs absC)) + | otherwise = _scc_ "writeRealC" printForC handle $ + pprCode CStyle (pprAbsC absC (panic "costs")) + +dumpRealC :: AbstractC -> SDoc dumpRealC absC - = uppShow 80 ( - uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') - ) + | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC)) + | otherwise = pprCode CStyle (pprAbsC absC (panic "costs")) + \end{code} This emits the macro, which is used in GrAnSim to compute the total costs from a cost 5 tuple. %% HWL \begin{code} -emitMacro :: CostRes -> Unpretty +emitMacro :: CostRes -> SDoc --- ToDo: Check a compile time flag to decide whether a macro should be emitted -emitMacro (Cost (i,b,l,s,f)) - = uppBesides [ uppStr "GRAN_EXEC(", - uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, - uppInt s, uppComma, uppInt f, pp_paren_semi ] -\end{code} +emitMacro _ | not opt_GranMacros = empty -\begin{code} -pp_paren_semi = uppStr ");" - --- --------------------------------------------------------------------------- --- 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 --- --------------------------------------------------------------------------- +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 ] -pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty +pp_paren_semi = text ");" +\end{code} -pprAbsC sty AbsCNop _ = uppNil -pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c) +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 -pprAbsC sty (CClosureUpdInfo info) c - = pprAbsC sty info c +\begin{code} +pprAbsC :: AbstractC -> CostRes -> SDoc +pprAbsC AbsCNop _ = empty +pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c) -pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src +pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src -pprAbsC sty (CJump target) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) +pprAbsC (CJump target) c + = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) + (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) -pprAbsC sty (CFallThrough target) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ]) - (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) +pprAbsC (CFallThrough target) c + = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ]) + (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) -- -------------------------------------------------------------------------- -- Spit out GRAN_EXEC macro immediately before the return HWL -pprAbsC sty (CReturn am return_info) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ]) - (uppBesides [uppStr "JMP_(", target, pp_paren_semi ]) +pprAbsC (CReturn am return_info) c + = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ]) + (hcat [text jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen] - DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') - StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive - mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"] + 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 [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma, + x, rparen ] -pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */") +pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER") -- we optimise various degenerate cases of CSwitches. @@ -145,60 +162,61 @@ pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */") -- HWL -- -------------------------------------------------------------------------- -pprAbsC sty (CSwitch discrim [] deflt) c - = pprAbsC sty deflt (c + costs deflt) +pprAbsC (CSwitch discrim [] deflt) c + = pprAbsC deflt (c + costs deflt) -- Empty alternative list => no costs for discrim as nothing cond. here HWL -pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt +pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt = case (nonemptyAbsC deflt) of Nothing -> -- one alt and no default - pprAbsC sty alt_code (c + costs alt_code) + pprAbsC alt_code (c + costs alt_code) -- Nothing conditional in here either HWL Just dc -> -- make it an "if" - do_if_stmt sty discrim tag alt_code dc c + do_if_stmt discrim tag alt_code dc c -pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] deflt) 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 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) = if (i1 == 0) then - do_if_stmt sty discrim tag1 alt_code1 alt_code2 c + do_if_stmt discrim tag1 alt_code1 alt_code2 c else - do_if_stmt sty discrim tag2 alt_code2 alt_code1 c + do_if_stmt discrim tag2 alt_code2 alt_code1 c where empty_deflt = not (maybeToBool (nonemptyAbsC deflt)) -pprAbsC sty (CSwitch discrim alts deflt) c -- general case +pprAbsC (CSwitch discrim alts deflt) c -- general case | isFloatingRep (getAmodeRep discrim) - = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c + = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c | otherwise - = uppAboves [ - uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"], - uppNest 2 (uppAboves (map (ppr_alt sty) alts)), + = vcat [ + hcat [text "switch (", pp_discrim, text ") {"], + nest 2 (vcat (map ppr_alt alts)), (case (nonemptyAbsC deflt) of - Nothing -> uppNil + Nothing -> empty Just dc -> - uppNest 2 (uppAboves [uppPStr SLIT("default:"), - pprAbsC sty dc (c + switch_head_cost + nest 2 (vcat [ptext SLIT("default:"), + pprAbsC dc (c + switch_head_cost + costs dc), - uppPStr SLIT("break;")])), - uppChar '}' ] + ptext SLIT("break;")])), + char '}' ] where pp_discrim - = pprAmode sty discrim + = pprAmode discrim - ppr_alt sty (lit, absC) - = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'], - uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC)) - (uppPStr SLIT("break;"))) ] + ppr_alt (lit, absC) + = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'], + nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC)) + (ptext SLIT("break;"))) ] -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) -pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _ - = pprCCall sty op args results liveness_mask vol_regs +pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _ + = pprCCall ccall args results vol_regs -pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ +pprAbsC stmt@(COpStmt results op args vol_regs) _ = let non_void_args = grab_non_void_amodes args non_void_results = grab_non_void_amodes results @@ -210,247 +228,391 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ the_op = ppr_op_call non_void_results non_void_args -- liveness mask is *in* the non_void_args in - case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) -> if primOpNeedsWrapper op then - uppAboves [ pp_saves, - the_op, - pp_restores - ] + 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 - = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen, - uppIntersperse uppComma (map ppr_op_result results), - if null results || null args then uppNil else uppComma, - uppIntersperse uppComma (map (pprAmode sty) args), + = hcat [ pprPrimOp 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)), pp_paren_semi ] - ppr_op_result r = ppr_amode sty r + ppr_op_result r = ppr_amode r -- primop macros do their own casting of result; -- hence we can toss the provided cast... -pprAbsC sty (CSimultaneous abs_c) c - = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"] - -pprAbsC sty stmt@(CMacroStmt macro as) _ - = uppBesides [uppStr (show macro), uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting -pprAbsC sty stmt@(CCallProfCtrMacro op as) _ - = uppBesides [uppPStr op, uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -pprAbsC sty stmt@(CCallProfCCMacro op as) _ - = uppBesides [uppPStr op, uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] - -pprAbsC sty (CCodeBlock label abs_C) _ - = ASSERT( maybeToBool(nonemptyAbsC abs_C) ) +pprAbsC stmt@(CSRT lbl closures) c + = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> + pp_exts + $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen + $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures))) + <> ptext SLIT("};") + } + +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("}};") + ] + +pprAbsC (CSimultaneous abs_c) c + = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] + +pprAbsC (CCheck macro as code) c + = hcat [ptext (cCheckMacroText macro), lparen, + hcat (punctuate comma (map ppr_amode as)), comma, + pprAbsC code c, pp_paren_semi + ] +pprAbsC (CMacroStmt macro as) _ + = 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, + hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] +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) _ + = 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 + {- + 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 + DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u + StaticTarget x -> pprCLabelString x + + 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 + | 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 = 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 + +pprAbsC (CCodeBlock lbl abs_C) _ + = if not (maybeToBool(nonemptyAbsC abs_C)) then + pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty + else case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> - uppAboves [ - uppBesides [uppStr (if (externallyVisibleCLabel label) + vcat [ + empty, + pp_exts, + hcat [text (if (externallyVisibleCLabel lbl) then "FN_(" -- abbreviations to save on output else "IFN_("), - pprCLabel sty label, uppStr ") {"], - case sty of - PprForC -> uppAbove pp_exts pp_temps - _ -> uppNil, - uppNest 8 (uppPStr SLIT("FB_")), - uppNest 8 (pprAbsC sty abs_C (costs abs_C)), - uppNest 8 (uppPStr SLIT("FE_")), - uppChar '}' ] + pprCLabel lbl, text ") {"], + + pp_temps, + + nest 8 (ptext SLIT("FB_")), + nest 8 (pprAbsC abs_C (costs abs_C)), + nest 8 (ptext SLIT("FE_")), + char '}', + char ' ' ] } -pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ - = uppBesides [ pp_init_hdr, uppStr "_HDR(", - ppr_amode sty (CAddr reg_rel), uppComma, - pprCLabel sty info_lbl, uppComma, - if_profiling sty (pprAmode sty cost_centre), uppComma, - pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ] + +pprAbsC (CInitHdr cl_info amode cost_centre) _ + = hcat [ ptext SLIT("SET_HDR_"), char '(', + ppr_amode amode, comma, + pprCLabelAddr info_lbl, comma, + if_profiling (pprAmode cost_centre), + pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info - sm_rep = closureSMRep cl_info - size = closureSizeWithoutFixedHdr cl_info - ptr_wds = closurePtrsSize cl_info - pp_init_hdr = uppStr (if inplace_upd then - getSMUpdInplaceHdrStr sm_rep - else - getSMInitHdrStr sm_rep) - -pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ +pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - uppAboves [ - case sty of - PprForC -> pp_exts - _ -> uppNil, - uppBesides [ - uppStr "SET_STATIC_HDR(", - pprCLabel sty closure_lbl, uppComma, - pprCLabel sty info_lbl, uppComma, - if_profiling sty (pprAmode sty cost_centre), uppComma, - ppLocalness closure_lbl, uppComma, - ppLocalnessMacro False{-for data-} info_lbl, - uppChar ')' + vcat [ + pp_exts, + hcat [ + ptext SLIT("SET_STATIC_HDR"), char '(', + pprCLabel closure_lbl, comma, + pprCLabel info_lbl, comma, + if_profiling (pprAmode cost_centre), comma, + ppLocalness closure_lbl, comma, + ppLocalnessMacro True{-include dyn-} info_lbl, + char ')' ], - uppNest 2 (uppBesides (map (ppr_item sty) amodes)), - uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)), - uppStr "};" ] + nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)), + ptext SLIT("};") ] } where info_lbl = infoTableLabelFromCI cl_info - ppr_item sty item - = if getAmodeRep item == VoidRep - then uppStr ", (W_) 0" -- might not even need this... - else uppBeside (uppStr ", (W_)") (ppr_amode sty item) + ppr_payload [] = empty + ppr_payload ls = comma <+> + braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls))) + + ppr_item item + | rep == VoidRep = text "0" -- might not even need this... + | rep == FloatRep = ppr_amode (floatToWord item) + | rep == DoubleRep = hcat (punctuate (text ", (L_)") + (map ppr_amode (doubleToWords item))) + | otherwise = ppr_amode item + where + rep = getAmodeRep item padding_wds = if not (closureUpdReqd cl_info) then [] else - case (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 -{- - STATIC_INIT_HDR(c,i,localness) blows into: - localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n> - - then *NO VarHdr STUFF FOR STATIC*... - - then the amodes are dropped in... - ,a1 ,a2 ... ,aN - then a close brace: - }; --} - -pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _ - = uppAboves [ - uppBesides [ - pp_info_rep, - uppStr "_ITBL(", - pprCLabel sty info_lbl, uppComma, - - -- CONST_ITBL needs an extra label for - -- the static version of the object. - if isConstantRep sm_rep - then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma - else uppNil, - - pprCLabel sty slow_lbl, uppComma, - pprAmode sty upd, uppComma, - uppInt liveness, uppComma, - - pp_tag, uppComma, - pp_size, uppComma, - pp_ptr_wds, uppComma, - - ppLocalness info_lbl, uppComma, - ppLocalnessMacro True{-function-} slow_lbl, uppComma, - - if is_selector - then uppBeside (uppInt select_word_i) uppComma - else uppNil, - - if_profiling sty pp_kind, uppComma, - if_profiling sty pp_descr, uppComma, - if_profiling sty pp_type, - uppStr ");" - ], + 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"), + ( if is_selector then + ptext SLIT("_SELECTOR") + else if is_constr then + ptext SLIT("_CONSTR") + else if needs_srt then + ptext SLIT("_SRT") + else empty ), char '(', + + pprCLabel info_lbl, comma, + pprCLabel slow_lbl, comma, + pp_rest, {- ptrs,nptrs,[srt,]type,-} comma, + + ppLocalness info_lbl, comma, + ppLocalnessMacro True{-include dyn-} slow_lbl, comma, + + if_profiling pp_descr, comma, + if_profiling pp_type, + text ");" + ], pp_slow, case maybe_fast of - Nothing -> uppNil + Nothing -> empty Just fast -> let stuff = CCodeBlock fast_lbl fast in - pprAbsC sty stuff (costs stuff) + pprAbsC stuff (costs stuff) ] where info_lbl = infoTableLabelFromCI cl_info fast_lbl = fastLabelFromCI cl_info - sm_rep = closureSMRep cl_info (slow_lbl, pp_slow) = case (nonemptyAbsC slow) of - Nothing -> (mkErrorStdEntryLabel, uppNil) + Nothing -> (mkErrorStdEntryLabel, empty) Just xx -> (entryLabelFromCI cl_info, let stuff = CCodeBlock slow_lbl xx in - pprAbsC sty stuff (costs stuff)) + pprAbsC stuff (costs stuff)) maybe_selector = maybeSelectorInfo cl_info is_selector = maybeToBool maybe_selector - (Just (_, select_word_i)) = maybe_selector - - pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep - = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep)) + (Just select_word_i) = maybe_selector + + maybe_tag = closureSemiTag cl_info + is_constr = maybeToBool maybe_tag + (Just tag) = maybe_tag + + needs_srt = infoTblNeedsSRT cl_info + srt = getSRTInfo cl_info + + size = closureNonHdrSize cl_info + + ptrs = closurePtrsSize cl_info + nptrs = size - ptrs + + pp_rest | is_selector = int select_word_i + | otherwise = hcat [ + int ptrs, comma, + int nptrs, comma, + if is_constr then + hcat [ int tag, comma ] + else if needs_srt then + pp_srt_info srt + else empty, + type_str ] + + type_str = pprSMRep (closureSMRep cl_info) + + pp_descr = pprStringInCStyle cl_descr + pp_type = pprStringInCStyle (closureTypeDescr cl_info) + +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 [ + ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen, + pprCLabel info_lbl, comma, + pprCLabel entry_lbl, comma, + pp_liveness liveness, comma, -- bitmap + pp_srt_info srt, -- SRT + ptext type_str, 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, + int 0, text ");" + ], + pp_code + ] + where + info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq - pp_tag = uppInt (closureSemiTag cl_info) + pp_code = let stuff = CCodeBlock entry_lbl code in + pprAbsC stuff (costs stuff) - is_phantom = isPhantomRep sm_rep + type_str = case liveness of + LvSmall _ -> SLIT("RET_SMALL") + LvLarge _ -> SLIT("RET_BIG") - pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always) - uppInt (closureNonHdrSize cl_info) +pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ + = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> + vcat [ + pp_exts, + hcat [ + 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 ");" + ] + } - else if is_phantom then -- do not have sizes for these - uppNil - else - pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info) - - pp_ptr_wds = if is_phantom then - uppNil - else - uppInt (closurePtrsSize cl_info) - - pp_kind = uppStr (closureKind cl_info) - pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"'] - pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"'] - -pprAbsC sty (CRetVector lbl maybes deflt) c - = uppAboves [ uppStr "{ // CRetVector (lbl????)", - uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)), - uppStr "} /*default=*/ {", pprAbsC sty deflt c, - uppStr "}"] where - ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/") - ppr_maybe_amode sty (Just a) = pprAmode sty a + ppr_item item = (<>) (text "(F_) ") (ppr_amode item) + size = length amodes -pprAbsC sty stmt@(CRetUnVector label amode) _ - = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma, - pprAmode sty amode, uppRparen] - where - pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static") - -pprAbsC sty stmt@(CFlatRetVector label amodes) _ - = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - uppAboves [ - case sty of - PprForC -> pp_exts - _ -> uppNil, - uppBesides [ppLocalness label, uppPStr SLIT(" W_ "), - pprCLabel sty label, uppStr "[] = {"], - uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)), - uppStr "};" ] } - where - ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item) + type_str = case liveness of + LvSmall _ -> SLIT("RET_VEC_SMALL") + LvLarge _ -> SLIT("RET_VEC_BIG") -pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc + +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 - = uppBeside static const +ppLocalness lbl + = if (externallyVisibleCLabel lbl) + then empty + else ptext SLIT("static ") + +-- Horrible macros for declaring the types and locality of labels (see +-- StgMacros.h). + +ppLocalnessMacro include_dyn_prefix clabel = + hcat [ + 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 - static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ") - const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const") - -ppLocalnessMacro for_fun{-vs data-} clabel - = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix -> - case (if isReadOnly clabel then "RO_" else "") of { suffix -> - if for_fun - then uppStr (prefix ++ "F_") - else uppStr (prefix ++ "D_" ++ suffix) - } } + 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} +jmp_lit = "JMP_(" + grab_non_void_amodes amodes = filter non_void amodes @@ -461,60 +623,56 @@ non_void amode \end{code} \begin{code} -ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty) +ppr_vol_regs :: [MagicId] -> (SDoc, SDoc) -ppr_vol_regs sty [] = (uppNil, uppNil) -ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs -ppr_vol_regs sty (r:rs) +ppr_vol_regs [] = (empty, empty) +ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs +ppr_vol_regs (r:rs) = let pp_reg = case r of VanillaReg pk n -> pprVanillaReg n - _ -> pprMagicId sty r - (more_saves, more_restores) = ppr_vol_regs sty rs + _ -> pprMagicId r + (more_saves, more_restores) = ppr_vol_regs rs in - (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves, - uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores) + (($$) ((<>) (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. -pp_basic_saves - = uppAboves [ - uppPStr SLIT("CALLER_SAVE_Base"), - uppPStr SLIT("CALLER_SAVE_SpA"), - uppPStr SLIT("CALLER_SAVE_SuA"), - uppPStr SLIT("CALLER_SAVE_SpB"), - uppPStr SLIT("CALLER_SAVE_SuB"), - uppPStr SLIT("CALLER_SAVE_Ret"), --- uppPStr SLIT("CALLER_SAVE_Activity"), - uppPStr SLIT("CALLER_SAVE_Hp"), - uppPStr SLIT("CALLER_SAVE_HpLim") ] - -pp_basic_restores - = uppAboves [ - uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first! - uppPStr SLIT("CALLER_RESTORE_SpA"), - uppPStr SLIT("CALLER_RESTORE_SuA"), - uppPStr SLIT("CALLER_RESTORE_SpB"), - uppPStr SLIT("CALLER_RESTORE_SuB"), - uppPStr SLIT("CALLER_RESTORE_Ret"), --- uppPStr SLIT("CALLER_RESTORE_Activity"), - uppPStr SLIT("CALLER_RESTORE_Hp"), - uppPStr SLIT("CALLER_RESTORE_HpLim"), - uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"), - uppPStr SLIT("CALLER_RESTORE_StkStub") ] +-- anything else. The correct sequence of saves&restores are +-- encoded by the CALLER_*_SYSTEM macros. +pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM") +pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -if_profiling sty pretty - = case sty of - PprForC -> if opt_SccProfilingOn - then pretty - else uppChar '0' -- leave it out! +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 ] +\end{code} - _ -> {-print it anyway-} pretty +\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 + else char '0' -- leave it out! -- --------------------------------------------------------------------------- -- Changes for GrAnSim: -- draw costs for computation in head of if into both branches; @@ -522,33 +680,46 @@ if_profiling sty pretty -- guessing unknown values and fed into the costs function -- --------------------------------------------------------------------------- -do_if_stmt sty discrim tag alt_code deflt c +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 sty (pprAmode sty discrim) + MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim) deflt alt_code (addrModeCosts discrim Rhs) c - other -> let - cond = uppBesides [ pprAmode sty discrim, - uppPStr SLIT(" == "), - pprAmode sty (CLit tag) ] + 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 sty cond + ppr_if_stmt cond alt_code deflt (addrModeCosts discrim Rhs) c -ppr_if_stmt sty pp_pred then_part else_part discrim_costs c - = uppAboves [ - uppBesides [uppStr "if (", pp_pred, uppStr ") {"], - uppNest 8 (pprAbsC sty then_part (c + discrim_costs + +ppr_if_stmt pp_pred then_part else_part discrim_costs c + = vcat [ + hcat [text "if (", pp_pred, text ") {"], + nest 8 (pprAbsC then_part (c + discrim_costs + (Cost (0, 2, 0, 0, 0)) + costs then_part)), - (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"), - uppNest 8 (pprAbsC sty else_part (c + discrim_costs + + (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"), + nest 8 (pprAbsC else_part (c + discrim_costs + (Cost (0, 1, 0, 0, 0)) + costs else_part)), - uppChar '}' ] + char '}' ] {- Total costs = inherited costs (before if) + costs for accessing discrim + costs for cond branch ( = (0, 1, 0, 0, 0) ) + costs for that alternative @@ -570,18 +741,13 @@ 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) -7) If returning Malloc Pointer, build a closure containing the - appropriate value. --} Otherwise, copy local variable into result register. 8) If ccall (not casm), declare the function being called as extern so @@ -605,39 +771,36 @@ Amendment to the above: if we can GC, we have to: can get at them. * be sure that there are no live registers or we're in trouble. (This can cause problems if you try something foolish like passing - an array or foreign obj to a _ccall_GC_ thing.) + an array or a foreign obj to a _ccall_GC_ thing.) * increment/decrement the @inCCallGC@ counter before/after the call so that the runtime check that PerformGC is being used sensibly will work. \begin{code} -pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs - = if (may_gc && liveness_mask /= noLiveRegsMask) - then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n") - else - uppAboves [ - uppChar '{', +pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs + = vcat [ + char '{', declare_local_vars, -- local var for *result* - uppAboves local_arg_decls, - -- if is_asm then uppNil else declareExtern, + 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 casm_str, pp_restore_context, assign_results, - uppChar '}' + char '}' ] where - (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs - (pp_save_context, pp_restore_context) = - if may_gc - then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", - uppStr "inCCallGC--; RestoreAllStgRegs();") - else ( pp_basic_saves `uppAbove` pp_saves, - pp_basic_restores `uppAbove` 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) + (pp_saves, pp_restores) = ppr_vol_regs vol_regs + (pp_save_context, pp_restore_context) + | 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 = 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 = @@ -647,45 +810,52 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo -- should ignore and a (possibly void) result. (local_arg_decls, pp_non_void_args) - = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ] - - pp_liveness = pprAmode sty (mkIntCLit liveness_mask) + = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ] (declare_local_vars, local_vars, assign_results) - = ppr_casm_results sty non_void_results pp_liveness + = ppr_casm_results non_void_results - casm_str = if is_asm then _UNPK_ op_str else ccall_str + 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 - ccall_str = uppShow 80 - (uppBesides [ + 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 uppNil - else uppPStr SLIT("%r = "), - uppLparen, uppPStr op_str, uppLparen, - uppIntersperse uppComma ccall_args, - uppStr "));" + then empty + else text "%r = ", + lparen, fun_name, lparen, + hcat (punctuate comma ccall_fun_args), + text "));" ]) - num_args = length non_void_args - ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ] + + ccall_fun_args | isDynamicTarget op_str = 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 the bit the C world wants to see. The only heap objects which can be -passed are @Array@s, @ByteArray@s and @ForeignObj@s. +passed are @Array@s and @ByteArray@s. \begin{code} -ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty) +ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc) -- (a) decl and assignment, (b) local var to be used later -ppr_casm_arg sty amode a_num +ppr_casm_arg amode a_num = let a_kind = getAmodeRep amode - pp_amode = pprAmode sty amode - pp_kind = pprPrimKind sty a_kind + pp_amode = pprAmode amode + pp_kind = pprPrimKind a_kind - local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num) + local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num) (arg_type, pp_amode2) = case a_kind of @@ -693,17 +863,19 @@ ppr_casm_arg sty amode a_num -- for array arguments, pass a pointer to the body of the array -- (PTRS_ARR_CTS skips over all the header nonsense) ArrayRep -> (pp_kind, - uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen]) + hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen]) ByteArrayRep -> (pp_kind, - uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen]) + hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen]) -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents. - ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"]) + ForeignObjRep -> (pp_kind, + hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"), + char '(', pp_amode, char ')']) + other -> (pp_kind, pp_amode) declare_local_var - = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ] + = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ] in (declare_local_var, local_var) \end{code} @@ -714,56 +886,33 @@ For l-values, the critical questions are: We only allow zero or one results. -{- With the introduction of ForeignObj (MallocPtr++), no longer necess. -2) Is the result is a foreign obj? - - The mallocptr must be encapsulated immediately in a heap object. --} \begin{code} -ppr_casm_results :: - PprStyle -- style - -> [CAddrMode] -- list of results (length <= 1) - -> Unpretty -- liveness mask +ppr_casm_results + :: [CAddrMode] -- list of results (length <= 1) -> - ( Unpretty, -- declaration of any local vars - [Unpretty], -- list of result vars (same length as results) - Unpretty ) -- assignment (if any) of results in local var to registers + ( SDoc, -- declaration of any local vars + [SDoc], -- list of result vars (same length as results) + SDoc ) -- assignment (if any) of results in local var to registers -ppr_casm_results sty [] liveness - = (uppNil, [], uppNil) -- no results +ppr_casm_results [] + = (empty, [], empty) -- no results -ppr_casm_results sty [r] liveness +ppr_casm_results [r] = let - result_reg = ppr_amode sty r + result_reg = ppr_amode r r_kind = getAmodeRep r - local_var = uppPStr SLIT("_ccall_result") + local_var = ptext SLIT("_ccall_result") (result_type, assign_result) - = case r_kind of -{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable. - Instead, external references have to be turned into ForeignObjs - using the primop makeForeignObj#. Benefit: Multiple finalisation - routines can be accommodated and the below special case is not needed. - Price is, of course, that you have to explicitly wrap `foreign objects' - with makeForeignObj#. -+ - ForeignObjRep -> - (uppPStr SLIT("StgForeignObj"), - uppBesides [ uppStr "constructForeignObj(", - liveness, uppComma, - result_reg, uppComma, - local_var, - pp_paren_semi ]) -} - _ -> - (pprPrimKind sty r_kind, - uppBesides [ result_reg, uppEquals, local_var, uppSemi ]) - - declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ] + = (pprPrimKind r_kind, + hcat [ result_reg, equals, local_var, semi ]) + + declare_local_var = hcat [ result_type, space, local_var, semi ] in (declare_local_var, [local_var], assign_result) -ppr_casm_results sty rs liveness +ppr_casm_results rs = panic "ppr_casm_results: ccall/casm with many results" \end{code} @@ -775,17 +924,17 @@ 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 :: - [Unpretty] -- results (length <= 1) - -> [Unpretty] -- arguments - -> String -- format string (with embedded %'s) - -> - Unpretty -- 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 - process [] _ "" = uppNil - process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n") + process [] _ "" = empty + process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ + string ++ + "\"\n(Try changing result type to IO ()\n") process ress args ('%':cs) = case cs of @@ -793,12 +942,12 @@ process_casm results args string = process results args string error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n") ('%':css) -> - uppBeside (uppChar '%') (process ress args css) + char '%' <> process ress args css ('r':css) -> case ress of [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n") - [r] -> uppBeside r (process [] args css) + [r] -> r <> (process [] args css) _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n") other -> @@ -809,13 +958,12 @@ process_casm results args string = process results args string case (read_int other) of [(num,css)] -> if 0 <= num && num < length args - then uppBeside (uppParens (args !! num)) - (process ress args css) - else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") + 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 % while processing _casm_ \"" ++ string ++ "\".\n") process ress args (other_c:cs) - = uppBeside (uppChar other_c) (process ress args cs) + = char other_c <> process ress args cs \end{code} %************************************************************************ @@ -832,61 +980,66 @@ of the source addressing mode.) If the kind of the assignment is of @VoidRep@, then don't generate any code at all. \begin{code} -pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty +pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc -pprAssign sty VoidRep dest src = uppNil +pprAssign VoidRep dest src = empty \end{code} Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} -pprAssign sty FloatRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] +pprAssign FloatRep dest@(CVal reg_rel _) src + = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', 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 ] -pprAssign sty DoubleRep dest@(CVal reg_rel _) src - = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty 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 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 sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) - = uppBesides [ pprVanillaReg dest, uppEquals, - pprVanillaReg src, uppSemi ] +pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) + = hcat [ pprVanillaReg dest, equals, + pprVanillaReg src, semi ] -pprAssign sty kind dest src +pprAssign kind dest src | mixedTypeLocn dest -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(W_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] + = hcat [ ppr_amode dest, equals, + text "(W_)(", -- Here is the cast + ppr_amode src, pp_paren_semi ] -pprAssign sty kind dest src +pprAssign kind dest src | mixedPtrLocn dest && getAmodeRep src /= PtrRep -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(P_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] + = hcat [ ppr_amode dest, equals, + text "(P_)(", -- Here is the cast + ppr_amode src, pp_paren_semi ] -pprAssign sty ByteArrayRep dest src +pprAssign ByteArrayRep dest src | mixedPtrLocn src - -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(B_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] - -pprAssign sty kind other_dest src - = uppBesides [ ppr_amode sty other_dest, uppEquals, - pprAmode sty src, uppSemi ] + -- Add in a cast iff the source is mixed + = hcat [ ppr_amode dest, equals, + text "(StgByteArray)(", -- Here is the cast + ppr_amode src, pp_paren_semi ] + +pprAssign kind other_dest src + = hcat [ ppr_amode other_dest, equals, + pprAmode src, semi ] \end{code} @@ -901,7 +1054,7 @@ pprAssign sty kind other_dest src @pprAmode@. \begin{code} -pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty +pprAmode, ppr_amode :: CAddrMode -> SDoc \end{code} For reasons discussed above under assignments, @CVal@ modes need @@ -912,82 +1065,143 @@ similar to those in @pprAssign@: question.) \begin{code} -pprAmode sty (CVal reg_rel FloatRep) - = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ] -pprAmode sty (CVal reg_rel DoubleRep) - = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ] +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 no-cast case: \begin{code} -pprAmode sty amode +pprAmode amode | mixedTypeLocn amode - = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(", - ppr_amode sty amode ]) + = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("), + ppr_amode amode ]) | otherwise -- No cast needed - = ppr_amode sty amode + = ppr_amode amode \end{code} -Now the rest of the cases for ``workhorse'' @ppr_amode@: +When we have an indirection through a CIndex, we have to be careful to +get the type casts right. -\begin{code} -ppr_amode sty (CVal reg_rel _) - = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of - (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg - (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ] +this amode: -ppr_amode sty (CAddr reg_rel) - = case (pprRegRelative sty True{-sign wanted-} reg_rel) of - (pp_reg, Nothing) -> pp_reg - (pp_reg, Just offset) -> uppBeside pp_reg offset + CVal (CIndex kind1 base offset) kind2 -ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id +means (in C speak): + + *(kind2 *)((kind1 *)base + offset) -ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq) +That is, the indexing is done in units of kind1, but the resulting +amode has kind2. -ppr_amode sty (CLbl label kind) = pprCLabel sty label +\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} -ppr_amode sty (CUnVecLbl direct vectored) - = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma, - pprCLabel sty vectored, uppRparen] +Now the rest of the cases for ``workhorse'' @ppr_amode@: -ppr_amode sty (CCharLike char) - = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ] -ppr_amode sty (CIntLike int) - = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ] +\begin{code} +ppr_amode (CVal reg_rel _) + = case (pprRegRelative False{-no sign wanted-} reg_rel) of + (pp_reg, Nothing) -> (<>) (char '*') pp_reg + (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ] -ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"'] - -- ToDo: are these *used* for anything? +ppr_amode (CAddr reg_rel) + = case (pprRegRelative True{-sign wanted-} reg_rel) of + (pp_reg, Nothing) -> pp_reg + (pp_reg, Just offset) -> (<>) pp_reg offset -ppr_amode sty (CLit lit) = pprBasicLit sty lit +ppr_amode (CReg magic_id) = pprMagicId magic_id -ppr_amode sty (CLitLit str _) = uppPStr str +ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_' -ppr_amode sty (COffset off) = pprHeapOffset sty off +ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl -ppr_amode sty (CCode abs_C) - = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] +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 sty (CLabelledCode label abs_C) - = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"], - uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] +ppr_amode (CLit lit) = pprBasicLit lit -ppr_amode sty (CJoinPoint _ _) +ppr_amode (CJoinPoint _) = panic "ppr_amode: CJoinPoint" -ppr_amode sty (CTableEntry base index kind) - = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(", - ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, - uppStr ")]"] +ppr_amode (CMacroExpr pk macro as) + = 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") +cExprMacroText CCS_HDR = SLIT("CCS_HDR") + +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 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") +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} -ppr_amode sty (CMacroExpr pk macro as) - = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, - uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"] +%************************************************************************ +%* * +\subsection[ppr-liveness-masks]{Liveness Masks} +%* * +%************************************************************************ -ppr_amode sty (CCostCentre cc print_as_string) - = uppCostCentre sty print_as_string cc +\begin{code} +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 \end{code} %************************************************************************ @@ -996,51 +1210,49 @@ ppr_amode sty (CCostCentre cc print_as_string) %* * %************************************************************************ -@pprRegRelative@ returns a pair of the @Unpretty@ for the register -(some casting may be required), and a @Maybe Unpretty@ for the offset +@pprRegRelative@ returns a pair of the @Doc@ for the register +(some casting may be required), and a @Maybe Doc@ for the offset (zero offset gives a @Nothing@). \begin{code} -addPlusSign :: Bool -> Unpretty -> Unpretty +addPlusSign :: Bool -> SDoc -> SDoc addPlusSign False p = p -addPlusSign True p = uppBeside (uppChar '+') p +addPlusSign True p = (<>) (char '+') p -pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0 +pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0 pprSignedInt sign_wanted n = if n == 0 then Nothing else - if n > 0 then Just (addPlusSign sign_wanted (uppInt n)) - else Just (uppInt n) + if n > 0 then Just (addPlusSign sign_wanted (int n)) + else Just (int n) -pprRegRelative :: PprStyle - -> Bool -- True <=> Print leading plus sign (if +ve) +pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve) -> RegRelative - -> (Unpretty, Maybe Unpretty) - -pprRegRelative sty sign_wanted (SpARel spA off) - = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off)) + -> (SDoc, Maybe SDoc) -pprRegRelative sty sign_wanted (SpBRel spB off) - = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off)) +pprRegRelative sign_wanted (SpRel off) + = (pprMagicId Sp, pprSignedInt sign_wanted (I# off)) -pprRegRelative sty sign_wanted r@(HpRel hp off) - = let to_print = hp `subOff` off - pp_Hp = pprMagicId sty Hp +pprRegRelative sign_wanted r@(HpRel o) + = let pp_Hp = pprMagicId Hp; off = I# o in - if isZeroOff to_print then + if off == 0 then (pp_Hp, Nothing) else - (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print))) - -- No parens needed because pprHeapOffset - -- does them when necessary + (pp_Hp, Just ((<>) (char '-') (int off))) -pprRegRelative sty sign_wanted (NodeRel off) - = let pp_Node = pprMagicId sty node +pprRegRelative sign_wanted (NodeRel o) + = let pp_Node = pprMagicId node; off = I# o in - if isZeroOff off then + if off == 0 then (pp_Node, Nothing) else - (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off))) + (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 @@ -1048,53 +1260,53 @@ represented by a discriminated union (@StgUnion@), so we use the @PrimRep@ to select the union tag. \begin{code} -pprMagicId :: PprStyle -> MagicId -> Unpretty +pprMagicId :: MagicId -> SDoc -pprMagicId sty BaseReg = uppPStr SLIT("BaseReg") -pprMagicId sty StkOReg = uppPStr SLIT("StkOReg") -pprMagicId sty (VanillaReg pk n) - = uppBesides [ pprVanillaReg n, uppChar '.', +pprMagicId BaseReg = ptext SLIT("BaseReg") +pprMagicId (VanillaReg pk n) + = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n)) -pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n)) -pprMagicId sty TagReg = uppPStr SLIT("TagReg") -pprMagicId sty RetReg = uppPStr SLIT("RetReg") -pprMagicId sty SpA = uppPStr SLIT("SpA") -pprMagicId sty SuA = uppPStr SLIT("SuA") -pprMagicId sty SpB = uppPStr SLIT("SpB") -pprMagicId sty SuB = uppPStr SLIT("SuB") -pprMagicId sty Hp = uppPStr SLIT("Hp") -pprMagicId sty HpLim = uppPStr SLIT("HpLim") -pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg") -pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg") -pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg") -pprMagicId sty CurCostCentre = uppPStr SLIT("CCC") -pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!" - -pprVanillaReg :: FAST_INT -> Unpretty - -pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n)) - -pprUnionTag :: PrimRep -> Unpretty - -pprUnionTag PtrRep = uppChar 'p' -pprUnionTag CodePtrRep = uppPStr SLIT("fp") -pprUnionTag DataPtrRep = uppChar 'd' -pprUnionTag RetRep = uppChar 'r' +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 Sp = ptext SLIT("Sp") +pprMagicId Su = ptext SLIT("Su") +pprMagicId SpLim = ptext SLIT("SpLim") +pprMagicId Hp = ptext SLIT("Hp") +pprMagicId HpLim = ptext SLIT("HpLim") +pprMagicId CurCostCentre = ptext SLIT("CCCS") +pprMagicId VoidReg = panic "pprMagicId:VoidReg!" + +pprVanillaReg :: FastInt -> SDoc +pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) + +pprUnionTag :: PrimRep -> SDoc + +pprUnionTag PtrRep = char 'p' +pprUnionTag CodePtrRep = ptext SLIT("fp") +pprUnionTag DataPtrRep = char 'd' +pprUnionTag RetRep = char 'p' pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?" -pprUnionTag CharRep = uppChar 'c' -pprUnionTag IntRep = uppChar 'i' -pprUnionTag WordRep = uppChar 'w' -pprUnionTag AddrRep = uppChar 'v' -pprUnionTag FloatRep = uppChar 'f' +pprUnionTag CharRep = char 'c' +pprUnionTag Int8Rep = ptext SLIT("i8") +pprUnionTag IntRep = char 'i' +pprUnionTag WordRep = char 'w' +pprUnionTag AddrRep = char 'a' +pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" -pprUnionTag StablePtrRep = uppChar 'i' -pprUnionTag ForeignObjRep = uppChar 'p' +pprUnionTag StablePtrRep = char 'p' +pprUnionTag StableNameRep = char 'p' +pprUnionTag WeakPtrRep = char 'p' +pprUnionTag ForeignObjRep = char 'p' +pprUnionTag PrimPtrRep = char 'p' -pprUnionTag ArrayRep = uppChar 'p' -pprUnionTag ByteArrayRep = uppChar 'b' +pprUnionTag ThreadIdRep = char 't' + +pprUnionTag ArrayRep = char 'p' +pprUnionTag ByteArrayRep = char 'b' +pprUnionTag BCORep = char 'p' pprUnionTag _ = panic "pprUnionTag:Odd kind" \end{code} @@ -1103,34 +1315,34 @@ pprUnionTag _ = panic "pprUnionTag:Odd kind" Find and print local and external declarations for a list of Abstract~C statements. \begin{code} -pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-}) -pprTempAndExternDecls AbsCNop = (uppNil, uppNil) +pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls AbsCNop = (empty, empty) pprTempAndExternDecls (AbsCStmts stmt1 stmt2) = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) -> ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) -> case (catMaybes [t_p1, t_p2]) of { real_temps -> case (catMaybes [e_p1, e_p2]) of { real_exts -> - returnTE (uppAboves real_temps, uppAboves real_exts) }} + returnTE (vcat real_temps, vcat real_exts) }} ) pprTempAndExternDecls other_stmt = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) -> returnTE ( case maybe_t of - Nothing -> uppNil + Nothing -> empty Just pp -> pp, case maybe_e of - Nothing -> uppNil + Nothing -> empty Just pp -> pp ) ) -pprBasicLit :: PprStyle -> Literal -> Unpretty -pprPrimKind :: PprStyle -> PrimRep -> Unpretty +pprBasicLit :: Literal -> SDoc +pprPrimKind :: PrimRep -> SDoc -pprBasicLit sty lit = uppStr (showLiteral sty lit) -pprPrimKind sty k = uppStr (showPrimRep k) +pprBasicLit lit = ppr lit +pprPrimKind k = ppr k \end{code} @@ -1152,6 +1364,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) @@ -1194,54 +1407,48 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels) 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} \begin{code} -pprTempDecl :: Unique -> PrimRep -> Unpretty +pprTempDecl :: Unique -> PrimRep -> SDoc pprTempDecl uniq kind - = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ] - -pprExternDecl :: CLabel -> PrimRep -> Unpretty - -pprExternDecl clabel kind - = if not (needsCDecl clabel) then - uppNil -- do not print anything for "known external" things (e.g., < PreludeCore) - else - case ( - case kind of - CodePtrRep -> ppLocalnessMacro True{-function-} clabel - _ -> ppLocalnessMacro False{-data-} clabel - ) of { pp_macro_str -> + = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ] + +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 - uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ] - } \end{code} \begin{code} -ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-}) +ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-}) ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing) ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2) = ppr_decls_AbsC stmts_1 `thenTE` \ p1 -> ppr_decls_AbsC stmts_2 `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) - -ppr_decls_AbsC (CClosureUpdInfo info) - = ppr_decls_AbsC info + returnTE (maybe_vcat [p1, p2]) ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing) ppr_decls_AbsC (CAssign dest source) = ppr_decls_Amode dest `thenTE` \ p1 -> ppr_decls_Amode source `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) + returnTE (maybe_vcat [p1, p2]) ppr_decls_AbsC (CJump target) = ppr_decls_Amode target @@ -1253,27 +1460,32 @@ ppr_decls_AbsC (CSwitch discrim alts deflt) = ppr_decls_Amode discrim `thenTE` \ pdisc -> mapTE ppr_alt_stuff alts `thenTE` \ palts -> ppr_decls_AbsC deflt `thenTE` \ pdeflt -> - returnTE (maybe_uppAboves (pdisc:pdeflt:palts)) + returnTE (maybe_vcat (pdisc:pdeflt:palts)) 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 inplace_upd) +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, 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 -ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args) +ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc +ppr_decls_AbsC (CCheck _ amodes code) = + ppr_decls_Amodes amodes `thenTE` \p1 -> + ppr_decls_AbsC code `thenTE` \p2 -> + returnTE (maybe_vcat [p1,p2]) + ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!! @@ -1286,44 +1498,47 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) -- ToDo: strictly speaking, should chk "cost_centre" amode = ppr_decls_Amodes amodes -ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _) - = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 -> +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 Nothing -> returnTE (Nothing, Nothing) Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 -> - returnTE (maybe_uppAboves [p1, p2, p3]) + returnTE (maybe_vcat [p1, p2, p3]) where entry_lbl = CLbl slow_lbl CodePtrRep slow_lbl = case (nonemptyAbsC slow) of Nothing -> mkErrorStdEntryLabel Just _ -> entryLabelFromCI cl_info -ppr_decls_AbsC (CRetVector label maybe_amodes absC) - = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 -> - ppr_decls_AbsC absC `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) +ppr_decls_AbsC (CSRT _ closure_lbls) + = mapTE labelSeenTE closure_lbls `thenTE` \ seen -> + returnTE (Nothing, + if and seen then Nothing + else Just (vcat [ pprExternDecl True{-in SRT decl-} l + | (l,False) <- zip closure_lbls seen ])) -ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode -ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes +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 Unpretty, Maybe Unpretty) +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) -ppr_decls_Amode (COffset _) = 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) @@ -1334,47 +1549,13 @@ ppr_decls_Amode (CTemp uniq kind) 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 -> - returnTE (Nothing, - if label_seen then Nothing else Just (pprExternDecl label kind)) - -{- WRONG: -ppr_decls_Amode (CUnVecLbl direct vectored) - = labelSeenTE direct `thenTE` \ dlbl_seen -> - labelSeenTE vectored `thenTE` \ vlbl_seen -> - let - ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep - vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep - in - returnTE (Nothing, - if (dlbl_seen || not (needsCDecl direct)) && - (vlbl_seen || not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) --} - -ppr_decls_Amode (CUnVecLbl direct vectored) - = -- We don't mark either label as "seen", because - -- we don't know which one will be used and which one tossed - -- by the C macro... - --labelSeenTE direct `thenTE` \ dlbl_seen -> - --labelSeenTE vectored `thenTE` \ vlbl_seen -> - let - ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep - vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep - in +ppr_decls_Amode (CLbl lbl kind) + = labelSeenTE lbl `thenTE` \ label_seen -> returnTE (Nothing, - if ({-dlbl_seen ||-} not (needsCDecl direct)) && - ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) - -ppr_decls_Amode (CTableEntry base index _) - = ppr_decls_Amode base `thenTE` \ p1 -> - ppr_decls_Amode index `thenTE` \ p2 -> - returnTE (maybe_uppAboves [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 @@ -1382,19 +1563,81 @@ ppr_decls_Amode (CMacroExpr _ _ amodes) ppr_decls_Amode other = returnTE (Nothing, Nothing) -maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty) -maybe_uppAboves ps +maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc) +maybe_vcat ps = case (unzip ps) of { (ts, es) -> case (catMaybes ts) of { real_ts -> case (catMaybes es) of { real_es -> - (if (null real_ts) then Nothing else Just (uppAboves real_ts), - if (null real_es) then Nothing else Just (uppAboves real_es)) + (if (null real_ts) then Nothing else Just (vcat real_ts), + if (null real_es) then Nothing else Just (vcat real_es)) } } } \end{code} \begin{code} -ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty) +ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc) ppr_decls_Amodes amodes = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> - returnTE ( maybe_uppAboves ps ) + returnTE ( maybe_vcat ps ) +\end{code} + +Print out a C Label where you want the *address* of the label, not the +object it refers to. The distinction is important when the label may +refer to a C structure (info tables and closures, for instance). + +When just generating a declaration for the label, use pprCLabel. + +\begin{code} +pprCLabelAddr :: CLabel -> SDoc +pprCLabelAddr clabel = + case labelType clabel of + InfoTblType -> addr_of_label + ClosureType -> addr_of_label + VecTblType -> addr_of_label + _ -> pp_label + where + addr_of_label = ptext SLIT("(P_)&") <> pp_label + pp_label = pprCLabel clabel + +\end{code} + +----------------------------------------------------------------------------- +Initialising static objects with floating-point numbers. We can't +just emit the floating point number, because C will cast it to an int +by rounding it. We want the actual bit-representation of the float. + +This is a hack to turn the floating point numbers into ints that we +can safely initialise to static locations. + +\begin{code} +big_doubles = (getPrimRepSize DoubleRep) /= 1 + +-- floatss are always 1 word +floatToWord :: CAddrMode -> CAddrMode +floatToWord (CLit (MachFloat r)) + = runST (do + arr <- newFloatArray ((0::Int),0) + writeFloatArray arr 0 (fromRational r) + i <- readIntArray arr 0 + return (CLit (MachInt (toInteger i))) + ) + +doubleToWords :: CAddrMode -> [CAddrMode] +doubleToWords (CLit (MachDouble r)) + | big_doubles -- doubles are 2 words + = runST (do + arr <- newDoubleArray ((0::Int),1) + writeDoubleArray arr 0 (fromRational r) + i1 <- readIntArray arr 0 + i2 <- readIntArray arr 1 + return [ CLit (MachInt (toInteger i1)) + , CLit (MachInt (toInteger i2)) + ] + ) + | otherwise -- doubles are 1 word + = runST (do + arr <- newDoubleArray ((0::Int),0) + writeDoubleArray arr 0 (fromRational r) + i <- readIntArray arr 0 + return [ CLit (MachInt (toInteger i)) ] + ) \end{code}