2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[PprAbsC]{Pretty-printing Abstract~C}
8 %************************************************************************
11 #include "HsVersions.h"
17 , pprAmode -- otherwise, not exported
22 IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
26 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
27 mixedPtrLocn, mixedTypeLocn
29 import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
30 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
31 isReadOnly, needsCDecl, pprCLabel,
32 CLabel{-instance Ord-}
34 import CmdLineOpts ( opt_SccProfilingOn )
35 import CostCentre ( uppCostCentre, uppCostCentreDecl )
36 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
37 import CStrings ( stringToC )
38 import FiniteMap ( addToFM, emptyFM, lookupFM )
39 import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
40 import Literal ( showLiteral, Literal(..) )
41 import Maybes ( maybeToBool, catMaybes )
42 import PprStyle ( PprStyle(..) )
43 import Pretty ( prettyToUn )
44 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
45 import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
46 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
47 isConstantRep, isSpecRep, isPhantomRep
49 import Unique ( pprUnique, Unique{-instance NamedThing-} )
50 import UniqSet ( emptyUniqSet, elementOfUniqSet,
51 addOneToUniqSet, UniqSet(..)
53 import Unpretty -- ********** NOTE **********
54 import Util ( nOfThem, panic, assertPanic )
59 For spitting out the costs of an abstract~C expression, @writeRealC@
60 now not only prints the C~code of the @absC@ arg but also adds a macro
61 call to a cost evaluation function @GRAN_EXEC@. For that,
62 @pprAbsC@ has a new ``costs'' argument. %% HWL
65 writeRealC :: Handle -> AbstractC -> IO ()
67 writeRealC handle absC
68 = uppPutStr handle 80 (
69 uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
72 dumpRealC :: AbstractC -> String
76 uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
80 This emits the macro, which is used in GrAnSim to compute the total costs
81 from a cost 5 tuple. %% HWL
84 emitMacro :: CostRes -> Unpretty
86 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
87 emitMacro (Cost (i,b,l,s,f))
88 = uppBesides [ uppStr "GRAN_EXEC(",
89 uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
90 uppInt s, uppComma, uppInt f, pp_paren_semi ]
94 pp_paren_semi = uppStr ");"
96 -- ---------------------------------------------------------------------------
97 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
98 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
99 -- which must be done before the return i.e. inside absC code) HWL
100 -- ---------------------------------------------------------------------------
102 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
104 pprAbsC sty AbsCNop _ = uppNil
105 pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
107 pprAbsC sty (CClosureUpdInfo info) c
110 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
112 pprAbsC sty (CJump target) c
113 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
114 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
116 pprAbsC sty (CFallThrough target) c
117 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
118 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
120 -- --------------------------------------------------------------------------
121 -- Spit out GRAN_EXEC macro immediately before the return HWL
123 pprAbsC sty (CReturn am return_info) c
124 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
125 (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
127 target = case return_info of
128 DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
129 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
130 StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
131 mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
133 pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
135 -- we optimise various degenerate cases of CSwitches.
137 -- --------------------------------------------------------------------------
138 -- Assume: CSwitch is also end of basic block
139 -- costs function yields nullCosts for whole switch
140 -- ==> inherited costs c are those of basic block up to switch
141 -- ==> inherit c + costs for the corresponding branch
143 -- --------------------------------------------------------------------------
145 pprAbsC sty (CSwitch discrim [] deflt) c
146 = pprAbsC sty deflt (c + costs deflt)
147 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
149 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
150 = case (nonemptyAbsC deflt) of
151 Nothing -> -- one alt and no default
152 pprAbsC sty alt_code (c + costs alt_code)
153 -- Nothing conditional in here either HWL
155 Just dc -> -- make it an "if"
156 do_if_stmt sty discrim tag alt_code dc c
158 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
159 (tag2@(MachInt i2 _), alt_code2)] deflt) c
160 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
162 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
164 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
166 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
168 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
169 | isFloatingRep (getAmodeRep discrim)
170 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
173 uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
174 uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
175 (case (nonemptyAbsC deflt) of
178 uppNest 2 (uppAboves [uppPStr SLIT("default:"),
179 pprAbsC sty dc (c + switch_head_cost
181 uppPStr SLIT("break;")])),
185 = pprAmode sty discrim
187 ppr_alt sty (lit, absC)
188 = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
189 uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
190 (uppPStr SLIT("break;"))) ]
192 -- Costs for addressing header of switch and cond. branching -- HWL
193 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
195 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
196 = pprCCall sty op args results liveness_mask vol_regs
198 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
200 non_void_args = grab_non_void_amodes args
201 non_void_results = grab_non_void_amodes results
202 -- if just one result, we print in the obvious "assignment" style;
203 -- if 0 or many results, we emit a macro call, w/ the results
204 -- followed by the arguments. The macro presumably knows which
207 the_op = ppr_op_call non_void_results non_void_args
208 -- liveness mask is *in* the non_void_args
210 case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
211 if primOpNeedsWrapper op then
212 uppAboves [ pp_saves,
220 ppr_op_call results args
221 = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
222 uppIntersperse uppComma (map ppr_op_result results),
223 if null results || null args then uppNil else uppComma,
224 uppIntersperse uppComma (map (pprAmode sty) args),
227 ppr_op_result r = ppr_amode sty r
228 -- primop macros do their own casting of result;
229 -- hence we can toss the provided cast...
231 pprAbsC sty (CSimultaneous abs_c) c
232 = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"]
234 pprAbsC sty stmt@(CMacroStmt macro as) _
235 = uppBesides [uppStr (show macro), uppLparen,
236 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
237 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
238 = uppBesides [uppPStr op, uppLparen,
239 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
240 pprAbsC sty stmt@(CCallProfCCMacro op as) _
241 = uppBesides [uppPStr op, uppLparen,
242 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
244 pprAbsC sty (CCodeBlock label abs_C) _
245 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
246 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
248 uppBesides [uppStr (if (externallyVisibleCLabel label)
249 then "FN_(" -- abbreviations to save on output
251 pprCLabel sty label, uppStr ") {"],
253 PprForC -> uppAbove pp_exts pp_temps
255 uppNest 8 (uppPStr SLIT("FB_")),
256 uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
257 uppNest 8 (uppPStr SLIT("FE_")),
261 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
262 = uppBesides [ pp_init_hdr, uppStr "_HDR(",
263 ppr_amode sty (CAddr reg_rel), uppComma,
264 pprCLabel sty info_lbl, uppComma,
265 if_profiling sty (pprAmode sty cost_centre), uppComma,
266 pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
268 info_lbl = infoTableLabelFromCI cl_info
269 sm_rep = closureSMRep cl_info
270 size = closureSizeWithoutFixedHdr cl_info
271 ptr_wds = closurePtrsSize cl_info
273 pp_init_hdr = uppStr (if inplace_upd then
274 getSMUpdInplaceHdrStr sm_rep
276 getSMInitHdrStr sm_rep)
278 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
279 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
285 uppStr "SET_STATIC_HDR(",
286 pprCLabel sty closure_lbl, uppComma,
287 pprCLabel sty info_lbl, uppComma,
288 if_profiling sty (pprAmode sty cost_centre), uppComma,
289 ppLocalness closure_lbl, uppComma,
290 ppLocalnessMacro False{-for data-} info_lbl,
293 uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
294 uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
298 info_lbl = infoTableLabelFromCI cl_info
301 = if getAmodeRep item == VoidRep
302 then uppStr ", (W_) 0" -- might not even need this...
303 else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
306 if not (closureUpdReqd cl_info) then
309 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
310 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
313 STATIC_INIT_HDR(c,i,localness) blows into:
314 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
316 then *NO VarHdr STUFF FOR STATIC*...
318 then the amodes are dropped in...
324 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
329 pprCLabel sty info_lbl, uppComma,
331 -- CONST_ITBL needs an extra label for
332 -- the static version of the object.
333 if isConstantRep sm_rep
334 then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
337 pprCLabel sty slow_lbl, uppComma,
338 pprAmode sty upd, uppComma,
339 uppInt liveness, uppComma,
343 pp_ptr_wds, uppComma,
345 ppLocalness info_lbl, uppComma,
346 ppLocalnessMacro True{-function-} slow_lbl, uppComma,
349 then uppBeside (uppInt select_word_i) uppComma
352 if_profiling sty pp_kind, uppComma,
353 if_profiling sty pp_descr, uppComma,
354 if_profiling sty pp_type,
360 Just fast -> let stuff = CCodeBlock fast_lbl fast in
361 pprAbsC sty stuff (costs stuff)
364 info_lbl = infoTableLabelFromCI cl_info
365 fast_lbl = fastLabelFromCI cl_info
366 sm_rep = closureSMRep cl_info
369 = case (nonemptyAbsC slow) of
370 Nothing -> (mkErrorStdEntryLabel, uppNil)
371 Just xx -> (entryLabelFromCI cl_info,
372 let stuff = CCodeBlock slow_lbl xx in
373 pprAbsC sty stuff (costs stuff))
375 maybe_selector = maybeSelectorInfo cl_info
376 is_selector = maybeToBool maybe_selector
377 (Just (_, select_word_i)) = maybe_selector
379 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
380 = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
382 pp_tag = uppInt (closureSemiTag cl_info)
384 is_phantom = isPhantomRep sm_rep
386 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
387 uppInt (closureNonHdrSize cl_info)
389 else if is_phantom then -- do not have sizes for these
392 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
394 pp_ptr_wds = if is_phantom then
397 uppInt (closurePtrsSize cl_info)
399 pp_kind = uppStr (closureKind cl_info)
400 pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
401 pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
403 pprAbsC sty (CRetVector lbl maybes deflt) c
404 = uppAboves [ uppStr "{ // CRetVector (lbl????)",
405 uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
406 uppStr "} /*default=*/ {", pprAbsC sty deflt c,
409 ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
410 ppr_maybe_amode sty (Just a) = pprAmode sty a
412 pprAbsC sty stmt@(CRetUnVector label amode) _
413 = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma,
414 pprAmode sty amode, uppRparen]
416 pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
418 pprAbsC sty stmt@(CFlatRetVector label amodes) _
419 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
424 uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
425 pprCLabel sty label, uppStr "[] = {"],
426 uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
429 ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
431 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
436 = uppBeside static const
438 static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
439 const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
441 ppLocalnessMacro for_fun{-vs data-} clabel
442 = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix ->
443 case (if isReadOnly clabel then "RO_" else "") of { suffix ->
445 then uppStr (prefix ++ "F_")
446 else uppStr (prefix ++ "D_" ++ suffix)
451 grab_non_void_amodes amodes
452 = filter non_void amodes
455 = case (getAmodeRep amode) of
461 ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
463 ppr_vol_regs sty [] = (uppNil, uppNil)
464 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
465 ppr_vol_regs sty (r:rs)
466 = let pp_reg = case r of
467 VanillaReg pk n -> pprVanillaReg n
468 _ -> pprMagicId sty r
469 (more_saves, more_restores) = ppr_vol_regs sty rs
471 (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
472 uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
474 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
475 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
476 -- depending on the platform. (The "volatile regs" stuff handles all
477 -- other registers.) Just be *sure* BaseReg is OK before trying to do
481 uppPStr SLIT("CALLER_SAVE_Base"),
482 uppPStr SLIT("CALLER_SAVE_SpA"),
483 uppPStr SLIT("CALLER_SAVE_SuA"),
484 uppPStr SLIT("CALLER_SAVE_SpB"),
485 uppPStr SLIT("CALLER_SAVE_SuB"),
486 uppPStr SLIT("CALLER_SAVE_Ret"),
487 -- uppPStr SLIT("CALLER_SAVE_Activity"),
488 uppPStr SLIT("CALLER_SAVE_Hp"),
489 uppPStr SLIT("CALLER_SAVE_HpLim") ]
493 uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
494 uppPStr SLIT("CALLER_RESTORE_SpA"),
495 uppPStr SLIT("CALLER_RESTORE_SuA"),
496 uppPStr SLIT("CALLER_RESTORE_SpB"),
497 uppPStr SLIT("CALLER_RESTORE_SuB"),
498 uppPStr SLIT("CALLER_RESTORE_Ret"),
499 -- uppPStr SLIT("CALLER_RESTORE_Activity"),
500 uppPStr SLIT("CALLER_RESTORE_Hp"),
501 uppPStr SLIT("CALLER_RESTORE_HpLim"),
502 uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
503 uppPStr SLIT("CALLER_RESTORE_StkStub") ]
507 if_profiling sty pretty
509 PprForC -> if opt_SccProfilingOn
511 else uppChar '0' -- leave it out!
513 _ -> {-print it anyway-} pretty
515 -- ---------------------------------------------------------------------------
516 -- Changes for GrAnSim:
517 -- draw costs for computation in head of if into both branches;
518 -- as no abstractC data structure is given for the head, one is constructed
519 -- guessing unknown values and fed into the costs function
520 -- ---------------------------------------------------------------------------
522 do_if_stmt sty discrim tag alt_code deflt c
524 -- This special case happens when testing the result of a comparison.
525 -- We can just avoid some redundant clutter in the output.
526 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
528 (addrModeCosts discrim Rhs) c
530 cond = uppBesides [ pprAmode sty discrim,
531 uppPStr SLIT(" == "),
532 pprAmode sty (CLit tag) ]
536 (addrModeCosts discrim Rhs) c
538 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
540 uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
541 uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
542 (Cost (0, 2, 0, 0, 0)) +
544 (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
545 uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
546 (Cost (0, 1, 0, 0, 0)) +
549 {- Total costs = inherited costs (before if) + costs for accessing discrim
550 + costs for cond branch ( = (0, 1, 0, 0, 0) )
551 + costs for that alternative
555 Historical note: this used to be two separate cases -- one for `ccall'
556 and one for `casm'. To get round a potential limitation to only 10
557 arguments, the numbering of arguments in @process_casm@ was beefed up a
560 Some rough notes on generating code for @CCallOp@:
562 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
563 2) Save any essential registers (heap, stack, etc).
565 ToDo: If stable pointers are in use, these must be saved in a place
566 where the runtime system can get at them so that the Stg world can
567 be restarted during the call.
569 3) Save any temporary registers that are currently in use.
570 4) Do the call putting result into a local variable
571 5) Restore essential registers
572 6) Restore temporaries
574 (This happens after restoration of essential registers because we
575 might need the @Base@ register to access all the others correctly.)
577 {- Doesn't apply anymore with ForeignObj, structure create via primop.
578 makeForeignObj (ForeignObj is not CReturnable)
579 7) If returning Malloc Pointer, build a closure containing the
582 Otherwise, copy local variable into result register.
584 8) If ccall (not casm), declare the function being called as extern so
585 that C knows if it returns anything other than an int.
588 { ResultType _ccall_result;
591 _ccall_result = f( args );
595 return_reg = _ccall_result;
599 Amendment to the above: if we can GC, we have to:
601 * make sure we save all our registers away where the garbage collector
603 * be sure that there are no live registers or we're in trouble.
604 (This can cause problems if you try something foolish like passing
605 an array or foreign obj to a _ccall_GC_ thing.)
606 * increment/decrement the @inCCallGC@ counter before/after the call so
607 that the runtime check that PerformGC is being used sensibly will work.
610 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
611 = if (may_gc && liveness_mask /= noLiveRegsMask)
612 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
616 declare_local_vars, -- local var for *result*
617 uppAboves local_arg_decls,
618 -- if is_asm then uppNil else declareExtern,
620 process_casm local_vars pp_non_void_args casm_str,
626 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
627 (pp_save_context, pp_restore_context) =
629 then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
630 uppStr "inCCallGC--; RestoreAllStgRegs();")
631 else ( pp_basic_saves `uppAbove` pp_saves,
632 pp_basic_restores `uppAbove` pp_restores)
636 in ASSERT (all non_void nvas) nvas
637 -- the first argument will be the "I/O world" token (a VoidRep)
638 -- all others should be non-void
641 let nvrs = grab_non_void_amodes results
642 in ASSERT (length nvrs <= 1) nvrs
643 -- there will usually be two results: a (void) state which we
644 -- should ignore and a (possibly void) result.
646 (local_arg_decls, pp_non_void_args)
647 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
649 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
651 (declare_local_vars, local_vars, assign_results)
652 = ppr_casm_results sty non_void_results pp_liveness
654 casm_str = if is_asm then _UNPK_ op_str else ccall_str
656 -- Remainder only used for ccall
658 ccall_str = uppShow 80
660 if null non_void_results
662 else uppPStr SLIT("%r = "),
663 uppLparen, uppPStr op_str, uppLparen,
664 uppIntersperse uppComma ccall_args,
667 num_args = length non_void_args
668 ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
671 If the argument is a heap object, we need to reach inside and pull out
672 the bit the C world wants to see. The only heap objects which can be
673 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
676 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
677 -- (a) decl and assignment, (b) local var to be used later
679 ppr_casm_arg sty amode a_num
681 a_kind = getAmodeRep amode
682 pp_amode = pprAmode sty amode
683 pp_kind = pprPrimKind sty a_kind
685 local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
687 (arg_type, pp_amode2)
690 -- for array arguments, pass a pointer to the body of the array
691 -- (PTRS_ARR_CTS skips over all the header nonsense)
692 ArrayRep -> (pp_kind,
693 uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
694 ByteArrayRep -> (pp_kind,
695 uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
697 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
698 ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
699 uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"])
700 other -> (pp_kind, pp_amode)
703 = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
705 (declare_local_var, local_var)
708 For l-values, the critical questions are:
710 1) Are there any results at all?
712 We only allow zero or one results.
714 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
715 2) Is the result is a foreign obj?
717 The mallocptr must be encapsulated immediately in a heap object.
722 -> [CAddrMode] -- list of results (length <= 1)
723 -> Unpretty -- liveness mask
725 ( Unpretty, -- declaration of any local vars
726 [Unpretty], -- list of result vars (same length as results)
727 Unpretty ) -- assignment (if any) of results in local var to registers
729 ppr_casm_results sty [] liveness
730 = (uppNil, [], uppNil) -- no results
732 ppr_casm_results sty [r] liveness
734 result_reg = ppr_amode sty r
735 r_kind = getAmodeRep r
737 local_var = uppPStr SLIT("_ccall_result")
739 (result_type, assign_result)
741 {- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
742 Instead, external references have to be turned into ForeignObjs
743 using the primop makeForeignObj#. Benefit: Multiple finalisation
744 routines can be accommodated and the below special case is not needed.
745 Price is, of course, that you have to explicitly wrap `foreign objects'
746 with makeForeignObj#.
749 (uppPStr SLIT("StgForeignObj"),
750 uppBesides [ uppStr "constructForeignObj(",
752 result_reg, uppComma,
756 (pprPrimKind sty r_kind,
757 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
759 declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
761 (declare_local_var, [local_var], assign_result)
763 ppr_casm_results sty rs liveness
764 = panic "ppr_casm_results: ccall/casm with many results"
768 Note the sneaky way _the_ result is represented by a list so that we
769 can complain if it's used twice.
771 ToDo: Any chance of giving line numbers when process-casm fails?
772 Or maybe we should do a check _much earlier_ in compiler. ADR
776 [Unpretty] -- results (length <= 1)
777 -> [Unpretty] -- arguments
778 -> String -- format string (with embedded %'s)
780 Unpretty -- code being generated
782 process_casm results args string = process results args string
784 process [] _ "" = uppNil
785 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
787 process ress args ('%':cs)
790 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
793 uppBeside (uppChar '%') (process ress args css)
797 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
798 [r] -> uppBeside r (process [] args css)
799 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
802 case readDec other of
804 if 0 <= num && num < length args
805 then uppBeside (uppParens (args !! num))
806 (process ress args css)
807 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
808 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
810 process ress args (other_c:cs)
811 = uppBeside (uppChar other_c) (process ress args cs)
814 %************************************************************************
816 \subsection[a2r-assignments]{Assignments}
818 %************************************************************************
820 Printing assignments is a little tricky because of type coercion.
822 First of all, the kind of the thing being assigned can be gotten from
823 the destination addressing mode. (It should be the same as the kind
824 of the source addressing mode.) If the kind of the assignment is of
825 @VoidRep@, then don't generate any code at all.
828 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
830 pprAssign sty VoidRep dest src = uppNil
833 Special treatment for floats and doubles, to avoid unwanted conversions.
836 pprAssign sty FloatRep dest@(CVal reg_rel _) src
837 = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
839 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
840 = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
843 Lastly, the question is: will the C compiler think the types of the
844 two sides of the assignment match?
846 We assume that the types will match
847 if neither side is a @CVal@ addressing mode for any register
848 which can point into the heap or B stack.
850 Why? Because the heap and B stack are used to store miscellaneous things,
851 whereas the A stack, temporaries, registers, etc., are only used for things
855 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
856 = uppBesides [ pprVanillaReg dest, uppEquals,
857 pprVanillaReg src, uppSemi ]
859 pprAssign sty kind dest src
861 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
862 = uppBesides [ ppr_amode sty dest, uppEquals,
863 uppStr "(W_)(", -- Here is the cast
864 ppr_amode sty src, pp_paren_semi ]
866 pprAssign sty kind dest src
867 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
868 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
869 = uppBesides [ ppr_amode sty dest, uppEquals,
870 uppStr "(P_)(", -- Here is the cast
871 ppr_amode sty src, pp_paren_semi ]
873 pprAssign sty ByteArrayRep dest src
875 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
876 = uppBesides [ ppr_amode sty dest, uppEquals,
877 uppStr "(B_)(", -- Here is the cast
878 ppr_amode sty src, pp_paren_semi ]
880 pprAssign sty kind other_dest src
881 = uppBesides [ ppr_amode sty other_dest, uppEquals,
882 pprAmode sty src, uppSemi ]
886 %************************************************************************
888 \subsection[a2r-CAddrModes]{Addressing modes}
890 %************************************************************************
892 @pprAmode@ is used to print r-values (which may need casts), whereas
893 @ppr_amode@ is used for l-values {\em and} as a help function for
897 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
900 For reasons discussed above under assignments, @CVal@ modes need
901 to be treated carefully. First come special cases for floats and doubles,
902 similar to those in @pprAssign@:
904 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
908 pprAmode sty (CVal reg_rel FloatRep)
909 = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
910 pprAmode sty (CVal reg_rel DoubleRep)
911 = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
914 Next comes the case where there is some other cast need, and the
919 | mixedTypeLocn amode
920 = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(",
921 ppr_amode sty amode ])
922 | otherwise -- No cast needed
923 = ppr_amode sty amode
926 Now the rest of the cases for ``workhorse'' @ppr_amode@:
929 ppr_amode sty (CVal reg_rel _)
930 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
931 (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
932 (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
934 ppr_amode sty (CAddr reg_rel)
935 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
936 (pp_reg, Nothing) -> pp_reg
937 (pp_reg, Just offset) -> uppBeside pp_reg offset
939 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
941 ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
943 ppr_amode sty (CLbl label kind) = pprCLabel sty label
945 ppr_amode sty (CUnVecLbl direct vectored)
946 = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
947 pprCLabel sty vectored, uppRparen]
949 ppr_amode sty (CCharLike char)
950 = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
951 ppr_amode sty (CIntLike int)
952 = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
954 ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
955 -- ToDo: are these *used* for anything?
957 ppr_amode sty (CLit lit) = pprBasicLit sty lit
959 ppr_amode sty (CLitLit str _) = uppPStr str
961 ppr_amode sty (COffset off) = pprHeapOffset sty off
963 ppr_amode sty (CCode abs_C)
964 = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
966 ppr_amode sty (CLabelledCode label abs_C)
967 = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"],
968 uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
970 ppr_amode sty (CJoinPoint _ _)
971 = panic "ppr_amode: CJoinPoint"
973 ppr_amode sty (CTableEntry base index kind)
974 = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
975 ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
978 ppr_amode sty (CMacroExpr pk macro as)
979 = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
980 uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
982 ppr_amode sty (CCostCentre cc print_as_string)
983 = uppCostCentre sty print_as_string cc
986 %************************************************************************
988 \subsection[a2r-MagicIds]{Magic ids}
990 %************************************************************************
992 @pprRegRelative@ returns a pair of the @Unpretty@ for the register
993 (some casting may be required), and a @Maybe Unpretty@ for the offset
994 (zero offset gives a @Nothing@).
997 addPlusSign :: Bool -> Unpretty -> Unpretty
998 addPlusSign False p = p
999 addPlusSign True p = uppBeside (uppChar '+') p
1001 pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
1002 pprSignedInt sign_wanted n
1003 = if n == 0 then Nothing else
1004 if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
1005 else Just (uppInt n)
1007 pprRegRelative :: PprStyle
1008 -> Bool -- True <=> Print leading plus sign (if +ve)
1010 -> (Unpretty, Maybe Unpretty)
1012 pprRegRelative sty sign_wanted (SpARel spA off)
1013 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1015 pprRegRelative sty sign_wanted (SpBRel spB off)
1016 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1018 pprRegRelative sty sign_wanted r@(HpRel hp off)
1019 = let to_print = hp `subOff` off
1020 pp_Hp = pprMagicId sty Hp
1022 if isZeroOff to_print then
1025 (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print)))
1026 -- No parens needed because pprHeapOffset
1027 -- does them when necessary
1029 pprRegRelative sty sign_wanted (NodeRel off)
1030 = let pp_Node = pprMagicId sty node
1032 if isZeroOff off then
1035 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1039 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1040 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1041 to select the union tag.
1044 pprMagicId :: PprStyle -> MagicId -> Unpretty
1046 pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
1047 pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
1048 pprMagicId sty (VanillaReg pk n)
1049 = uppBesides [ pprVanillaReg n, uppChar '.',
1051 pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
1052 pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
1053 pprMagicId sty TagReg = uppPStr SLIT("TagReg")
1054 pprMagicId sty RetReg = uppPStr SLIT("RetReg")
1055 pprMagicId sty SpA = uppPStr SLIT("SpA")
1056 pprMagicId sty SuA = uppPStr SLIT("SuA")
1057 pprMagicId sty SpB = uppPStr SLIT("SpB")
1058 pprMagicId sty SuB = uppPStr SLIT("SuB")
1059 pprMagicId sty Hp = uppPStr SLIT("Hp")
1060 pprMagicId sty HpLim = uppPStr SLIT("HpLim")
1061 pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
1062 pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
1063 pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
1064 pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
1065 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1067 pprVanillaReg :: FAST_INT -> Unpretty
1069 pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
1071 pprUnionTag :: PrimRep -> Unpretty
1073 pprUnionTag PtrRep = uppChar 'p'
1074 pprUnionTag CodePtrRep = uppPStr SLIT("fp")
1075 pprUnionTag DataPtrRep = uppChar 'd'
1076 pprUnionTag RetRep = uppChar 'r'
1077 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1079 pprUnionTag CharRep = uppChar 'c'
1080 pprUnionTag IntRep = uppChar 'i'
1081 pprUnionTag WordRep = uppChar 'w'
1082 pprUnionTag AddrRep = uppChar 'v'
1083 pprUnionTag FloatRep = uppChar 'f'
1084 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1086 pprUnionTag StablePtrRep = uppChar 'i'
1087 pprUnionTag ForeignObjRep = uppChar 'p'
1089 pprUnionTag ArrayRep = uppChar 'p'
1090 pprUnionTag ByteArrayRep = uppChar 'b'
1092 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1096 Find and print local and external declarations for a list of
1097 Abstract~C statements.
1099 pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-})
1100 pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
1102 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1103 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1104 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1105 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1106 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1107 returnTE (uppAboves real_temps, uppAboves real_exts) }}
1110 pprTempAndExternDecls other_stmt
1111 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1122 pprBasicLit :: PprStyle -> Literal -> Unpretty
1123 pprPrimKind :: PprStyle -> PrimRep -> Unpretty
1125 pprBasicLit sty lit = uppStr (showLiteral sty lit)
1126 pprPrimKind sty k = uppStr (showPrimRep k)
1130 %************************************************************************
1132 \subsection[a2r-monad]{Monadery}
1134 %************************************************************************
1136 We need some monadery to keep track of temps and externs we have already
1137 printed. This info must be threaded right through the Abstract~C, so
1138 it's most convenient to hide it in this monad.
1140 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1141 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1144 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1145 emptyCLabelSet = emptyFM
1146 x `elementOfCLabelSet` labs
1147 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1148 addToCLabelSet set x = addToFM set x ()
1150 type TEenv = (UniqSet Unique, CLabelSet)
1152 type TeM result = TEenv -> (TEenv, result)
1154 initTE :: TeM a -> a
1156 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1159 {-# INLINE thenTE #-}
1160 {-# INLINE returnTE #-}
1162 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1164 = case a u of { (u_1, result_of_a) ->
1167 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1168 mapTE f [] = returnTE []
1170 = f x `thenTE` \ r ->
1171 mapTE f xs `thenTE` \ rs ->
1174 returnTE :: a -> TeM a
1175 returnTE result env = (env, result)
1177 -- these next two check whether the thing is already
1178 -- recorded, and THEN THEY RECORD IT
1179 -- (subsequent calls will return False for the same uniq/label)
1181 tempSeenTE :: Unique -> TeM Bool
1182 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1183 = if (uniq `elementOfUniqSet` seen_uniqs)
1185 else ((addOneToUniqSet seen_uniqs uniq,
1189 labelSeenTE :: CLabel -> TeM Bool
1190 labelSeenTE label env@(seen_uniqs, seen_labels)
1191 = if (label `elementOfCLabelSet` seen_labels)
1194 addToCLabelSet seen_labels label),
1199 pprTempDecl :: Unique -> PrimRep -> Unpretty
1200 pprTempDecl uniq kind
1201 = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
1203 pprExternDecl :: CLabel -> PrimRep -> Unpretty
1205 pprExternDecl clabel kind
1206 = if not (needsCDecl clabel) then
1207 uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
1211 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1212 _ -> ppLocalnessMacro False{-data-} clabel
1213 ) of { pp_macro_str ->
1215 uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
1220 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
1222 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1224 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1225 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1226 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1227 returnTE (maybe_uppAboves [p1, p2])
1229 ppr_decls_AbsC (CClosureUpdInfo info)
1230 = ppr_decls_AbsC info
1232 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1234 ppr_decls_AbsC (CAssign dest source)
1235 = ppr_decls_Amode dest `thenTE` \ p1 ->
1236 ppr_decls_Amode source `thenTE` \ p2 ->
1237 returnTE (maybe_uppAboves [p1, p2])
1239 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1241 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1243 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1245 ppr_decls_AbsC (CSwitch discrim alts deflt)
1246 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1247 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1248 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1249 returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
1251 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1253 ppr_decls_AbsC (CCodeBlock label absC)
1254 = ppr_decls_AbsC absC
1256 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1257 -- ToDo: strictly speaking, should chk "cost_centre" amode
1258 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1263 Just (pprExternDecl info_lbl PtrRep))
1265 info_lbl = infoTableLabelFromCI cl_info
1267 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1268 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1270 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1272 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1273 -- you get some nasty re-decls of stdio.h if you compile
1274 -- the prelude while looking inside those amodes;
1275 -- no real reason to, anyway.
1276 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1278 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1279 -- ToDo: strictly speaking, should chk "cost_centre" amode
1280 = ppr_decls_Amodes amodes
1282 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1283 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1284 ppr_decls_AbsC slow `thenTE` \ p2 ->
1286 Nothing -> returnTE (Nothing, Nothing)
1287 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1288 returnTE (maybe_uppAboves [p1, p2, p3])
1290 entry_lbl = CLbl slow_lbl CodePtrRep
1291 slow_lbl = case (nonemptyAbsC slow) of
1292 Nothing -> mkErrorStdEntryLabel
1293 Just _ -> entryLabelFromCI cl_info
1295 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1296 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1297 ppr_decls_AbsC absC `thenTE` \ p2 ->
1298 returnTE (maybe_uppAboves [p1, p2])
1300 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1301 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1305 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
1306 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1307 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1308 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1309 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1310 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1311 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1312 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1314 -- CIntLike must be a literal -- no decls
1315 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1317 -- CCharLike may have be arbitrary value -- may have decls
1318 ppr_decls_Amode (CCharLike char)
1319 = ppr_decls_Amode char
1321 -- now, the only place where we actually print temps/externs...
1322 ppr_decls_Amode (CTemp uniq kind)
1324 VoidRep -> returnTE (Nothing, Nothing)
1326 tempSeenTE uniq `thenTE` \ temp_seen ->
1328 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1330 ppr_decls_Amode (CLbl label VoidRep)
1331 = returnTE (Nothing, Nothing)
1333 ppr_decls_Amode (CLbl label kind)
1334 = labelSeenTE label `thenTE` \ label_seen ->
1336 if label_seen then Nothing else Just (pprExternDecl label kind))
1339 ppr_decls_Amode (CUnVecLbl direct vectored)
1340 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1341 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1343 ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
1344 vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
1347 if (dlbl_seen || not (needsCDecl direct)) &&
1348 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1349 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1352 ppr_decls_Amode (CUnVecLbl direct vectored)
1353 = -- We don't mark either label as "seen", because
1354 -- we don't know which one will be used and which one tossed
1355 -- by the C macro...
1356 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1357 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1359 ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
1360 vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
1363 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1364 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1365 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1367 ppr_decls_Amode (CTableEntry base index _)
1368 = ppr_decls_Amode base `thenTE` \ p1 ->
1369 ppr_decls_Amode index `thenTE` \ p2 ->
1370 returnTE (maybe_uppAboves [p1, p2])
1372 ppr_decls_Amode (CMacroExpr _ _ amodes)
1373 = ppr_decls_Amodes amodes
1375 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1378 maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
1380 = case (unzip ps) of { (ts, es) ->
1381 case (catMaybes ts) of { real_ts ->
1382 case (catMaybes es) of { real_es ->
1383 (if (null real_ts) then Nothing else Just (uppAboves real_ts),
1384 if (null real_es) then Nothing else Just (uppAboves real_es))
1389 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
1390 ppr_decls_Amodes amodes
1391 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1392 returnTE ( maybe_uppAboves ps )