2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[PprAbsC]{Pretty-printing Abstract~C}
8 %************************************************************************
11 #include "HsVersions.h"
17 pprAmode, -- otherwise, not exported
20 -- and for interface self-sufficiency...
21 AbstractC, CAddrMode, MagicId,
25 IMPORT_Trace -- ToDo: rm (debugging only)
29 import PrelInfo ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
30 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
32 import Literal ( literalPrimRep, showLiteral )
33 import CLabel -- lots of things
34 import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
35 import CgRetConv ( noLiveRegsMask )
36 import ClosureInfo -- quite a few things
37 import Costs -- for GrAnSim; cost counting function -- HWL
40 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
42 import Pretty ( codeStyle, prettyToUn )
43 import PrimRep ( showPrimRep, isFloatingRep, PrimRep(..) )
46 import Unpretty -- ********** NOTE **********
52 For spitting out the costs of an abstract~C expression, @writeRealC@
53 now not only prints the C~code of the @absC@ arg but also adds a macro
54 call to a cost evaluation function @GRAN_EXEC@. For that,
55 @pprAbsC@ has a new ``costs'' argument. %% HWL
58 writeRealC :: _FILE -> AbstractC -> PrimIO ()
60 writeRealC sw_chker file absC
61 = uppAppendFile file 80 (
62 uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
65 dumpRealC :: AbstractC -> String
67 dumpRealC sw_chker absC
69 uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
73 This emits the macro, which is used in GrAnSim to compute the total costs
74 from a cost 5 tuple. %% HWL
77 emitMacro :: CostRes -> Unpretty
82 emitMacro (Cost (i,b,l,s,f))
83 = uppBesides [ uppStr "GRAN_EXEC(",
84 uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
85 uppInt s, uppComma, uppInt f, pp_paren_semi ]
90 pp_paren_semi = uppStr ");"
92 -- ---------------------------------------------------------------------------
93 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
94 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
95 -- which must be done before the return i.e. inside absC code) HWL
96 -- ---------------------------------------------------------------------------
98 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
100 pprAbsC sty AbsCNop _ = uppNil
101 pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
103 pprAbsC sty (CClosureUpdInfo info) c
106 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
108 pprAbsC sty (CJump target) c
109 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
110 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
112 pprAbsC sty (CFallThrough target) c
113 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
114 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
116 -- --------------------------------------------------------------------------
117 -- Spit out GRAN_EXEC macro immediately before the return HWL
119 pprAbsC sty (CReturn am return_info) c
120 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
121 (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
123 target = case return_info of
124 DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
125 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
126 StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
127 mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
129 pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
131 -- we optimise various degenerate cases of CSwitches.
133 -- --------------------------------------------------------------------------
134 -- Assume: CSwitch is also end of basic block
135 -- costs function yields nullCosts for whole switch
136 -- ==> inherited costs c are those of basic block up to switch
137 -- ==> inherit c + costs for the corresponding branch
139 -- --------------------------------------------------------------------------
141 pprAbsC sty (CSwitch discrim [] deflt) c
142 = pprAbsC sty deflt (c + costs deflt)
143 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
145 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
146 = case (nonemptyAbsC deflt) of
147 Nothing -> -- one alt and no default
148 pprAbsC sty alt_code (c + costs alt_code)
149 -- Nothing conditional in here either HWL
151 Just dc -> -- make it an "if"
152 do_if_stmt sty discrim tag alt_code dc c
154 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
155 (tag2@(MachInt i2 _), alt_code2)] deflt) c
156 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
158 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
160 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
162 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
164 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
165 | isFloatingRep (getAmodeRep discrim)
166 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
169 uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
170 uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
171 (case (nonemptyAbsC deflt) of
174 uppNest 2 (uppAboves [uppPStr SLIT("default:"),
175 pprAbsC sty dc (c + switch_head_cost
177 uppPStr SLIT("break;")])),
181 = pprAmode sty discrim
183 ppr_alt sty (lit, absC)
184 = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
185 uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
186 (uppPStr SLIT("break;"))) ]
188 -- Costs for addressing header of switch and cond. branching -- HWL
189 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
191 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
192 = pprCCall sty op args results liveness_mask vol_regs
194 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
196 non_void_args = grab_non_void_amodes args
197 non_void_results = grab_non_void_amodes results
198 -- if just one result, we print in the obvious "assignment" style;
199 -- if 0 or many results, we emit a macro call, w/ the results
200 -- followed by the arguments. The macro presumably knows which
203 the_op = ppr_op_call non_void_results non_void_args
204 -- liveness mask is *in* the non_void_args
206 BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
207 if primOpNeedsWrapper op then
208 uppAboves [ pp_saves,
216 ppr_op_call results args
217 = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
218 uppIntersperse uppComma (map ppr_op_result results),
219 if null results || null args then uppNil else uppComma,
220 uppIntersperse uppComma (map (pprAmode sty) args),
223 ppr_op_result r = ppr_amode sty r
224 -- primop macros do their own casting of result;
225 -- hence we can toss the provided cast...
227 pprAbsC sty (CSimultaneous abs_c) c
228 = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"]
230 pprAbsC sty stmt@(CMacroStmt macro as) _
231 = uppBesides [uppStr (show macro), uppLparen,
232 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
233 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
234 = uppBesides [uppPStr op, uppLparen,
235 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
236 pprAbsC sty stmt@(CCallProfCCMacro op as) _
237 = uppBesides [uppPStr op, uppLparen,
238 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
240 pprAbsC sty (CCodeBlock label abs_C) _
241 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
242 BIND (pprTempAndExternDecls abs_C) _TO_ (pp_temps, pp_exts) ->
244 uppBesides [uppStr (if (externallyVisibleCLabel label)
245 then "FN_(" -- abbreviations to save on output
247 pprCLabel sty label, uppStr ") {"],
249 PprForC _ -> uppAbove pp_exts pp_temps
251 uppNest 8 (uppPStr SLIT("FB_")),
252 uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
253 uppNest 8 (uppPStr SLIT("FE_")),
257 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
258 = uppBesides [ pp_init_hdr, uppStr "_HDR(",
259 ppr_amode sty (CAddr reg_rel), uppComma,
260 pprCLabel sty info_lbl, uppComma,
261 if_profiling sty (pprAmode sty cost_centre), uppComma,
262 pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
264 info_lbl = infoTableLabelFromCI cl_info
265 sm_rep = closureSMRep cl_info
266 size = closureSizeWithoutFixedHdr cl_info
267 ptr_wds = closurePtrsSize cl_info
269 pp_init_hdr = uppStr (if inplace_upd then
270 getSMUpdInplaceHdrStr sm_rep
272 getSMInitHdrStr sm_rep)
274 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
275 = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
281 uppStr "SET_STATIC_HDR(",
282 pprCLabel sty closure_lbl, uppComma,
283 pprCLabel sty info_lbl, uppComma,
284 if_profiling sty (pprAmode sty cost_centre), uppComma,
285 ppLocalness closure_lbl, uppComma,
286 ppLocalnessMacro False{-for data-} info_lbl,
289 uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
290 uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
294 info_lbl = infoTableLabelFromCI cl_info
297 = if getAmodeRep item == VoidRep
298 then uppStr ", (W_) 0" -- might not even need this...
299 else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
302 if not (closureUpdReqd cl_info) then
305 BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed ->
306 nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
310 STATIC_INIT_HDR(c,i,localness) blows into:
311 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
313 then *NO VarHdr STUFF FOR STATIC*...
315 then the amodes are dropped in...
321 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
326 pprCLabel sty info_lbl, uppComma,
328 -- CONST_ITBL needs an extra label for
329 -- the static version of the object.
330 if isConstantRep sm_rep
331 then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
334 pprCLabel sty slow_lbl, uppComma,
335 pprAmode sty upd, uppComma,
336 uppInt liveness, uppComma,
340 pp_ptr_wds, uppComma,
342 ppLocalness info_lbl, uppComma,
343 ppLocalnessMacro True{-function-} slow_lbl, uppComma,
346 then uppBeside (uppInt select_word_i) uppComma
349 if_profiling sty pp_kind, uppComma,
350 if_profiling sty pp_descr, uppComma,
351 if_profiling sty pp_type,
357 Just fast -> let stuff = CCodeBlock fast_lbl fast in
358 pprAbsC sty stuff (costs stuff)
361 info_lbl = infoTableLabelFromCI cl_info
362 fast_lbl = fastLabelFromCI cl_info
363 sm_rep = closureSMRep cl_info
366 = case (nonemptyAbsC slow) of
367 Nothing -> (mkErrorStdEntryLabel, uppNil)
368 Just xx -> (entryLabelFromCI cl_info,
369 let stuff = CCodeBlock slow_lbl xx in
370 pprAbsC sty stuff (costs stuff))
372 maybe_selector = maybeSelectorInfo cl_info
373 is_selector = maybeToBool maybe_selector
374 (Just (_, select_word_i)) = maybe_selector
376 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
377 = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
379 pp_tag = uppInt (closureSemiTag cl_info)
381 is_phantom = isPhantomRep sm_rep
383 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
384 uppInt (closureNonHdrSize cl_info)
386 else if is_phantom then -- do not have sizes for these
389 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
391 pp_ptr_wds = if is_phantom then
394 uppInt (closurePtrsSize cl_info)
396 pp_kind = uppStr (closureKind cl_info)
397 pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
398 pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
400 pprAbsC sty (CRetVector lbl maybes deflt) c
401 = uppAboves [ uppStr "{ // CRetVector (lbl????)",
402 uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
403 uppStr "} /*default=*/ {", pprAbsC sty deflt c,
406 ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
407 ppr_maybe_amode sty (Just a) = pprAmode sty a
409 pprAbsC sty stmt@(CRetUnVector label amode) _
410 = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma,
411 pprAmode sty amode, uppRparen]
413 pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
415 pprAbsC sty stmt@(CFlatRetVector label amodes) _
416 = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
421 uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
422 pprCLabel sty label, uppStr "[] = {"],
423 uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
427 ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
429 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
434 = uppBeside static const
436 static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
437 const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
439 ppLocalnessMacro for_fun{-vs data-} clabel
440 = BIND (if externallyVisibleCLabel clabel then "E" else "I") _TO_ prefix ->
441 BIND (if isReadOnly clabel then "RO_" else "") _TO_ suffix ->
443 then uppStr (prefix ++ "F_")
444 else uppStr (prefix ++ "D_" ++ suffix)
449 grab_non_void_amodes amodes
450 = filter non_void amodes
453 = case (getAmodeRep amode) of
459 ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
461 ppr_vol_regs sty [] = (uppNil, uppNil)
462 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
463 ppr_vol_regs sty (r:rs)
464 = let pp_reg = case r of
465 VanillaReg pk n -> pprVanillaReg n
466 _ -> pprMagicId sty r
467 (more_saves, more_restores) = ppr_vol_regs sty rs
469 (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
470 uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
472 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
473 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
474 -- depending on the platform. (The "volatile regs" stuff handles all
475 -- other registers.) Just be *sure* BaseReg is OK before trying to do
479 uppPStr SLIT("CALLER_SAVE_Base"),
480 uppPStr SLIT("CALLER_SAVE_SpA"),
481 uppPStr SLIT("CALLER_SAVE_SuA"),
482 uppPStr SLIT("CALLER_SAVE_SpB"),
483 uppPStr SLIT("CALLER_SAVE_SuB"),
484 uppPStr SLIT("CALLER_SAVE_Ret"),
485 -- uppPStr SLIT("CALLER_SAVE_Activity"),
486 uppPStr SLIT("CALLER_SAVE_Hp"),
487 uppPStr SLIT("CALLER_SAVE_HpLim") ]
491 uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
492 uppPStr SLIT("CALLER_RESTORE_SpA"),
493 uppPStr SLIT("CALLER_RESTORE_SuA"),
494 uppPStr SLIT("CALLER_RESTORE_SpB"),
495 uppPStr SLIT("CALLER_RESTORE_SuB"),
496 uppPStr SLIT("CALLER_RESTORE_Ret"),
497 -- uppPStr SLIT("CALLER_RESTORE_Activity"),
498 uppPStr SLIT("CALLER_RESTORE_Hp"),
499 uppPStr SLIT("CALLER_RESTORE_HpLim"),
500 uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
501 uppPStr SLIT("CALLER_RESTORE_StkStub") ]
505 if_profiling sty pretty
507 PprForC sw_chker -> if sw_chker SccProfilingOn
509 else uppChar '0' -- leave it out!
511 _ -> {-print it anyway-} pretty
513 -- ---------------------------------------------------------------------------
514 -- Changes for GrAnSim:
515 -- draw costs for computation in head of if into both branches;
516 -- as no abstractC data structure is given for the head, one is constructed
517 -- guessing unknown values and fed into the costs function
518 -- ---------------------------------------------------------------------------
520 do_if_stmt sty discrim tag alt_code deflt c
522 -- This special case happens when testing the result of a comparison.
523 -- We can just avoid some redundant clutter in the output.
524 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
526 (addrModeCosts discrim Rhs) c
528 cond = uppBesides [ pprAmode sty discrim,
529 uppPStr SLIT(" == "),
530 pprAmode sty (CLit tag) ]
534 (addrModeCosts discrim Rhs) c
536 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
538 uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
539 uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
540 (Cost (0, 2, 0, 0, 0)) +
542 (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
543 uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
544 (Cost (0, 1, 0, 0, 0)) +
547 {- Total costs = inherited costs (before if) + costs for accessing discrim
548 + costs for cond branch ( = (0, 1, 0, 0, 0) )
549 + costs for that alternative
553 Historical note: this used to be two separate cases -- one for `ccall'
554 and one for `casm'. To get round a potential limitation to only 10
555 arguments, the numbering of arguments in @process_casm@ was beefed up a
558 Some rough notes on generating code for @CCallOp@:
560 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
561 2) Save any essential registers (heap, stack, etc).
563 ToDo: If stable pointers are in use, these must be saved in a place
564 where the runtime system can get at them so that the Stg world can
565 be restarted during the call.
567 3) Save any temporary registers that are currently in use.
568 4) Do the call putting result into a local variable
569 5) Restore essential registers
570 6) Restore temporaries
572 (This happens after restoration of essential registers because we
573 might need the @Base@ register to access all the others correctly.)
575 7) If returning Malloc Pointer, build a closure containing the
578 Otherwise, copy local variable into result register.
580 8) If ccall (not casm), declare the function being called as extern so
581 that C knows if it returns anything other than an int.
584 { ResultType _ccall_result;
587 _ccall_result = f( args );
592 constructMallocPtr(liveness, return_reg, _ccall_result);
594 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 mallocptr 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")
614 -- trace ("casm \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat localVars)) ++ (uppShow 80 (uppCat pp_non_void_args)))
617 declare_local_vars, -- local var for *result*
618 uppAboves local_arg_decls,
619 -- if is_asm then uppNil else declareExtern,
621 process_casm local_vars pp_non_void_args casm_str,
627 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
628 (pp_save_context, pp_restore_context) =
630 then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
631 uppStr "inCCallGC--; RestoreAllStgRegs();")
632 else ( pp_basic_saves `uppAbove` pp_saves,
633 pp_basic_restores `uppAbove` pp_restores)
637 in ASSERT (all non_void nvas) nvas
638 -- the first argument will be the "I/O world" token (a VoidRep)
639 -- all others should be non-void
642 let nvrs = grab_non_void_amodes results
643 in ASSERT (length nvrs <= 1) nvrs
644 -- there will usually be two results: a (void) state which we
645 -- should ignore and a (possibly void) result.
647 (local_arg_decls, pp_non_void_args)
648 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
650 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
652 (declare_local_vars, local_vars, assign_results)
653 = ppr_casm_results sty non_void_results pp_liveness
655 casm_str = if is_asm then _UNPK_ op_str else ccall_str
657 -- Remainder only used for ccall
659 ccall_str = uppShow 80
661 if null non_void_results
663 else uppPStr SLIT("%r = "),
664 uppLparen, uppPStr op_str, uppLparen,
665 uppIntersperse uppComma ccall_args,
668 num_args = length non_void_args
669 ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
672 If the argument is a heap object, we need to reach inside and pull out
673 the bit the C world wants to see. The only heap objects which can be
674 passed are @Array@s, @ByteArray@s and @MallocPtr@s.
677 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
678 -- (a) decl and assignment, (b) local var to be used later
680 ppr_casm_arg sty amode a_num
682 a_kind = getAmodeRep amode
683 pp_amode = pprAmode sty amode
684 pp_kind = pprPrimKind sty a_kind
686 local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
688 (arg_type, pp_amode2)
691 -- for array arguments, pass a pointer to the body of the array
692 -- (PTRS_ARR_CTS skips over all the header nonsense)
693 ArrayRep -> (pp_kind,
694 uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
695 ByteArrayRep -> (pp_kind,
696 uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
698 -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents.
699 MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"),
700 uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
701 other -> (pp_kind, pp_amode)
704 = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
706 (declare_local_var, local_var)
709 For l-values, the critical questions are:
711 1) Are there any results at all?
713 We only allow zero or one results.
715 2) Is the result is a mallocptr?
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)
742 (uppPStr SLIT("StgMallocPtr"),
743 uppBesides [ uppStr "constructMallocPtr(",
745 result_reg, uppComma,
749 (pprPrimKind sty r_kind,
750 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
752 declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
754 (declare_local_var, [local_var], assign_result)
756 ppr_casm_results sty rs liveness
757 = panic "ppr_casm_results: ccall/casm with many results"
761 Note the sneaky way _the_ result is represented by a list so that we
762 can complain if it's used twice.
764 ToDo: Any chance of giving line numbers when process-casm fails?
765 Or maybe we should do a check _much earlier_ in compiler. ADR
769 [Unpretty] -- results (length <= 1)
770 -> [Unpretty] -- arguments
771 -> String -- format string (with embedded %'s)
773 Unpretty -- code being generated
775 process_casm results args string = process results args string
777 process [] _ "" = uppNil
778 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
780 process ress args ('%':cs)
783 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
786 uppBeside (uppChar '%') (process ress args css)
790 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
791 [r] -> uppBeside r (process [] args css)
792 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
795 case readDec other of
797 if 0 <= num && num < length args
798 then uppBesides [uppLparen, args !! num, uppRparen,
799 process ress args css]
800 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
801 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
803 process ress args (other_c:cs)
804 = uppBeside (uppChar other_c) (process ress args cs)
807 %************************************************************************
809 \subsection[a2r-assignments]{Assignments}
811 %************************************************************************
813 Printing assignments is a little tricky because of type coercion.
815 First of all, the kind of the thing being assigned can be gotten from
816 the destination addressing mode. (It should be the same as the kind
817 of the source addressing mode.) If the kind of the assignment is of
818 @VoidRep@, then don't generate any code at all.
821 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
823 pprAssign sty VoidRep dest src = uppNil
826 pprAssign sty kind dest src
827 | (kind /= getAmodeRep dest) || (kind /= getAmodeRep src)
828 = uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
829 pprPrimKind sty (getAmodeRep dest), pprAmode sty dest,
830 pprPrimKind sty (getAmodeRep src), pprAmode sty src]
834 Special treatment for floats and doubles, to avoid unwanted conversions.
837 pprAssign sty FloatRep dest@(CVal reg_rel _) src
838 = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
840 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
841 = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
844 Lastly, the question is: will the C compiler think the types of the
845 two sides of the assignment match?
847 We assume that the types will match
848 if neither side is a @CVal@ addressing mode for any register
849 which can point into the heap or B stack.
851 Why? Because the heap and B stack are used to store miscellaneous things,
852 whereas the A stack, temporaries, registers, etc., are only used for things
856 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
857 = uppBesides [ pprVanillaReg dest, uppEquals,
858 pprVanillaReg src, uppSemi ]
860 pprAssign sty kind dest src
862 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
863 = uppBesides [ ppr_amode sty dest, uppEquals,
864 uppStr "(W_)(", -- Here is the cast
865 ppr_amode sty src, pp_paren_semi ]
867 pprAssign sty kind dest src
868 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
869 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
870 = uppBesides [ ppr_amode sty dest, uppEquals,
871 uppStr "(P_)(", -- Here is the cast
872 ppr_amode sty src, pp_paren_semi ]
874 pprAssign sty ByteArrayRep dest src
876 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
877 = uppBesides [ ppr_amode sty dest, uppEquals,
878 uppStr "(B_)(", -- Here is the cast
879 ppr_amode sty src, pp_paren_semi ]
881 pprAssign sty kind other_dest src
882 = uppBesides [ ppr_amode sty other_dest, uppEquals,
883 pprAmode sty src, uppSemi ]
887 %************************************************************************
889 \subsection[a2r-CAddrModes]{Addressing modes}
891 %************************************************************************
893 @pprAmode@ is used to print r-values (which may need casts), whereas
894 @ppr_amode@ is used for l-values {\em and} as a help function for
898 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
901 For reasons discussed above under assignments, @CVal@ modes need
902 to be treated carefully. First come special cases for floats and doubles,
903 similar to those in @pprAssign@:
905 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
909 pprAmode sty (CVal reg_rel FloatRep)
910 = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
911 pprAmode sty (CVal reg_rel DoubleRep)
912 = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
915 Next comes the case where there is some other cast need, and the
920 | mixedTypeLocn amode
921 = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(",
922 ppr_amode sty amode, uppRparen]
923 | otherwise -- No cast needed
924 = ppr_amode sty amode
927 Now the rest of the cases for ``workhorse'' @ppr_amode@:
930 ppr_amode sty (CVal reg_rel _)
931 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
932 (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
933 (pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
935 ppr_amode sty (CAddr reg_rel)
936 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
937 (pp_reg, Nothing) -> pp_reg
938 (pp_reg, Just offset) -> uppBeside pp_reg offset
940 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
942 ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
944 ppr_amode sty (CLbl label kind) = pprCLabel sty label
946 ppr_amode sty (CUnVecLbl direct vectored)
947 = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
948 pprCLabel sty vectored, uppRparen]
950 ppr_amode sty (CCharLike char)
951 = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
952 ppr_amode sty (CIntLike int)
953 = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
955 ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
956 -- ToDo: are these *used* for anything?
958 ppr_amode sty (CLit lit) = pprBasicLit sty lit
960 ppr_amode sty (CLitLit str _) = uppPStr str
962 ppr_amode sty (COffset off) = pprHeapOffset sty off
964 ppr_amode sty (CCode abs_C)
965 = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
967 ppr_amode sty (CLabelledCode label abs_C)
968 = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"],
969 uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
971 ppr_amode sty (CJoinPoint _ _)
972 = panic "ppr_amode: CJoinPoint"
974 ppr_amode sty (CTableEntry base index kind)
975 = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
976 ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
979 ppr_amode sty (CMacroExpr pk macro as)
980 = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
981 uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
983 ppr_amode sty (CCostCentre cc print_as_string)
984 = uppCostCentre sty print_as_string cc
987 %************************************************************************
989 \subsection[a2r-MagicIds]{Magic ids}
991 %************************************************************************
993 @pprRegRelative@ returns a pair of the @Unpretty@ for the register
994 (some casting may be required), and a @Maybe Unpretty@ for the offset
995 (zero offset gives a @Nothing@).
998 addPlusSign :: Bool -> Unpretty -> Unpretty
999 addPlusSign False p = p
1000 addPlusSign True p = uppBeside (uppChar '+') p
1002 pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
1003 pprSignedInt sign_wanted n
1004 = if n == 0 then Nothing else
1005 if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
1006 else Just (uppInt n)
1008 pprRegRelative :: PprStyle
1009 -> Bool -- True <=> Print leading plus sign (if +ve)
1011 -> (Unpretty, Maybe Unpretty)
1013 pprRegRelative sty sign_wanted (SpARel spA off)
1014 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1016 pprRegRelative sty sign_wanted (SpBRel spB off)
1017 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1019 pprRegRelative sty sign_wanted r@(HpRel hp off)
1020 = let to_print = hp `subOff` off
1021 pp_Hp = pprMagicId sty Hp
1023 if isZeroOff to_print then
1026 (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print)))
1027 -- No parens needed because pprHeapOffset
1028 -- does them when necessary
1030 pprRegRelative sty sign_wanted (NodeRel off)
1031 = let pp_Node = pprMagicId sty node
1033 if isZeroOff off then
1036 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1040 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1041 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1042 to select the union tag.
1045 pprMagicId :: PprStyle -> MagicId -> Unpretty
1047 pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
1048 pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
1049 pprMagicId sty (VanillaReg pk n)
1050 = uppBesides [ pprVanillaReg n, uppChar '.',
1052 pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
1053 pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
1054 pprMagicId sty TagReg = uppPStr SLIT("TagReg")
1055 pprMagicId sty RetReg = uppPStr SLIT("RetReg")
1056 pprMagicId sty SpA = uppPStr SLIT("SpA")
1057 pprMagicId sty SuA = uppPStr SLIT("SuA")
1058 pprMagicId sty SpB = uppPStr SLIT("SpB")
1059 pprMagicId sty SuB = uppPStr SLIT("SuB")
1060 pprMagicId sty Hp = uppPStr SLIT("Hp")
1061 pprMagicId sty HpLim = uppPStr SLIT("HpLim")
1062 pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
1063 pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
1064 pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
1065 pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
1066 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1068 pprVanillaReg :: FAST_INT -> Unpretty
1070 pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
1072 pprUnionTag :: PrimRep -> Unpretty
1074 pprUnionTag PtrRep = uppChar 'p'
1075 pprUnionTag CodePtrRep = uppPStr SLIT("fp")
1076 pprUnionTag DataPtrRep = uppChar 'd'
1077 pprUnionTag RetRep = uppChar 'r'
1078 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1080 pprUnionTag CharRep = uppChar 'c'
1081 pprUnionTag IntRep = uppChar 'i'
1082 pprUnionTag WordRep = uppChar 'w'
1083 pprUnionTag AddrRep = uppChar 'v'
1084 pprUnionTag FloatRep = uppChar 'f'
1085 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1087 pprUnionTag StablePtrRep = uppChar 'i'
1088 pprUnionTag MallocPtrRep = uppChar 'p'
1090 pprUnionTag ArrayRep = uppChar 'p'
1091 pprUnionTag ByteArrayRep = uppChar 'b'
1093 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1097 Find and print local and external declarations for a list of
1098 Abstract~C statements.
1100 pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-})
1101 pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
1103 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1104 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1105 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1106 BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps ->
1107 BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts ->
1108 returnTE (uppAboves real_temps, uppAboves real_exts)
1112 pprTempAndExternDecls other_stmt
1113 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1124 pprBasicLit :: PprStyle -> Literal -> Unpretty
1125 pprPrimKind :: PprStyle -> PrimRep -> Unpretty
1127 pprBasicLit sty lit = uppStr (showLiteral sty lit)
1128 pprPrimKind sty k = uppStr (showPrimRep k)
1132 %************************************************************************
1134 \subsection[a2r-monad]{Monadery}
1136 %************************************************************************
1138 We need some monadery to keep track of temps and externs we have already
1139 printed. This info must be threaded right through the Abstract~C, so
1140 it's most convenient to hide it in this monad.
1142 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1143 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1146 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1147 emptyCLabelSet = emptyFM
1148 x `elementOfCLabelSet` labs
1149 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1150 addToCLabelSet set x = addToFM set x ()
1152 type UniqueSet = UniqFM ()
1153 emptyUniqueSet = emptyUFM
1154 x `elementOfUniqueSet` us
1155 = case (lookupDirectlyUFM us x) of { Just _ -> True; Nothing -> False }
1156 addToUniqueSet set x = set `plusUFM` singletonDirectlyUFM x ()
1158 type TEenv = (UniqueSet, CLabelSet)
1160 type TeM result = TEenv -> (TEenv, result)
1162 initTE :: TeM a -> a
1164 = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
1167 {-# INLINE thenTE #-}
1168 {-# INLINE returnTE #-}
1170 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1172 = case a u of { (u_1, result_of_a) ->
1175 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1176 mapTE f [] = returnTE []
1178 = f x `thenTE` \ r ->
1179 mapTE f xs `thenTE` \ rs ->
1182 returnTE :: a -> TeM a
1183 returnTE result env = (env, result)
1185 -- these next two check whether the thing is already
1186 -- recorded, and THEN THEY RECORD IT
1187 -- (subsequent calls will return False for the same uniq/label)
1189 tempSeenTE :: Unique -> TeM Bool
1190 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1191 = if (uniq `elementOfUniqueSet` seen_uniqs)
1193 else ((addToUniqueSet seen_uniqs uniq,
1197 labelSeenTE :: CLabel -> TeM Bool
1198 labelSeenTE label env@(seen_uniqs, seen_labels)
1199 = if (label `elementOfCLabelSet` seen_labels)
1202 addToCLabelSet seen_labels label),
1207 pprTempDecl :: Unique -> PrimRep -> Unpretty
1208 pprTempDecl uniq kind
1209 = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
1211 ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
1213 pprExternDecl :: CLabel -> PrimRep -> Unpretty
1215 pprExternDecl clabel kind
1216 = if not (needsCDecl clabel) then
1217 uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
1221 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1222 _ -> ppLocalnessMacro False{-data-} clabel
1223 ) _TO_ pp_macro_str ->
1225 uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ]
1230 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
1232 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1234 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1235 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1236 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1237 returnTE (maybe_uppAboves [p1, p2])
1239 ppr_decls_AbsC (CClosureUpdInfo info)
1240 = ppr_decls_AbsC info
1242 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1244 ppr_decls_AbsC (CAssign dest source)
1245 = ppr_decls_Amode dest `thenTE` \ p1 ->
1246 ppr_decls_Amode source `thenTE` \ p2 ->
1247 returnTE (maybe_uppAboves [p1, p2])
1249 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1251 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1253 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1255 ppr_decls_AbsC (CSwitch discrim alts deflt)
1256 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1257 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1258 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1259 returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
1261 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1263 ppr_decls_AbsC (CCodeBlock label absC)
1264 = ppr_decls_AbsC absC
1266 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1267 -- ToDo: strictly speaking, should chk "cost_centre" amode
1268 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1273 Just (pprExternDecl info_lbl PtrRep))
1275 info_lbl = infoTableLabelFromCI cl_info
1277 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1278 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1280 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1282 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1283 -- you get some nasty re-decls of stdio.h if you compile
1284 -- the prelude while looking inside those amodes;
1285 -- no real reason to, anyway.
1286 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1288 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1289 -- ToDo: strictly speaking, should chk "cost_centre" amode
1290 = ppr_decls_Amodes amodes
1292 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1293 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1294 ppr_decls_AbsC slow `thenTE` \ p2 ->
1296 Nothing -> returnTE (Nothing, Nothing)
1297 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1298 returnTE (maybe_uppAboves [p1, p2, p3])
1300 entry_lbl = CLbl slow_lbl CodePtrRep
1301 slow_lbl = case (nonemptyAbsC slow) of
1302 Nothing -> mkErrorStdEntryLabel
1303 Just _ -> entryLabelFromCI cl_info
1305 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1306 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1307 ppr_decls_AbsC absC `thenTE` \ p2 ->
1308 returnTE (maybe_uppAboves [p1, p2])
1310 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1311 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1315 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
1316 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1317 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1318 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1319 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1320 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1321 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1322 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1324 -- CIntLike must be a literal -- no decls
1325 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1327 -- CCharLike may have be arbitrary value -- may have decls
1328 ppr_decls_Amode (CCharLike char)
1329 = ppr_decls_Amode char
1331 -- now, the only place where we actually print temps/externs...
1332 ppr_decls_Amode (CTemp uniq kind)
1334 VoidRep -> returnTE (Nothing, Nothing)
1336 tempSeenTE uniq `thenTE` \ temp_seen ->
1338 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1340 ppr_decls_Amode (CLbl label VoidRep)
1341 = returnTE (Nothing, Nothing)
1343 ppr_decls_Amode (CLbl label kind)
1344 = labelSeenTE label `thenTE` \ label_seen ->
1346 if label_seen then Nothing else Just (pprExternDecl label kind))
1349 ppr_decls_Amode (CUnVecLbl direct vectored)
1350 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1351 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1353 ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
1354 vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
1357 if (dlbl_seen || not (needsCDecl direct)) &&
1358 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1359 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1362 ppr_decls_Amode (CUnVecLbl direct vectored)
1363 = -- We don't mark either label as "seen", because
1364 -- we don't know which one will be used and which one tossed
1365 -- by the C macro...
1366 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1367 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1369 ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
1370 vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
1373 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1374 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1375 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1377 ppr_decls_Amode (CTableEntry base index _)
1378 = ppr_decls_Amode base `thenTE` \ p1 ->
1379 ppr_decls_Amode index `thenTE` \ p2 ->
1380 returnTE (maybe_uppAboves [p1, p2])
1382 ppr_decls_Amode (CMacroExpr _ _ amodes)
1383 = ppr_decls_Amodes amodes
1385 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1388 maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
1390 = BIND (unzip ps) _TO_ (ts, es) ->
1391 BIND (catMaybes ts) _TO_ real_ts ->
1392 BIND (catMaybes es) _TO_ real_es ->
1393 (if (null real_ts) then Nothing else Just (uppAboves real_ts),
1394 if (null real_es) then Nothing else Just (uppAboves real_es))
1399 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
1400 ppr_decls_Amodes amodes
1401 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1402 returnTE ( maybe_uppAboves ps )