%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
%************************************************************************
\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 CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+
+import Constants ( mIN_UPD_SIZE )
+import CallConv ( CallConv, callConvAttribute, cCallConv )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
isReadOnly, needsCDecl, pprCLabel,
- CLabel{-instance Ord-}
+ mkReturnInfoLabel, mkReturnPtLabel,
+ CLabel, CLabelType(..), labelType
)
-import CmdLineOpts ( opt_SccProfilingOn )
-import CostCentre ( uppCostCentre, uppCostCentreDecl )
+
+import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
+import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
+
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
-import Literal ( showLiteral, Literal(..) )
+import Const ( Literal(..) )
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 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 Addr ( Addr )
+
+import ST
+import MutableArray
infixr 9 `thenTE`
\end{code}
@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)
+-}
+
+writeRealC :: Handle -> AbstractC -> IO ()
+--writeRealC handle absC =
+-- _scc_ "writeRealC"
+-- printDoc LeftMode handle (pprAbsC absC (costs absC))
-dumpRealC :: AbstractC -> String
+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}
-
-\begin{code}
-pp_paren_semi = uppStr ");"
+emitMacro _ | not opt_GranMacros = empty
--- ---------------------------------------------------------------------------
--- 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 [char '(', pprAmode am, rparen]
+ DynamicVectoredReturn am' -> mk_vector (pprAmode am')
+ StaticVectoredReturn n -> mk_vector (int n) -- Always positive
+ mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
+ x, rparen ]
-pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
+pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
-- we optimise various degenerate cases of CSwitches.
-- 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),
+-- 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 op@(CCallOp _ _ _ _) args vol_regs) _
+ = pprCCall op 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
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) ->
+ case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
- uppAboves [ pp_saves,
- the_op,
- 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("};")
+ }
+ where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
+
+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 [text (show macro), lparen,
+ hcat (punctuate comma (map ppr_amode as)), comma,
+ pprAbsC code c, pp_paren_semi
+ ]
+pprAbsC (CMacroStmt macro as) _
+ = hcat [text (show macro), lparen,
+ hcat (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 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) _
+ = if not (maybeToBool(nonemptyAbsC abs_C)) then
+ pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+ else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
- uppAboves [
- uppBesides [uppStr (if (externallyVisibleCLabel label)
+ vcat [
+ hcat [text (if (externallyVisibleCLabel label)
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 label, text ") {"],
+
+ pp_exts, pp_temps,
+
+ nest 8 (ptext SLIT("FB_")),
+ nest 8 (pprAbsC abs_C (costs abs_C)),
+ nest 8 (ptext SLIT("FE_")),
+ 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 reg_rel cost_centre) _
+ = hcat [ ptext SLIT("SET_HDR_"), char '(',
+ ppr_amode (CAddr reg_rel), 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 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)),
+ 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
+
+ -- always at least one padding word: this is the static link field for
+ -- the garbage collector.
padding_wds =
if not (closureUpdReqd cl_info) then
- []
+ [mkIntCLit 0]
else
- case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+ case 1 + (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 ");"
- ],
+pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt 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 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))
-
- pp_tag = uppInt (closureSemiTag cl_info)
-
- is_phantom = isPhantomRep sm_rep
-
- pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
- uppInt (closureNonHdrSize cl_info)
-
- 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 "}"]
+ (Just select_word_i) = maybe_selector
+
+ maybe_tag = closureSemiTag cl_info
+ is_constr = maybeToBool maybe_tag
+ (Just tag) = maybe_tag
+
+ needs_srt = has_srt srt && needsSRT 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 = hcat [char '"', text (stringToC cl_descr), char '"']
+ pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
+
+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 entry_lbl, comma, -- entry pt storage class
+ int 0, comma,
+ int 0, text ");"
+ ],
+ pp_code
+ ]
where
- ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
- ppr_maybe_amode sty (Just a) = pprAmode sty a
+ info_lbl = mkReturnInfoLabel uniq
+ entry_lbl = mkReturnPtLabel uniq
+
+ pp_code = let stuff = CCodeBlock entry_lbl code in
+ pprAbsC stuff (costs stuff)
+
+ type_str = case liveness of
+ LvSmall _ -> SLIT("RET_SMALL")
+ LvLarge _ -> SLIT("RET_BIG")
+
+pprAbsC stmt@(CRetVector label amodes srt liveness) _
+ = vcat [
+ pp_vector,
+ hcat [
+ ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
+ lparen,
+ pp_liveness liveness, comma, -- bitmap liveness mask
+ pp_srt_info srt, -- SRT
+ ptext type_str, -- or big, depending on the size
+ -- of the liveness mask.
+ rparen
+ ],
+ text "};"
+ ]
-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)
-
-pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
+ pp_vector =
+ case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+ vcat [
+ pp_exts,
+ hcat [ppLocalness label,
+ ptext SLIT(" vec_info_"), int size, space,
+ pprCLabel label, text "= { {"
+ ],
+ nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
+ ] }
+
+ ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
+ size = length amodes
+
+ type_str = case liveness of
+ LvSmall _ -> SLIT("RET_VEC_SMALL")
+ LvLarge _ -> SLIT("RET_VEC_BIG")
+
+
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
\begin{code}
ppLocalness label
- = uppBeside static const
+ = (<>) static const
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)
- } }
+ static = if (externallyVisibleCLabel label)
+ then empty
+ else ptext SLIT("static ")
+ const = if not (isReadOnly label)
+ then empty
+ else ptext SLIT("const")
+
+-- Horrible macros for declaring the types and locality of labels (see
+-- StgMacros.h).
+
+ppLocalnessMacro clabel =
+ hcat [
+ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
+ case labelType clabel of
+ InfoTblType -> ptext SLIT("I_")
+ ClosureType -> ptext SLIT("C_")
+ CodeType -> ptext SLIT("F_")
+ DataType -> ptext SLIT("D_") <>
+ if isReadOnly clabel
+ then ptext SLIT("RO_")
+ else empty
+ ]
\end{code}
\begin{code}
+jmp_lit = "JMP_("
+
grab_non_void_amodes amodes
= filter non_void amodes
\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
-- 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.
+-- anything else. The correct sequence of saves&restores are
+-- encoded by the CALLER_*_SYSTEM macros.
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") ]
+ = vcat
+ [ ptext SLIT("CALLER_SAVE_Base")
+ , 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!
-
- _ -> {-print it anyway-} pretty
+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}
+\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;
-- 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) ]
+ 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 _ signed | signed -> 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
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
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 op@(CCallOp 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,
+ declare_fun_extern, -- declare expected function type.
+ 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)
+ (pp_saves, pp_restores) = ppr_vol_regs vol_regs
+ (pp_save_context, pp_restore_context)
+ | may_gc = ( text "do { SaveThreadState();"
+ , text "LoadThreadState();} while(0);"
+ )
+ | otherwise = ( pp_basic_saves $$ pp_saves,
+ pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = tail args
-- 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..] ]
+ = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
+
+
+ {-
+ In the non-casm case, to ensure that we're entering the given external
+ entry point using the correct calling convention, we have to do the following:
+
+ - When entering via a function pointer (the `dynamic' case) using the specified
+ calling convention, we emit a typedefn declaration attributed with the
+ calling convention to use together with the result and parameter types we're
+ assuming. Coerce the function pointer to this type and go.
+
+ - to enter the function at a given code label, we emit an extern declaration
+ for the label here, stating the calling convention together with result and
+ argument types we're assuming.
+
+ The C compiler will hopefully use this extern declaration to good effect,
+ reporting any discrepancies between our extern decl and any other that
+ may be in scope.
+
+ Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
+ the external function `foo' use the calling convention of the first `foo'
+ prototype it encounters (nor does it complain about conflicting attribute
+ declarations). The consequence of this is that you cannot override the
+ calling convention of `foo' using an extern declaration (you'd have to use
+ a typedef), but why you would want to do such a thing in the first place
+ is totally beyond me.
+
+ ToDo: petition the gcc folks to add code to warn about conflicting attribute
+ declarations.
- pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
+ -}
+ 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 sty non_void_results pp_liveness
+ = ppr_casm_results non_void_results
+
+ (Left asm_str) = op_str
+ is_dynamic =
+ case op_str of
+ Left _ -> False
+ _ -> True
- casm_str = if is_asm then _UNPK_ op_str else ccall_str
+ casm_str = if is_asm then _UNPK_ asm_str else ccall_str
-- Remainder only used for ccall
- ccall_str = uppShow 80
- (uppBesides [
+ 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 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
+ | 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
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
-- 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}
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}
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 PrimIO ()\n")
process ress args ('%':cs)
= case cs of
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 ->
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 %<num> 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}
%************************************************************************
@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 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 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
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}
@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
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@:
\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 ]
+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 (CAddr reg_rel)
- = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
+ppr_amode (CAddr reg_rel)
+ = case (pprRegRelative True{-sign wanted-} reg_rel) of
(pp_reg, Nothing) -> pp_reg
- (pp_reg, Just offset) -> uppBeside pp_reg offset
-
-ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
+ (pp_reg, Just offset) -> (<>) pp_reg offset
-ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
+ppr_amode (CReg magic_id) = pprMagicId magic_id
-ppr_amode sty (CLbl label kind) = pprCLabel sty label
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode sty (CUnVecLbl direct vectored)
- = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
- pprCLabel sty vectored, uppRparen]
+ppr_amode (CLbl label kind) = pprCLabelAddr label
-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 ]
+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 (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
+ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
-- ToDo: are these *used* for anything?
-ppr_amode sty (CLit lit) = pprBasicLit sty lit
-
-ppr_amode sty (CLitLit str _) = uppPStr str
-
-ppr_amode sty (COffset off) = pprHeapOffset sty off
+ppr_amode (CLit lit) = pprBasicLit lit
-ppr_amode sty (CCode abs_C)
- = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
+ppr_amode (CLitLit str _) = ptext str
-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 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 (CTableEntry base index kind)
+ = hcat [text "((", pprPrimKind kind, text " *)(",
+ ppr_amode base, text "))[(I_)(", ppr_amode index,
+ ptext SLIT(")]")]
+
+ppr_amode (CMacroExpr pk macro as)
+ = parens (pprPrimKind pk) <+>
+ parens (text (show macro) <>
+ parens (hcat (punctuate comma (map pprAmode as))))
+\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
+ LvSmall mask -> int (intBS mask)
+ LvLarge lbl -> char '&' <> pprCLabel lbl
\end{code}
%************************************************************************
%* *
%************************************************************************
-@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)))
\end{code}
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 :: FAST_INT -> 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 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 'i'
+pprUnionTag StableNameRep = char 'p'
+pprUnionTag WeakPtrRep = char 'p'
+pprUnionTag ForeignObjRep = char 'p'
-pprUnionTag ArrayRep = uppChar 'p'
-pprUnionTag ByteArrayRep = uppChar 'b'
+pprUnionTag ThreadIdRep = char 't'
+
+pprUnionTag ArrayRep = char 'p'
+pprUnionTag ByteArrayRep = char 'b'
pprUnionTag _ = panic "pprUnionTag:Odd kind"
\end{code}
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}
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)
\end{code}
\begin{code}
-pprTempDecl :: Unique -> PrimRep -> Unpretty
+pprTempDecl :: Unique -> PrimRep -> SDoc
pprTempDecl uniq kind
- = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
+ = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
-pprExternDecl :: CLabel -> PrimRep -> Unpretty
+pprExternDecl :: CLabel -> PrimRep -> SDoc
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 ->
-
- uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
- }
+ empty -- do not print anything for "known external" things
+ else
+ hcat [ ppLocalnessMacro clabel,
+ lparen, pprCLabel 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
= 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 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,
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 [] -- *****!!!
-- 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 lbl closure_lbls)
+ = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
+ returnTE (Nothing,
+ if and seen then Nothing
+ else Just (vcat [ pprExternDecl l PtrRep
+ | (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
\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 _ _) = 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)
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
- 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])
+ returnTE (maybe_vcat [p1, p2])
ppr_decls_Amode (CMacroExpr _ _ amodes)
= ppr_decls_Amodes 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) True))
+ )
+
+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) True)
+ , CLit (MachInt (toInteger i2) True)
+ ]
+ )
+ | 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) True) ]
+ )
\end{code}
projects / ghc-hetmet.git / blobdiff