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
23 IMPORT_1_3(IO(Handle))
24 IMPORT_1_3(Char(isDigit,isPrint))
25 IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
29 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
30 mixedPtrLocn, mixedTypeLocn
32 import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
33 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
34 isReadOnly, needsCDecl, pprCLabel,
35 CLabel{-instance Ord-}
37 import CmdLineOpts ( opt_SccProfilingOn )
38 import CostCentre ( uppCostCentre, uppCostCentreDecl )
39 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
40 import CStrings ( stringToC )
41 import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
42 import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
43 import Literal ( showLiteral, Literal(..) )
44 import Maybes ( maybeToBool, catMaybes )
45 import PprStyle ( PprStyle(..) )
46 import Pretty ( prettyToUn )
47 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
48 import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
49 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
50 isConstantRep, isSpecRep, isPhantomRep
52 import Unique ( pprUnique, Unique{-instance NamedThing-} )
53 import UniqSet ( emptyUniqSet, elementOfUniqSet,
54 addOneToUniqSet, SYN_IE(UniqSet)
56 import Unpretty -- ********** NOTE **********
57 import Util ( nOfThem, panic, assertPanic )
62 For spitting out the costs of an abstract~C expression, @writeRealC@
63 now not only prints the C~code of the @absC@ arg but also adds a macro
64 call to a cost evaluation function @GRAN_EXEC@. For that,
65 @pprAbsC@ has a new ``costs'' argument. %% HWL
68 writeRealC :: Handle -> AbstractC -> IO ()
70 writeRealC handle absC
71 = uppPutStr handle 80 (
72 uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
75 dumpRealC :: AbstractC -> String
79 uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
83 This emits the macro, which is used in GrAnSim to compute the total costs
84 from a cost 5 tuple. %% HWL
87 emitMacro :: CostRes -> Unpretty
89 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
90 emitMacro (Cost (i,b,l,s,f))
91 = uppBesides [ uppPStr SLIT("GRAN_EXEC"), uppChar '(',
92 uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
93 uppInt s, uppComma, uppInt f, pp_paren_semi ]
97 pp_paren_semi = uppStr ");"
99 -- ---------------------------------------------------------------------------
100 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
101 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
102 -- which must be done before the return i.e. inside absC code) HWL
103 -- ---------------------------------------------------------------------------
105 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
107 pprAbsC sty AbsCNop _ = uppNil
108 pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
110 pprAbsC sty (CClosureUpdInfo info) c
113 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
115 pprAbsC sty (CJump target) c
116 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
117 (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ])
119 pprAbsC sty (CFallThrough target) c
120 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
121 (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ])
123 -- --------------------------------------------------------------------------
124 -- Spit out GRAN_EXEC macro immediately before the return HWL
126 pprAbsC sty (CReturn am return_info) c
127 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
128 (uppBesides [uppStr jmp_lit, target, pp_paren_semi ])
130 target = case return_info of
131 DirectReturn -> uppBesides [uppPStr SLIT("DIRECT"),uppChar '(', pprAmode sty am, uppRparen]
132 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
133 StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
134 mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
136 pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
138 -- we optimise various degenerate cases of CSwitches.
140 -- --------------------------------------------------------------------------
141 -- Assume: CSwitch is also end of basic block
142 -- costs function yields nullCosts for whole switch
143 -- ==> inherited costs c are those of basic block up to switch
144 -- ==> inherit c + costs for the corresponding branch
146 -- --------------------------------------------------------------------------
148 pprAbsC sty (CSwitch discrim [] deflt) c
149 = pprAbsC sty deflt (c + costs deflt)
150 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
152 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
153 = case (nonemptyAbsC deflt) of
154 Nothing -> -- one alt and no default
155 pprAbsC sty alt_code (c + costs alt_code)
156 -- Nothing conditional in here either HWL
158 Just dc -> -- make it an "if"
159 do_if_stmt sty discrim tag alt_code dc c
161 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
162 (tag2@(MachInt i2 _), alt_code2)] deflt) c
163 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
165 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
167 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
169 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
171 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
172 | isFloatingRep (getAmodeRep discrim)
173 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
176 uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
177 uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
178 (case (nonemptyAbsC deflt) of
181 uppNest 2 (uppAboves [uppPStr SLIT("default:"),
182 pprAbsC sty dc (c + switch_head_cost
184 uppPStr SLIT("break;")])),
188 = pprAmode sty discrim
190 ppr_alt sty (lit, absC)
191 = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
192 uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
193 (uppPStr SLIT("break;"))) ]
195 -- Costs for addressing header of switch and cond. branching -- HWL
196 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
198 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
199 = pprCCall sty op args results liveness_mask vol_regs
201 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
203 non_void_args = grab_non_void_amodes args
204 non_void_results = grab_non_void_amodes results
205 -- if just one result, we print in the obvious "assignment" style;
206 -- if 0 or many results, we emit a macro call, w/ the results
207 -- followed by the arguments. The macro presumably knows which
210 the_op = ppr_op_call non_void_results non_void_args
211 -- liveness mask is *in* the non_void_args
213 case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
214 if primOpNeedsWrapper op then
215 uppAboves [ pp_saves,
223 ppr_op_call results args
224 = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
225 uppIntersperse uppComma (map ppr_op_result results),
226 if null results || null args then uppNil else uppComma,
227 uppIntersperse uppComma (map (pprAmode sty) args),
230 ppr_op_result r = ppr_amode sty r
231 -- primop macros do their own casting of result;
232 -- hence we can toss the provided cast...
234 pprAbsC sty (CSimultaneous abs_c) c
235 = uppBesides [uppPStr SLIT("{{"), pprAbsC sty abs_c c, uppPStr SLIT("}}")]
237 pprAbsC sty stmt@(CMacroStmt macro as) _
238 = uppBesides [uppStr (show macro), uppLparen,
239 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
240 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
241 = uppBesides [uppPStr op, uppLparen,
242 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
243 pprAbsC sty stmt@(CCallProfCCMacro op as) _
244 = uppBesides [uppPStr op, uppLparen,
245 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
247 pprAbsC sty (CCodeBlock label abs_C) _
248 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
249 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
251 uppBesides [uppStr (if (externallyVisibleCLabel label)
252 then "FN_(" -- abbreviations to save on output
254 pprCLabel sty label, uppStr ") {"],
256 PprForC -> uppAbove pp_exts pp_temps
258 uppNest 8 (uppPStr SLIT("FB_")),
259 uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
260 uppNest 8 (uppPStr SLIT("FE_")),
264 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
265 = uppBesides [ pp_init_hdr, uppStr "_HDR(",
266 ppr_amode sty (CAddr reg_rel), uppComma,
267 pprCLabel sty info_lbl, uppComma,
268 if_profiling sty (pprAmode sty cost_centre), uppComma,
269 pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
271 info_lbl = infoTableLabelFromCI cl_info
272 sm_rep = closureSMRep cl_info
273 size = closureSizeWithoutFixedHdr cl_info
274 ptr_wds = closurePtrsSize cl_info
276 pp_init_hdr = uppStr (if inplace_upd then
277 getSMUpdInplaceHdrStr sm_rep
279 getSMInitHdrStr sm_rep)
281 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
282 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
288 uppPStr SLIT("SET_STATIC_HDR"),uppChar '(',
289 pprCLabel sty closure_lbl, uppComma,
290 pprCLabel sty info_lbl, uppComma,
291 if_profiling sty (pprAmode sty cost_centre), uppComma,
292 ppLocalness closure_lbl, uppComma,
293 ppLocalnessMacro False{-for data-} info_lbl,
296 uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
297 uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
301 info_lbl = infoTableLabelFromCI cl_info
304 = if getAmodeRep item == VoidRep
305 then uppStr ", (W_) 0" -- might not even need this...
306 else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
309 if not (closureUpdReqd cl_info) then
312 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
313 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
316 STATIC_INIT_HDR(c,i,localness) blows into:
317 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
319 then *NO VarHdr STUFF FOR STATIC*...
321 then the amodes are dropped in...
327 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
331 uppPStr SLIT("_ITBL"),uppChar '(',
332 pprCLabel sty info_lbl, uppComma,
334 -- CONST_ITBL needs an extra label for
335 -- the static version of the object.
336 if isConstantRep sm_rep
337 then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
340 pprCLabel sty slow_lbl, uppComma,
341 pprAmode sty upd, uppComma,
342 uppInt liveness, uppComma,
346 pp_ptr_wds, uppComma,
348 ppLocalness info_lbl, uppComma,
349 ppLocalnessMacro True{-function-} slow_lbl, uppComma,
352 then uppBeside (uppInt select_word_i) uppComma
355 if_profiling sty pp_kind, uppComma,
356 if_profiling sty pp_descr, uppComma,
357 if_profiling sty pp_type,
363 Just fast -> let stuff = CCodeBlock fast_lbl fast in
364 pprAbsC sty stuff (costs stuff)
367 info_lbl = infoTableLabelFromCI cl_info
368 fast_lbl = fastLabelFromCI cl_info
369 sm_rep = closureSMRep cl_info
372 = case (nonemptyAbsC slow) of
373 Nothing -> (mkErrorStdEntryLabel, uppNil)
374 Just xx -> (entryLabelFromCI cl_info,
375 let stuff = CCodeBlock slow_lbl xx in
376 pprAbsC sty stuff (costs stuff))
378 maybe_selector = maybeSelectorInfo cl_info
379 is_selector = maybeToBool maybe_selector
380 (Just (_, select_word_i)) = maybe_selector
382 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
383 = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
385 pp_tag = uppInt (closureSemiTag cl_info)
387 is_phantom = isPhantomRep sm_rep
389 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
390 uppInt (closureNonHdrSize cl_info)
392 else if is_phantom then -- do not have sizes for these
395 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
397 pp_ptr_wds = if is_phantom then
400 uppInt (closurePtrsSize cl_info)
402 pp_kind = uppStr (closureKind cl_info)
403 pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
404 pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
406 pprAbsC sty (CRetVector lbl maybes deflt) c
407 = uppAboves [ uppPStr SLIT("{ // CRetVector (lbl????)"),
408 uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
409 uppStr "} /*default=*/ {", pprAbsC sty deflt c,
412 ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
413 ppr_maybe_amode sty (Just a) = pprAmode sty a
415 pprAbsC sty stmt@(CRetUnVector label amode) _
416 = uppBesides [uppPStr SLIT("UNVECTBL"),uppChar '(', pp_static, uppComma, pprCLabel sty label, uppComma,
417 pprAmode sty amode, uppRparen]
419 pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
421 pprAbsC sty stmt@(CFlatRetVector label amodes) _
422 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
427 uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
428 pprCLabel sty label, uppStr "[] = {"],
429 uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
432 ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
434 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
439 = uppBeside static const
441 static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
442 const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
444 ppLocalnessMacro for_fun{-vs data-} clabel
445 = uppBesides [ uppChar (if externallyVisibleCLabel clabel then 'E' else 'I'),
449 uppBeside (uppPStr SLIT("D_"))
450 (if isReadOnly clabel then
459 grab_non_void_amodes amodes
460 = filter non_void amodes
463 = case (getAmodeRep amode) of
469 ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
471 ppr_vol_regs sty [] = (uppNil, uppNil)
472 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
473 ppr_vol_regs sty (r:rs)
474 = let pp_reg = case r of
475 VanillaReg pk n -> pprVanillaReg n
476 _ -> pprMagicId sty r
477 (more_saves, more_restores) = ppr_vol_regs sty rs
479 (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
480 uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
482 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
483 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
484 -- depending on the platform. (The "volatile regs" stuff handles all
485 -- other registers.) Just be *sure* BaseReg is OK before trying to do
489 uppPStr SLIT("CALLER_SAVE_Base"),
490 uppPStr SLIT("CALLER_SAVE_SpA"),
491 uppPStr SLIT("CALLER_SAVE_SuA"),
492 uppPStr SLIT("CALLER_SAVE_SpB"),
493 uppPStr SLIT("CALLER_SAVE_SuB"),
494 uppPStr SLIT("CALLER_SAVE_Ret"),
495 -- uppPStr SLIT("CALLER_SAVE_Activity"),
496 uppPStr SLIT("CALLER_SAVE_Hp"),
497 uppPStr SLIT("CALLER_SAVE_HpLim") ]
501 uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
502 uppPStr SLIT("CALLER_RESTORE_SpA"),
503 uppPStr SLIT("CALLER_RESTORE_SuA"),
504 uppPStr SLIT("CALLER_RESTORE_SpB"),
505 uppPStr SLIT("CALLER_RESTORE_SuB"),
506 uppPStr SLIT("CALLER_RESTORE_Ret"),
507 -- uppPStr SLIT("CALLER_RESTORE_Activity"),
508 uppPStr SLIT("CALLER_RESTORE_Hp"),
509 uppPStr SLIT("CALLER_RESTORE_HpLim"),
510 uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
511 uppPStr SLIT("CALLER_RESTORE_StkStub") ]
515 if_profiling sty pretty
517 PprForC -> if opt_SccProfilingOn
519 else uppChar '0' -- leave it out!
521 _ -> {-print it anyway-} pretty
523 -- ---------------------------------------------------------------------------
524 -- Changes for GrAnSim:
525 -- draw costs for computation in head of if into both branches;
526 -- as no abstractC data structure is given for the head, one is constructed
527 -- guessing unknown values and fed into the costs function
528 -- ---------------------------------------------------------------------------
530 do_if_stmt sty discrim tag alt_code deflt c
532 -- This special case happens when testing the result of a comparison.
533 -- We can just avoid some redundant clutter in the output.
534 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
536 (addrModeCosts discrim Rhs) c
538 cond = uppBesides [ pprAmode sty discrim,
539 uppPStr SLIT(" == "),
540 pprAmode sty (CLit tag) ]
544 (addrModeCosts discrim Rhs) c
546 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
548 uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
549 uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
550 (Cost (0, 2, 0, 0, 0)) +
552 (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
553 uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
554 (Cost (0, 1, 0, 0, 0)) +
557 {- Total costs = inherited costs (before if) + costs for accessing discrim
558 + costs for cond branch ( = (0, 1, 0, 0, 0) )
559 + costs for that alternative
563 Historical note: this used to be two separate cases -- one for `ccall'
564 and one for `casm'. To get round a potential limitation to only 10
565 arguments, the numbering of arguments in @process_casm@ was beefed up a
568 Some rough notes on generating code for @CCallOp@:
570 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
571 2) Save any essential registers (heap, stack, etc).
573 ToDo: If stable pointers are in use, these must be saved in a place
574 where the runtime system can get at them so that the Stg world can
575 be restarted during the call.
577 3) Save any temporary registers that are currently in use.
578 4) Do the call putting result into a local variable
579 5) Restore essential registers
580 6) Restore temporaries
582 (This happens after restoration of essential registers because we
583 might need the @Base@ register to access all the others correctly.)
585 {- Doesn't apply anymore with ForeignObj, structure create via primop.
586 makeForeignObj (ForeignObj is not CReturnable)
587 7) If returning Malloc Pointer, build a closure containing the
590 Otherwise, copy local variable into result register.
592 8) If ccall (not casm), declare the function being called as extern so
593 that C knows if it returns anything other than an int.
596 { ResultType _ccall_result;
599 _ccall_result = f( args );
603 return_reg = _ccall_result;
607 Amendment to the above: if we can GC, we have to:
609 * make sure we save all our registers away where the garbage collector
611 * be sure that there are no live registers or we're in trouble.
612 (This can cause problems if you try something foolish like passing
613 an array or foreign obj to a _ccall_GC_ thing.)
614 * increment/decrement the @inCCallGC@ counter before/after the call so
615 that the runtime check that PerformGC is being used sensibly will work.
618 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
619 = if (may_gc && liveness_mask /= noLiveRegsMask)
620 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
624 declare_local_vars, -- local var for *result*
625 uppAboves local_arg_decls,
626 -- if is_asm then uppNil else declareExtern,
628 process_casm local_vars pp_non_void_args casm_str,
634 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
635 (pp_save_context, pp_restore_context) =
637 then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
638 uppStr "inCCallGC--; RestoreAllStgRegs();")
639 else ( pp_basic_saves `uppAbove` pp_saves,
640 pp_basic_restores `uppAbove` pp_restores)
644 in ASSERT (all non_void nvas) nvas
645 -- the first argument will be the "I/O world" token (a VoidRep)
646 -- all others should be non-void
649 let nvrs = grab_non_void_amodes results
650 in ASSERT (length nvrs <= 1) nvrs
651 -- there will usually be two results: a (void) state which we
652 -- should ignore and a (possibly void) result.
654 (local_arg_decls, pp_non_void_args)
655 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
657 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
659 (declare_local_vars, local_vars, assign_results)
660 = ppr_casm_results sty non_void_results pp_liveness
662 casm_str = if is_asm then _UNPK_ op_str else ccall_str
664 -- Remainder only used for ccall
666 ccall_str = uppShow 80
668 if null non_void_results
671 uppLparen, uppPStr op_str, uppLparen,
672 uppIntersperse uppComma ccall_args,
675 num_args = length non_void_args
676 ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
679 If the argument is a heap object, we need to reach inside and pull out
680 the bit the C world wants to see. The only heap objects which can be
681 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
684 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
685 -- (a) decl and assignment, (b) local var to be used later
687 ppr_casm_arg sty amode a_num
689 a_kind = getAmodeRep amode
690 pp_amode = pprAmode sty amode
691 pp_kind = pprPrimKind sty a_kind
693 local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
695 (arg_type, pp_amode2)
698 -- for array arguments, pass a pointer to the body of the array
699 -- (PTRS_ARR_CTS skips over all the header nonsense)
700 ArrayRep -> (pp_kind,
701 uppBesides [uppPStr SLIT("PTRS_ARR_CTS"),uppChar '(', pp_amode, uppRparen])
702 ByteArrayRep -> (pp_kind,
703 uppBesides [uppPStr SLIT("BYTE_ARR_CTS"),uppChar '(', pp_amode, uppRparen])
705 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
706 ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
707 uppBesides [uppPStr SLIT("ForeignObj_CLOSURE_DATA"),uppChar '(',
708 pp_amode, uppChar ')'])
709 other -> (pp_kind, pp_amode)
712 = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
714 (declare_local_var, local_var)
717 For l-values, the critical questions are:
719 1) Are there any results at all?
721 We only allow zero or one results.
723 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
724 2) Is the result is a foreign obj?
726 The mallocptr must be encapsulated immediately in a heap object.
731 -> [CAddrMode] -- list of results (length <= 1)
732 -> Unpretty -- liveness mask
734 ( Unpretty, -- declaration of any local vars
735 [Unpretty], -- list of result vars (same length as results)
736 Unpretty ) -- assignment (if any) of results in local var to registers
738 ppr_casm_results sty [] liveness
739 = (uppNil, [], uppNil) -- no results
741 ppr_casm_results sty [r] liveness
743 result_reg = ppr_amode sty r
744 r_kind = getAmodeRep r
746 local_var = uppPStr SLIT("_ccall_result")
748 (result_type, assign_result)
750 {- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
751 Instead, external references have to be turned into ForeignObjs
752 using the primop makeForeignObj#. Benefit: Multiple finalisation
753 routines can be accommodated and the below special case is not needed.
754 Price is, of course, that you have to explicitly wrap `foreign objects'
755 with makeForeignObj#.
758 (uppPStr SLIT("StgForeignObj"),
759 uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(',
761 result_reg, uppComma,
765 (pprPrimKind sty r_kind,
766 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
768 declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
770 (declare_local_var, [local_var], assign_result)
772 ppr_casm_results sty rs liveness
773 = panic "ppr_casm_results: ccall/casm with many results"
777 Note the sneaky way _the_ result is represented by a list so that we
778 can complain if it's used twice.
780 ToDo: Any chance of giving line numbers when process-casm fails?
781 Or maybe we should do a check _much earlier_ in compiler. ADR
785 [Unpretty] -- results (length <= 1)
786 -> [Unpretty] -- arguments
787 -> String -- format string (with embedded %'s)
789 Unpretty -- code being generated
791 process_casm results args string = process results args string
793 process [] _ "" = uppNil
794 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
796 process ress args ('%':cs)
799 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
802 uppBeside (uppChar '%') (process ress args css)
806 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
807 [r] -> uppBeside r (process [] args css)
808 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
812 read_int :: ReadS Int
815 case (read_int other) of
817 if 0 <= num && num < length args
818 then uppBeside (uppParens (args !! num))
819 (process ress args css)
820 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
821 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
823 process ress args (other_c:cs)
824 = uppBeside (uppChar other_c) (process ress args cs)
827 %************************************************************************
829 \subsection[a2r-assignments]{Assignments}
831 %************************************************************************
833 Printing assignments is a little tricky because of type coercion.
835 First of all, the kind of the thing being assigned can be gotten from
836 the destination addressing mode. (It should be the same as the kind
837 of the source addressing mode.) If the kind of the assignment is of
838 @VoidRep@, then don't generate any code at all.
841 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
843 pprAssign sty VoidRep dest src = uppNil
846 Special treatment for floats and doubles, to avoid unwanted conversions.
849 pprAssign sty FloatRep dest@(CVal reg_rel _) src
850 = uppBesides [ uppPStr SLIT("ASSIGN_FLT"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
852 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
853 = uppBesides [ uppPStr SLIT("ASSIGN_DBL"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
856 Lastly, the question is: will the C compiler think the types of the
857 two sides of the assignment match?
859 We assume that the types will match
860 if neither side is a @CVal@ addressing mode for any register
861 which can point into the heap or B stack.
863 Why? Because the heap and B stack are used to store miscellaneous things,
864 whereas the A stack, temporaries, registers, etc., are only used for things
868 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
869 = uppBesides [ pprVanillaReg dest, uppEquals,
870 pprVanillaReg src, uppSemi ]
872 pprAssign sty kind dest src
874 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
875 = uppBesides [ ppr_amode sty dest, uppEquals,
876 uppStr "(W_)(", -- Here is the cast
877 ppr_amode sty src, pp_paren_semi ]
879 pprAssign sty kind dest src
880 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
881 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
882 = uppBesides [ ppr_amode sty dest, uppEquals,
883 uppStr "(P_)(", -- Here is the cast
884 ppr_amode sty src, pp_paren_semi ]
886 pprAssign sty ByteArrayRep dest src
888 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
889 = uppBesides [ ppr_amode sty dest, uppEquals,
890 uppStr "(B_)(", -- Here is the cast
891 ppr_amode sty src, pp_paren_semi ]
893 pprAssign sty kind other_dest src
894 = uppBesides [ ppr_amode sty other_dest, uppEquals,
895 pprAmode sty src, uppSemi ]
899 %************************************************************************
901 \subsection[a2r-CAddrModes]{Addressing modes}
903 %************************************************************************
905 @pprAmode@ is used to print r-values (which may need casts), whereas
906 @ppr_amode@ is used for l-values {\em and} as a help function for
910 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
913 For reasons discussed above under assignments, @CVal@ modes need
914 to be treated carefully. First come special cases for floats and doubles,
915 similar to those in @pprAssign@:
917 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
921 pprAmode sty (CVal reg_rel FloatRep)
922 = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
923 pprAmode sty (CVal reg_rel DoubleRep)
924 = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
927 Next comes the case where there is some other cast need, and the
932 | mixedTypeLocn amode
933 = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppPStr SLIT(")("),
934 ppr_amode sty amode ])
935 | otherwise -- No cast needed
936 = ppr_amode sty amode
939 Now the rest of the cases for ``workhorse'' @ppr_amode@:
942 ppr_amode sty (CVal reg_rel _)
943 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
944 (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
945 (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
947 ppr_amode sty (CAddr reg_rel)
948 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
949 (pp_reg, Nothing) -> pp_reg
950 (pp_reg, Just offset) -> uppBeside pp_reg offset
952 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
954 ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
956 ppr_amode sty (CLbl label kind) = pprCLabel sty label
958 ppr_amode sty (CUnVecLbl direct vectored)
959 = uppBesides [uppChar '(',uppPStr SLIT("StgRetAddr"),uppChar ')', uppPStr SLIT("UNVEC"),uppChar '(', pprCLabel sty direct, uppComma,
960 pprCLabel sty vectored, uppRparen]
962 ppr_amode sty (CCharLike char)
963 = uppBesides [uppPStr SLIT("CHARLIKE_CLOSURE"),uppChar '(', pprAmode sty char, uppRparen ]
964 ppr_amode sty (CIntLike int)
965 = uppBesides [uppPStr SLIT("INTLIKE_CLOSURE"),uppChar '(', pprAmode sty int, uppRparen ]
967 ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
968 -- ToDo: are these *used* for anything?
970 ppr_amode sty (CLit lit) = pprBasicLit sty lit
972 ppr_amode sty (CLitLit str _) = uppPStr str
974 ppr_amode sty (COffset off) = pprHeapOffset sty off
976 ppr_amode sty (CCode abs_C)
977 = uppAboves [ uppPStr SLIT("{ -- CCode"), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
979 ppr_amode sty (CLabelledCode label abs_C)
980 = uppAboves [ uppBesides [pprCLabel sty label, uppPStr SLIT(" = { -- CLabelledCode")],
981 uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
983 ppr_amode sty (CJoinPoint _ _)
984 = panic "ppr_amode: CJoinPoint"
986 ppr_amode sty (CTableEntry base index kind)
987 = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
988 ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
991 ppr_amode sty (CMacroExpr pk macro as)
992 = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
993 uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
995 ppr_amode sty (CCostCentre cc print_as_string)
996 = uppCostCentre sty print_as_string cc
999 %************************************************************************
1001 \subsection[a2r-MagicIds]{Magic ids}
1003 %************************************************************************
1005 @pprRegRelative@ returns a pair of the @Unpretty@ for the register
1006 (some casting may be required), and a @Maybe Unpretty@ for the offset
1007 (zero offset gives a @Nothing@).
1010 addPlusSign :: Bool -> Unpretty -> Unpretty
1011 addPlusSign False p = p
1012 addPlusSign True p = uppBeside (uppChar '+') p
1014 pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
1015 pprSignedInt sign_wanted n
1016 = if n == 0 then Nothing else
1017 if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
1018 else Just (uppInt n)
1020 pprRegRelative :: PprStyle
1021 -> Bool -- True <=> Print leading plus sign (if +ve)
1023 -> (Unpretty, Maybe Unpretty)
1025 pprRegRelative sty sign_wanted (SpARel spA off)
1026 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1028 pprRegRelative sty sign_wanted (SpBRel spB off)
1029 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1031 pprRegRelative sty sign_wanted r@(HpRel hp off)
1032 = let to_print = hp `subOff` off
1033 pp_Hp = pprMagicId sty Hp
1035 if isZeroOff to_print then
1038 (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print)))
1039 -- No parens needed because pprHeapOffset
1040 -- does them when necessary
1042 pprRegRelative sty sign_wanted (NodeRel off)
1043 = let pp_Node = pprMagicId sty node
1045 if isZeroOff off then
1048 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1052 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1053 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1054 to select the union tag.
1057 pprMagicId :: PprStyle -> MagicId -> Unpretty
1059 pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
1060 pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
1061 pprMagicId sty (VanillaReg pk n)
1062 = uppBesides [ pprVanillaReg n, uppChar '.',
1064 pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
1065 pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
1066 pprMagicId sty TagReg = uppPStr SLIT("TagReg")
1067 pprMagicId sty RetReg = uppPStr SLIT("RetReg")
1068 pprMagicId sty SpA = uppPStr SLIT("SpA")
1069 pprMagicId sty SuA = uppPStr SLIT("SuA")
1070 pprMagicId sty SpB = uppPStr SLIT("SpB")
1071 pprMagicId sty SuB = uppPStr SLIT("SuB")
1072 pprMagicId sty Hp = uppPStr SLIT("Hp")
1073 pprMagicId sty HpLim = uppPStr SLIT("HpLim")
1074 pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
1075 pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
1076 pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
1077 pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
1078 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1080 pprVanillaReg :: FAST_INT -> Unpretty
1082 pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
1084 pprUnionTag :: PrimRep -> Unpretty
1086 pprUnionTag PtrRep = uppChar 'p'
1087 pprUnionTag CodePtrRep = uppPStr SLIT("fp")
1088 pprUnionTag DataPtrRep = uppChar 'd'
1089 pprUnionTag RetRep = uppChar 'r'
1090 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1092 pprUnionTag CharRep = uppChar 'c'
1093 pprUnionTag IntRep = uppChar 'i'
1094 pprUnionTag WordRep = uppChar 'w'
1095 pprUnionTag AddrRep = uppChar 'v'
1096 pprUnionTag FloatRep = uppChar 'f'
1097 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1099 pprUnionTag StablePtrRep = uppChar 'i'
1100 pprUnionTag ForeignObjRep = uppChar 'p'
1102 pprUnionTag ArrayRep = uppChar 'p'
1103 pprUnionTag ByteArrayRep = uppChar 'b'
1105 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1109 Find and print local and external declarations for a list of
1110 Abstract~C statements.
1112 pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-})
1113 pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
1115 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1116 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1117 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1118 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1119 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1120 returnTE (uppAboves real_temps, uppAboves real_exts) }}
1123 pprTempAndExternDecls other_stmt
1124 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1135 pprBasicLit :: PprStyle -> Literal -> Unpretty
1136 pprPrimKind :: PprStyle -> PrimRep -> Unpretty
1138 pprBasicLit sty lit = uppStr (showLiteral sty lit)
1139 pprPrimKind sty k = uppStr (showPrimRep k)
1143 %************************************************************************
1145 \subsection[a2r-monad]{Monadery}
1147 %************************************************************************
1149 We need some monadery to keep track of temps and externs we have already
1150 printed. This info must be threaded right through the Abstract~C, so
1151 it's most convenient to hide it in this monad.
1153 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1154 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1157 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1158 emptyCLabelSet = emptyFM
1159 x `elementOfCLabelSet` labs
1160 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1161 addToCLabelSet set x = addToFM set x ()
1163 type TEenv = (UniqSet Unique, CLabelSet)
1165 type TeM result = TEenv -> (TEenv, result)
1167 initTE :: TeM a -> a
1169 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1172 {-# INLINE thenTE #-}
1173 {-# INLINE returnTE #-}
1175 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1177 = case a u of { (u_1, result_of_a) ->
1180 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1181 mapTE f [] = returnTE []
1183 = f x `thenTE` \ r ->
1184 mapTE f xs `thenTE` \ rs ->
1187 returnTE :: a -> TeM a
1188 returnTE result env = (env, result)
1190 -- these next two check whether the thing is already
1191 -- recorded, and THEN THEY RECORD IT
1192 -- (subsequent calls will return False for the same uniq/label)
1194 tempSeenTE :: Unique -> TeM Bool
1195 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1196 = if (uniq `elementOfUniqSet` seen_uniqs)
1198 else ((addOneToUniqSet seen_uniqs uniq,
1202 labelSeenTE :: CLabel -> TeM Bool
1203 labelSeenTE label env@(seen_uniqs, seen_labels)
1204 = if (label `elementOfCLabelSet` seen_labels)
1207 addToCLabelSet seen_labels label),
1212 pprTempDecl :: Unique -> PrimRep -> Unpretty
1213 pprTempDecl uniq kind
1214 = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
1216 pprExternDecl :: CLabel -> PrimRep -> Unpretty
1218 pprExternDecl clabel kind
1219 = if not (needsCDecl clabel) then
1220 uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
1224 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1225 _ -> ppLocalnessMacro False{-data-} clabel
1226 ) of { pp_macro_str ->
1228 uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
1233 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
1235 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1237 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1238 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1239 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1240 returnTE (maybe_uppAboves [p1, p2])
1242 ppr_decls_AbsC (CClosureUpdInfo info)
1243 = ppr_decls_AbsC info
1245 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1247 ppr_decls_AbsC (CAssign dest source)
1248 = ppr_decls_Amode dest `thenTE` \ p1 ->
1249 ppr_decls_Amode source `thenTE` \ p2 ->
1250 returnTE (maybe_uppAboves [p1, p2])
1252 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1254 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1256 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1258 ppr_decls_AbsC (CSwitch discrim alts deflt)
1259 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1260 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1261 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1262 returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
1264 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1266 ppr_decls_AbsC (CCodeBlock label absC)
1267 = ppr_decls_AbsC absC
1269 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1270 -- ToDo: strictly speaking, should chk "cost_centre" amode
1271 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1276 Just (pprExternDecl info_lbl PtrRep))
1278 info_lbl = infoTableLabelFromCI cl_info
1280 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1281 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1283 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1285 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1286 -- you get some nasty re-decls of stdio.h if you compile
1287 -- the prelude while looking inside those amodes;
1288 -- no real reason to, anyway.
1289 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1291 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1292 -- ToDo: strictly speaking, should chk "cost_centre" amode
1293 = ppr_decls_Amodes amodes
1295 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1296 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1297 ppr_decls_AbsC slow `thenTE` \ p2 ->
1299 Nothing -> returnTE (Nothing, Nothing)
1300 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1301 returnTE (maybe_uppAboves [p1, p2, p3])
1303 entry_lbl = CLbl slow_lbl CodePtrRep
1304 slow_lbl = case (nonemptyAbsC slow) of
1305 Nothing -> mkErrorStdEntryLabel
1306 Just _ -> entryLabelFromCI cl_info
1308 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1309 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1310 ppr_decls_AbsC absC `thenTE` \ p2 ->
1311 returnTE (maybe_uppAboves [p1, p2])
1313 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1314 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1318 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
1319 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1320 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1321 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1322 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1323 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1324 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1325 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1327 -- CIntLike must be a literal -- no decls
1328 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1330 -- CCharLike may have be arbitrary value -- may have decls
1331 ppr_decls_Amode (CCharLike char)
1332 = ppr_decls_Amode char
1334 -- now, the only place where we actually print temps/externs...
1335 ppr_decls_Amode (CTemp uniq kind)
1337 VoidRep -> returnTE (Nothing, Nothing)
1339 tempSeenTE uniq `thenTE` \ temp_seen ->
1341 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1343 ppr_decls_Amode (CLbl label VoidRep)
1344 = returnTE (Nothing, Nothing)
1346 ppr_decls_Amode (CLbl label kind)
1347 = labelSeenTE label `thenTE` \ label_seen ->
1349 if label_seen then Nothing else Just (pprExternDecl label kind))
1352 ppr_decls_Amode (CUnVecLbl direct vectored)
1353 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1354 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1356 ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
1357 vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
1360 if (dlbl_seen || not (needsCDecl direct)) &&
1361 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1362 else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen]))
1365 ppr_decls_Amode (CUnVecLbl direct vectored)
1366 = -- We don't mark either label as "seen", because
1367 -- we don't know which one will be used and which one tossed
1368 -- by the C macro...
1369 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1370 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1372 ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
1373 vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
1376 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1377 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1378 else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen]))
1380 ppr_decls_Amode (CTableEntry base index _)
1381 = ppr_decls_Amode base `thenTE` \ p1 ->
1382 ppr_decls_Amode index `thenTE` \ p2 ->
1383 returnTE (maybe_uppAboves [p1, p2])
1385 ppr_decls_Amode (CMacroExpr _ _ amodes)
1386 = ppr_decls_Amodes amodes
1388 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1391 maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
1393 = case (unzip ps) of { (ts, es) ->
1394 case (catMaybes ts) of { real_ts ->
1395 case (catMaybes es) of { real_es ->
1396 (if (null real_ts) then Nothing else Just (uppAboves real_ts),
1397 if (null real_es) then Nothing else Just (uppAboves real_es))
1402 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
1403 ppr_decls_Amodes amodes
1404 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1405 returnTE ( maybe_uppAboves ps )