2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[PprAbsC]{Pretty-printing Abstract~C}
8 %************************************************************************
11 #include "HsVersions.h"
14 #ifdef __GLASGOW_HASKELL__
18 #if defined(DEBUG) || defined(DPH)
19 pprAmode, -- otherwise, not exported
26 -- and for interface self-sufficiency...
27 AbstractC, CAddrMode, MagicId,
31 IMPORT_Trace -- ToDo: rm (debugging only)
35 import AbsPrel ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
36 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
38 import BasicLit ( kindOfBasicLit, showBasicLit )
39 import CLabelInfo -- lots of things
40 import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
41 import CgRetConv ( noLiveRegsMask )
42 import ClosureInfo -- quite a few things
43 import CmdLineOpts ( GlobalSwitch(..) )
44 import Costs -- for GrAnSim; cost counting function -- HWL
47 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
49 import Pretty ( codeStyle, prettyToUn )
50 import PrimKind ( showPrimKind, isFloatingKind, PrimKind(..) )
54 import Unique -- UniqueSupply monadery used in flattening
55 import Unpretty -- ********** NOTE **********
61 For spitting out the costs of an abstract~C expression, @writeRealC@
62 now not only prints the C~code of the @absC@ arg but also adds a macro
63 call to a cost evaluation function @GRAN_EXEC@. For that,
64 @pprAbsC@ has a new ``costs'' argument. %% HWL
67 #ifdef __GLASGOW_HASKELL__
68 # if __GLASGOW_HASKELL__ < 23
71 writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> PrimIO ()
73 writeRealC sw_chker file absC
74 = uppAppendFile file 80 (
75 uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
79 dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> String
81 dumpRealC sw_chker absC
83 uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
87 This emits the macro, which is used in GrAnSim to compute the total costs
88 from a cost 5 tuple. %% HWL
91 emitMacro :: CostRes -> Unpretty
96 emitMacro (Cost (i,b,l,s,f))
97 = uppBesides [ uppStr "GRAN_EXEC(",
98 uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
99 uppInt s, uppComma, uppInt f, pp_paren_semi ]
104 pp_paren_semi = uppStr ");"
106 -- ---------------------------------------------------------------------------
107 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
108 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
109 -- which must be done before the return i.e. inside absC code) HWL
110 -- ---------------------------------------------------------------------------
112 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
114 pprAbsC sty AbsCNop _ = uppNil
115 pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
117 pprAbsC sty (CClosureUpdInfo info) c
120 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeKind dest) dest src
122 pprAbsC sty (CJump target) c
123 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
124 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
126 pprAbsC sty (CFallThrough target) c
127 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
128 (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
130 -- --------------------------------------------------------------------------
131 -- Spit out GRAN_EXEC macro immediately before the return HWL
133 pprAbsC sty (CReturn am return_info) c
134 = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
135 (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
137 target = case return_info of
138 DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
139 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
140 StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
141 mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
144 pprAbsC sty (CComment s) _
145 = uppNil -- ifPprShowAll sty (uppCat [uppStr "/*", uppStr s, uppStr "*/"])
148 pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
150 -- we optimise various degenerate cases of CSwitches.
152 -- --------------------------------------------------------------------------
153 -- Assume: CSwitch is also end of basic block
154 -- costs function yields nullCosts for whole switch
155 -- ==> inherited costs c are those of basic block up to switch
156 -- ==> inherit c + costs for the corresponding branch
158 -- --------------------------------------------------------------------------
160 pprAbsC sty (CSwitch discrim [] deflt) c
161 = pprAbsC sty deflt (c + costs deflt)
162 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
164 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
165 = case (nonemptyAbsC deflt) of
166 Nothing -> -- one alt and no default
167 pprAbsC sty alt_code (c + costs alt_code)
168 -- Nothing conditional in here either HWL
170 Just dc -> -- make it an "if"
171 do_if_stmt sty discrim tag alt_code dc c
173 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
174 (tag2@(MachInt i2 _), alt_code2)] deflt) c
175 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
177 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
179 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
181 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
183 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
184 | isFloatingKind (getAmodeKind discrim)
185 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
188 uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
189 uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
190 (case (nonemptyAbsC deflt) of
193 uppNest 2 (uppAboves [uppPStr SLIT("default:"),
194 pprAbsC sty dc (c + switch_head_cost
196 uppPStr SLIT("break;")])),
200 = pprAmode sty discrim
202 ppr_alt sty (lit, absC)
203 = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
204 uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
205 (uppPStr SLIT("break;"))) ]
207 -- Costs for addressing header of switch and cond. branching -- HWL
208 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
210 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
211 = pprCCall sty op args results liveness_mask vol_regs
213 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
215 non_void_args = grab_non_void_amodes args
216 non_void_results = grab_non_void_amodes results
217 -- if just one result, we print in the obvious "assignment" style;
218 -- if 0 or many results, we emit a macro call, w/ the results
219 -- followed by the arguments. The macro presumably knows which
222 the_op = ppr_op_call non_void_results non_void_args
223 -- liveness mask is *in* the non_void_args
225 BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
226 if primOpNeedsWrapper op then
227 uppAboves [ pp_saves,
235 ppr_op_call results args
236 = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
237 uppIntersperse uppComma (map ppr_op_result results),
238 if null results || null args then uppNil else uppComma,
239 uppIntersperse uppComma (map (pprAmode sty) args),
242 ppr_op_result r = ppr_amode sty r
243 -- primop macros do their own casting of result;
244 -- hence we can toss the provided cast...
246 pprAbsC sty (CSimultaneous abs_c) c
247 = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"]
249 pprAbsC sty stmt@(CMacroStmt macro as) _
250 = uppBesides [uppStr (show macro), uppLparen,
251 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
252 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
253 = uppBesides [uppPStr op, uppLparen,
254 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
255 pprAbsC sty stmt@(CCallProfCCMacro op as) _
256 = uppBesides [uppPStr op, uppLparen,
257 uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
259 pprAbsC sty (CCodeBlock label abs_C) _
260 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
261 BIND (pprTempAndExternDecls abs_C) _TO_ (pp_temps, pp_exts) ->
263 uppBesides [uppStr (if (externallyVisibleCLabel label)
264 then "FN_(" -- abbreviations to save on output
266 pprCLabel sty label, uppStr ") {"],
268 PprForC _ -> uppAbove pp_exts pp_temps
270 uppNest 8 (uppPStr SLIT("FB_")),
271 uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
272 uppNest 8 (uppPStr SLIT("FE_")),
276 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
277 = uppBesides [ pp_init_hdr, uppStr "_HDR(",
278 ppr_amode sty (CAddr reg_rel), uppComma,
279 pprCLabel sty info_lbl, uppComma,
280 if_profiling sty (pprAmode sty cost_centre), uppComma,
281 pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
283 info_lbl = infoTableLabelFromCI cl_info
284 sm_rep = closureSMRep cl_info
285 size = closureSizeWithoutFixedHdr cl_info
286 ptr_wds = closurePtrsSize cl_info
288 pp_init_hdr = uppStr (if inplace_upd then
289 getSMUpdInplaceHdrStr sm_rep
291 getSMInitHdrStr sm_rep)
293 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
294 = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
300 uppStr "SET_STATIC_HDR(",
301 pprCLabel sty closure_lbl, uppComma,
302 pprCLabel sty info_lbl, uppComma,
303 if_profiling sty (pprAmode sty cost_centre), uppComma,
304 ppLocalness closure_lbl, uppComma,
305 ppLocalnessMacro False{-for data-} info_lbl,
308 uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
309 uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
313 info_lbl = infoTableLabelFromCI cl_info
316 = if getAmodeKind item == VoidKind
317 then uppStr ", (W_) 0" -- might not even need this...
318 else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
321 if not (closureUpdReqd cl_info) then
324 BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed ->
325 nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
329 STATIC_INIT_HDR(c,i,localness) blows into:
330 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
332 then *NO VarHdr STUFF FOR STATIC*...
334 then the amodes are dropped in...
340 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
345 pprCLabel sty info_lbl, uppComma,
347 -- CONST_ITBL needs an extra label for
348 -- the static version of the object.
349 if isConstantRep sm_rep
350 then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
353 pprCLabel sty slow_lbl, uppComma,
354 pprAmode sty upd, uppComma,
355 uppInt liveness, uppComma,
359 pp_ptr_wds, uppComma,
361 ppLocalness info_lbl, uppComma,
362 ppLocalnessMacro True{-function-} slow_lbl, uppComma,
365 then uppBeside (uppInt select_word_i) uppComma
368 if_profiling sty pp_kind, uppComma,
369 if_profiling sty pp_descr, uppComma,
370 if_profiling sty pp_type,
376 Just fast -> let stuff = CCodeBlock fast_lbl fast in
377 pprAbsC sty stuff (costs stuff)
380 info_lbl = infoTableLabelFromCI cl_info
381 fast_lbl = fastLabelFromCI cl_info
382 sm_rep = closureSMRep cl_info
385 = case (nonemptyAbsC slow) of
386 Nothing -> (mkErrorStdEntryLabel, uppNil)
387 Just xx -> (entryLabelFromCI cl_info,
388 let stuff = CCodeBlock slow_lbl xx in
389 pprAbsC sty stuff (costs stuff))
391 maybe_selector = maybeSelectorInfo cl_info
392 is_selector = maybeToBool maybe_selector
393 (Just (_, select_word_i)) = maybe_selector
395 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
396 = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
398 pp_tag = uppInt (closureSemiTag cl_info)
400 is_phantom = isPhantomRep sm_rep
402 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
403 uppInt (closureNonHdrSize cl_info)
405 else if is_phantom then -- do not have sizes for these
408 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
410 pp_ptr_wds = if is_phantom then
413 uppInt (closurePtrsSize cl_info)
415 pp_kind = uppStr (closureKind cl_info)
416 pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
417 pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
419 pprAbsC sty (CRetVector lbl maybes deflt) c
420 = uppAboves [ uppStr "{ // CRetVector (lbl????)",
421 uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
422 uppStr "} /*default=*/ {", pprAbsC sty deflt c,
425 ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
426 ppr_maybe_amode sty (Just a) = pprAmode sty a
428 pprAbsC sty stmt@(CRetUnVector label amode) _
429 = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma,
430 pprAmode sty amode, uppRparen]
432 pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
434 pprAbsC sty stmt@(CFlatRetVector label amodes) _
435 = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
440 uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
441 pprCLabel sty label, uppStr "[] = {"],
442 uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
446 ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
448 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
451 -- Only used for debugging (i.e output abstractC instead of APAL)
452 pprAbsC sty (CNativeInfoTableAndCode _ _ absC)
453 = uppAboves [uppStr "CNativeInfoTableAndCode (DPH)",
455 #endif {- Data Parallel Haskell -}
460 = uppBeside static const
462 static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
463 const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
465 ppLocalnessMacro for_fun{-vs data-} clabel
466 = BIND (if externallyVisibleCLabel clabel then "E" else "I") _TO_ prefix ->
467 BIND (if isReadOnly clabel then "RO_" else "") _TO_ suffix ->
469 then uppStr (prefix ++ "F_")
470 else uppStr (prefix ++ "D_" ++ suffix)
475 grab_non_void_amodes amodes
476 = filter non_void amodes
479 = case (getAmodeKind amode) of
485 ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
487 ppr_vol_regs sty [] = (uppNil, uppNil)
488 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
489 ppr_vol_regs sty (r:rs)
490 = let pp_reg = case r of
491 VanillaReg pk n -> pprVanillaReg n
492 _ -> pprMagicId sty r
493 (more_saves, more_restores) = ppr_vol_regs sty rs
495 (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
496 uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
498 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
499 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
500 -- depending on the platform. (The "volatile regs" stuff handles all
501 -- other registers.) Just be *sure* BaseReg is OK before trying to do
505 uppPStr SLIT("CALLER_SAVE_Base"),
506 uppPStr SLIT("CALLER_SAVE_SpA"),
507 uppPStr SLIT("CALLER_SAVE_SuA"),
508 uppPStr SLIT("CALLER_SAVE_SpB"),
509 uppPStr SLIT("CALLER_SAVE_SuB"),
510 uppPStr SLIT("CALLER_SAVE_Ret"),
511 -- uppPStr SLIT("CALLER_SAVE_Activity"),
512 uppPStr SLIT("CALLER_SAVE_Hp"),
513 uppPStr SLIT("CALLER_SAVE_HpLim") ]
517 uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
518 uppPStr SLIT("CALLER_RESTORE_SpA"),
519 uppPStr SLIT("CALLER_RESTORE_SuA"),
520 uppPStr SLIT("CALLER_RESTORE_SpB"),
521 uppPStr SLIT("CALLER_RESTORE_SuB"),
522 uppPStr SLIT("CALLER_RESTORE_Ret"),
523 -- uppPStr SLIT("CALLER_RESTORE_Activity"),
524 uppPStr SLIT("CALLER_RESTORE_Hp"),
525 uppPStr SLIT("CALLER_RESTORE_HpLim"),
526 uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
527 uppPStr SLIT("CALLER_RESTORE_StkStub") ]
531 if_profiling sty pretty
533 PprForC sw_chker -> if sw_chker SccProfilingOn
535 else uppChar '0' -- leave it out!
537 _ -> {-print it anyway-} pretty
539 -- ---------------------------------------------------------------------------
540 -- Changes for GrAnSim:
541 -- draw costs for computation in head of if into both branches;
542 -- as no abstractC data structure is given for the head, one is constructed
543 -- guessing unknown values and fed into the costs function
544 -- ---------------------------------------------------------------------------
546 do_if_stmt sty discrim tag alt_code deflt c
548 -- This special case happens when testing the result of a comparison.
549 -- We can just avoid some redundant clutter in the output.
550 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
552 (addrModeCosts discrim Rhs) c
554 cond = uppBesides [ pprAmode sty discrim,
555 uppPStr SLIT(" == "),
556 pprAmode sty (CLit tag) ]
560 (addrModeCosts discrim Rhs) c
562 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
564 uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
565 uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
566 (Cost (0, 2, 0, 0, 0)) +
568 (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
569 uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
570 (Cost (0, 1, 0, 0, 0)) +
573 {- Total costs = inherited costs (before if) + costs for accessing discrim
574 + costs for cond branch ( = (0, 1, 0, 0, 0) )
575 + costs for that alternative
579 Historical note: this used to be two separate cases -- one for `ccall'
580 and one for `casm'. To get round a potential limitation to only 10
581 arguments, the numbering of arguments in @process_casm@ was beefed up a
584 Some rough notes on generating code for @CCallOp@:
586 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
587 2) Save any essential registers (heap, stack, etc).
589 ToDo: If stable pointers are in use, these must be saved in a place
590 where the runtime system can get at them so that the Stg world can
591 be restarted during the call.
593 3) Save any temporary registers that are currently in use.
594 4) Do the call putting result into a local variable
595 5) Restore essential registers
596 6) Restore temporaries
598 (This happens after restoration of essential registers because we
599 might need the @Base@ register to access all the others correctly.)
601 7) If returning Malloc Pointer, build a closure containing the
604 Otherwise, copy local variable into result register.
606 8) If ccall (not casm), declare the function being called as extern so
607 that C knows if it returns anything other than an int.
610 { ResultType _ccall_result;
613 _ccall_result = f( args );
618 constructMallocPtr(liveness, return_reg, _ccall_result);
620 return_reg = _ccall_result;
625 Amendment to the above: if we can GC, we have to:
627 * make sure we save all our registers away where the garbage collector
629 * be sure that there are no live registers or we're in trouble.
630 (This can cause problems if you try something foolish like passing
631 an array or mallocptr to a _ccall_GC_ thing.)
632 * increment/decrement the @inCCallGC@ counter before/after the call so
633 that the runtime check that PerformGC is being used sensibly will work.
636 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
637 = if (may_gc && liveness_mask /= noLiveRegsMask)
638 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
640 -- trace ("casm \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat localVars)) ++ (uppShow 80 (uppCat pp_non_void_args)))
643 declare_local_vars, -- local var for *result*
644 uppAboves local_arg_decls,
645 -- if is_asm then uppNil else declareExtern,
647 process_casm local_vars pp_non_void_args casm_str,
653 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
654 (pp_save_context, pp_restore_context) =
656 then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
657 uppStr "inCCallGC--; RestoreAllStgRegs();")
658 else ( pp_basic_saves `uppAbove` pp_saves,
659 pp_basic_restores `uppAbove` pp_restores)
663 in ASSERT (all non_void nvas) nvas
664 -- the first argument will be the "I/O world" token (a VoidKind)
665 -- all others should be non-void
668 let nvrs = grab_non_void_amodes results
669 in ASSERT (length nvrs <= 1) nvrs
670 -- there will usually be two results: a (void) state which we
671 -- should ignore and a (possibly void) result.
673 (local_arg_decls, pp_non_void_args)
674 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
676 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
678 (declare_local_vars, local_vars, assign_results)
679 = ppr_casm_results sty non_void_results pp_liveness
681 casm_str = if is_asm then _UNPK_ op_str else ccall_str
683 -- Remainder only used for ccall
685 ccall_str = uppShow 80
687 if null non_void_results
689 else uppPStr SLIT("%r = "),
690 uppLparen, uppPStr op_str, uppLparen,
691 uppIntersperse uppComma ccall_args,
694 num_args = length non_void_args
695 ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
698 If the argument is a heap object, we need to reach inside and pull out
699 the bit the C world wants to see. The only heap objects which can be
700 passed are @Array@s, @ByteArray@s and @MallocPtr@s.
703 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
704 -- (a) decl and assignment, (b) local var to be used later
706 ppr_casm_arg sty amode a_num
708 a_kind = getAmodeKind amode
709 pp_amode = pprAmode sty amode
710 pp_kind = pprPrimKind sty a_kind
712 local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
714 (arg_type, pp_amode2)
717 -- for array arguments, pass a pointer to the body of the array
718 -- (PTRS_ARR_CTS skips over all the header nonsense)
719 ArrayKind -> (pp_kind,
720 uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
721 ByteArrayKind -> (pp_kind,
722 uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
724 -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents.
725 MallocPtrKind -> (uppPStr SLIT("StgMallocPtr"),
726 uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
727 other -> (pp_kind, pp_amode)
730 = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
732 (declare_local_var, local_var)
735 For l-values, the critical questions are:
737 1) Are there any results at all?
739 We only allow zero or one results.
741 2) Is the result is a mallocptr?
743 The mallocptr must be encapsulated immediately in a heap object.
748 -> [CAddrMode] -- list of results (length <= 1)
749 -> Unpretty -- liveness mask
751 ( Unpretty, -- declaration of any local vars
752 [Unpretty], -- list of result vars (same length as results)
753 Unpretty ) -- assignment (if any) of results in local var to registers
755 ppr_casm_results sty [] liveness
756 = (uppNil, [], uppNil) -- no results
758 ppr_casm_results sty [r] liveness
760 result_reg = ppr_amode sty r
761 r_kind = getAmodeKind r
763 local_var = uppPStr SLIT("_ccall_result")
765 (result_type, assign_result)
768 (uppPStr SLIT("StgMallocPtr"),
769 uppBesides [ uppStr "constructMallocPtr(",
771 result_reg, uppComma,
775 (pprPrimKind sty r_kind,
776 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
778 declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
780 (declare_local_var, [local_var], assign_result)
782 ppr_casm_results sty rs liveness
783 = panic "ppr_casm_results: ccall/casm with many results"
787 Note the sneaky way _the_ result is represented by a list so that we
788 can complain if it's used twice.
790 ToDo: Any chance of giving line numbers when process-casm fails?
791 Or maybe we should do a check _much earlier_ in compiler. ADR
795 [Unpretty] -- results (length <= 1)
796 -> [Unpretty] -- arguments
797 -> String -- format string (with embedded %'s)
799 Unpretty -- code being generated
801 process_casm results args string = process results args string
803 process [] _ "" = uppNil
804 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
806 process ress args ('%':cs)
809 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
812 uppBeside (uppChar '%') (process ress args css)
816 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
817 [r] -> uppBeside r (process [] args css)
818 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
821 case readDec other of
823 if 0 <= num && num < length args
824 then uppBesides [uppLparen, args !! num, uppRparen,
825 process ress args css]
826 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
827 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
829 process ress args (other_c:cs)
830 = uppBeside (uppChar other_c) (process ress args cs)
833 %************************************************************************
835 \subsection[a2r-assignments]{Assignments}
837 %************************************************************************
839 Printing assignments is a little tricky because of type coercion.
841 First of all, the kind of the thing being assigned can be gotten from
842 the destination addressing mode. (It should be the same as the kind
843 of the source addressing mode.) If the kind of the assignment is of
844 @VoidKind@, then don't generate any code at all.
847 pprAssign :: PprStyle -> PrimKind -> CAddrMode -> CAddrMode -> Unpretty
849 pprAssign sty VoidKind dest src = uppNil
852 pprAssign sty kind dest src
853 | (kind /= getAmodeKind dest) || (kind /= getAmodeKind src)
854 = uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
855 pprPrimKind sty (getAmodeKind dest), pprAmode sty dest,
856 pprPrimKind sty (getAmodeKind src), pprAmode sty src]
860 Special treatment for floats and doubles, to avoid unwanted conversions.
863 pprAssign sty FloatKind dest@(CVal reg_rel _) src
864 = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
866 pprAssign sty DoubleKind dest@(CVal reg_rel _) src
867 = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
870 Lastly, the question is: will the C compiler think the types of the
871 two sides of the assignment match?
873 We assume that the types will match
874 if neither side is a @CVal@ addressing mode for any register
875 which can point into the heap or B stack.
877 Why? Because the heap and B stack are used to store miscellaneous things,
878 whereas the A stack, temporaries, registers, etc., are only used for things
882 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
883 = uppBesides [ pprVanillaReg dest, uppEquals,
884 pprVanillaReg src, uppSemi ]
886 pprAssign sty kind dest src
888 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
889 = uppBesides [ ppr_amode sty dest, uppEquals,
890 uppStr "(W_)(", -- Here is the cast
891 ppr_amode sty src, pp_paren_semi ]
893 pprAssign sty kind dest src
894 | mixedPtrLocn dest && getAmodeKind src /= PtrKind
895 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
896 = uppBesides [ ppr_amode sty dest, uppEquals,
897 uppStr "(P_)(", -- Here is the cast
898 ppr_amode sty src, pp_paren_semi ]
900 pprAssign sty ByteArrayKind dest src
902 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
903 = uppBesides [ ppr_amode sty dest, uppEquals,
904 uppStr "(B_)(", -- Here is the cast
905 ppr_amode sty src, pp_paren_semi ]
907 pprAssign sty kind other_dest src
908 = uppBesides [ ppr_amode sty other_dest, uppEquals,
909 pprAmode sty src, uppSemi ]
913 %************************************************************************
915 \subsection[a2r-CAddrModes]{Addressing modes}
917 %************************************************************************
919 @pprAmode@ is used to print r-values (which may need casts), whereas
920 @ppr_amode@ is used for l-values {\em and} as a help function for
924 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
927 For reasons discussed above under assignments, @CVal@ modes need
928 to be treated carefully. First come special cases for floats and doubles,
929 similar to those in @pprAssign@:
931 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
935 pprAmode sty (CVal reg_rel FloatKind)
936 = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
937 pprAmode sty (CVal reg_rel DoubleKind)
938 = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
941 Next comes the case where there is some other cast need, and the
946 | mixedTypeLocn amode
947 = uppBesides [ uppLparen, pprPrimKind sty (getAmodeKind amode), uppStr ")(",
948 ppr_amode sty amode, uppRparen]
949 | otherwise -- No cast needed
950 = ppr_amode sty amode
953 Now the rest of the cases for ``workhorse'' @ppr_amode@:
956 ppr_amode sty (CVal reg_rel _)
957 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
958 (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
959 (pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
961 ppr_amode sty (CAddr reg_rel)
962 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
963 (pp_reg, Nothing) -> pp_reg
964 (pp_reg, Just offset) -> uppBeside pp_reg offset
966 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
968 ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
970 ppr_amode sty (CLbl label kind) = pprCLabel sty label
972 ppr_amode sty (CUnVecLbl direct vectored)
973 = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
974 pprCLabel sty vectored, uppRparen]
976 ppr_amode sty (CCharLike char)
977 = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
978 ppr_amode sty (CIntLike int)
979 = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
981 ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
982 -- ToDo: are these *used* for anything?
984 ppr_amode sty (CLit lit) = pprBasicLit sty lit
986 ppr_amode sty (CLitLit str _) = uppPStr str
988 ppr_amode sty (COffset off) = pprHeapOffset sty off
990 ppr_amode sty (CCode abs_C)
991 = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
993 ppr_amode sty (CLabelledCode label abs_C)
994 = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"],
995 uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
997 ppr_amode sty (CJoinPoint _ _)
998 = panic "ppr_amode: CJoinPoint"
1000 ppr_amode sty (CTableEntry base index kind)
1001 = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
1002 ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
1005 ppr_amode sty (CMacroExpr pk macro as)
1006 = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
1007 uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
1009 ppr_amode sty (CCostCentre cc print_as_string)
1010 = uppCostCentre sty print_as_string cc
1013 %************************************************************************
1015 \subsection[a2r-MagicIds]{Magic ids}
1017 %************************************************************************
1019 @pprRegRelative@ returns a pair of the @Unpretty@ for the register
1020 (some casting may be required), and a @Maybe Unpretty@ for the offset
1021 (zero offset gives a @Nothing@).
1024 addPlusSign :: Bool -> Unpretty -> Unpretty
1025 addPlusSign False p = p
1026 addPlusSign True p = uppBeside (uppChar '+') p
1028 pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
1029 pprSignedInt sign_wanted n
1030 = if n == 0 then Nothing else
1031 if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
1032 else Just (uppInt n)
1034 pprRegRelative :: PprStyle
1035 -> Bool -- True <=> Print leading plus sign (if +ve)
1037 -> (Unpretty, Maybe Unpretty)
1039 pprRegRelative sty sign_wanted r@(SpARel spA off)
1040 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt r))
1042 pprRegRelative sty sign_wanted r@(SpBRel spB off)
1043 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt r))
1045 pprRegRelative sty sign_wanted r@(HpRel hp off)
1046 = let to_print = hp `subOff` off
1047 pp_Hp = pprMagicId sty Hp
1049 if isZeroOff to_print then
1052 (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print)))
1053 -- No parens needed because pprHeapOffset
1054 -- does them when necessary
1056 pprRegRelative sty sign_wanted (NodeRel off)
1057 = let pp_Node = pprMagicId sty node
1059 if isZeroOff off then
1062 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1066 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1067 represented by a discriminated union (@StgUnion@), so we use the @PrimKind@
1068 to select the union tag.
1071 pprMagicId :: PprStyle -> MagicId -> Unpretty
1073 pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
1074 pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
1075 pprMagicId sty (VanillaReg pk n)
1076 = uppBesides [ pprVanillaReg n, uppChar '.',
1078 pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
1079 pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
1080 pprMagicId sty TagReg = uppPStr SLIT("TagReg")
1081 pprMagicId sty RetReg = uppPStr SLIT("RetReg")
1082 pprMagicId sty SpA = uppPStr SLIT("SpA")
1083 pprMagicId sty SuA = uppPStr SLIT("SuA")
1084 pprMagicId sty SpB = uppPStr SLIT("SpB")
1085 pprMagicId sty SuB = uppPStr SLIT("SuB")
1086 pprMagicId sty Hp = uppPStr SLIT("Hp")
1087 pprMagicId sty HpLim = uppPStr SLIT("HpLim")
1088 pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
1089 --UNUSED pprMagicId sty ActivityReg = uppPStr SLIT("ActivityReg")
1090 pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
1091 pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
1092 pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
1093 pprMagicId sty VoidReg = {-uppStr "RetVoid!"-} panic "pprMagicId:VoidReg!"
1095 pprMagicId sty (DataReg _ n) = uppBeside (uppPStr SLIT("RD")) (uppInt n)
1096 #endif {- Data Parallel Haskell -}
1098 pprVanillaReg :: FAST_INT -> Unpretty
1100 pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
1102 pprUnionTag :: PrimKind -> Unpretty
1104 pprUnionTag PtrKind = uppChar 'p'
1105 pprUnionTag CodePtrKind = uppPStr SLIT("fp")
1106 pprUnionTag DataPtrKind = uppChar 'd'
1107 pprUnionTag RetKind = uppChar 'r'
1108 pprUnionTag InfoPtrKind = uppChar 'd'
1109 pprUnionTag CostCentreKind = panic "pprUnionTag:CostCentre?"
1111 pprUnionTag CharKind = uppChar 'c'
1112 pprUnionTag IntKind = uppChar 'i'
1113 pprUnionTag WordKind = uppChar 'w'
1114 pprUnionTag AddrKind = uppChar 'v'
1115 pprUnionTag FloatKind = uppChar 'f'
1116 pprUnionTag DoubleKind = panic "pprUnionTag:Double?"
1118 pprUnionTag StablePtrKind = uppChar 'i'
1119 pprUnionTag MallocPtrKind = uppChar 'p'
1121 pprUnionTag ArrayKind = uppChar 'p'
1122 pprUnionTag ByteArrayKind = uppChar 'b'
1124 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1129 Find and print local and external declarations for a list of
1130 Abstract~C statements.
1132 pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-})
1133 pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
1135 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1136 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1137 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1138 BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps ->
1139 BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts ->
1140 returnTE (uppAboves real_temps, uppAboves real_exts)
1144 pprTempAndExternDecls other_stmt
1145 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1156 pprBasicLit :: PprStyle -> BasicLit -> Unpretty
1157 pprPrimKind :: PprStyle -> PrimKind -> Unpretty
1159 pprBasicLit sty lit = uppStr (showBasicLit sty lit)
1160 pprPrimKind sty k = uppStr (showPrimKind k)
1164 %************************************************************************
1166 \subsection[a2r-monad]{Monadery}
1168 %************************************************************************
1170 We need some monadery to keep track of temps and externs we have already
1171 printed. This info must be threaded right through the Abstract~C, so
1172 it's most convenient to hide it in this monad.
1174 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1175 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1178 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1179 emptyCLabelSet = emptyFM
1180 x `elementOfCLabelSet` labs
1181 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1182 addToCLabelSet set x = addToFM set x ()
1184 type UniqueSet = UniqFM ()
1185 emptyUniqueSet = emptyUFM
1186 x `elementOfUniqueSet` us
1187 = case (lookupDirectlyUFM us x) of { Just _ -> True; Nothing -> False }
1188 addToUniqueSet set x = set `plusUFM` singletonDirectlyUFM x ()
1190 type TEenv = (UniqueSet, CLabelSet)
1192 type TeM result = TEenv -> (TEenv, result)
1194 initTE :: TeM a -> a
1196 = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
1199 #ifdef __GLASGOW_HASKELL__
1200 {-# INLINE thenTE #-}
1201 {-# INLINE returnTE #-}
1204 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1206 = case a u of { (u_1, result_of_a) ->
1209 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1210 mapTE f [] = returnTE []
1212 = f x `thenTE` \ r ->
1213 mapTE f xs `thenTE` \ rs ->
1216 returnTE :: a -> TeM a
1217 returnTE result env = (env, result)
1219 -- these next two check whether the thing is already
1220 -- recorded, and THEN THEY RECORD IT
1221 -- (subsequent calls will return False for the same uniq/label)
1223 tempSeenTE :: Unique -> TeM Bool
1224 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1225 = if (uniq `elementOfUniqueSet` seen_uniqs)
1227 else ((addToUniqueSet seen_uniqs uniq,
1231 labelSeenTE :: CLabel -> TeM Bool
1232 labelSeenTE label env@(seen_uniqs, seen_labels)
1233 = if (label `elementOfCLabelSet` seen_labels)
1236 addToCLabelSet seen_labels label),
1241 pprTempDecl :: Unique -> PrimKind -> Unpretty
1242 pprTempDecl uniq kind
1243 = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
1245 ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
1247 pprExternDecl :: CLabel -> PrimKind -> Unpretty
1249 pprExternDecl clabel kind
1250 = if not (needsCDecl clabel) then
1251 uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
1255 CodePtrKind -> ppLocalnessMacro True{-function-} clabel
1256 _ -> ppLocalnessMacro False{-data-} clabel
1257 ) _TO_ pp_macro_str ->
1259 uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ]
1264 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
1266 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1268 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1269 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1270 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1271 returnTE (maybe_uppAboves [p1, p2])
1273 ppr_decls_AbsC (CClosureUpdInfo info)
1274 = ppr_decls_AbsC info
1276 --UNUSED: ppr_decls_AbsC (CComment comment) = returnTE (Nothing, Nothing)
1278 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1280 ppr_decls_AbsC (CAssign dest source)
1281 = ppr_decls_Amode dest `thenTE` \ p1 ->
1282 ppr_decls_Amode source `thenTE` \ p2 ->
1283 returnTE (maybe_uppAboves [p1, p2])
1285 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1287 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1289 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1291 ppr_decls_AbsC (CSwitch discrim alts deflt)
1292 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1293 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1294 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1295 returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
1297 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1299 ppr_decls_AbsC (CCodeBlock label absC)
1300 = ppr_decls_AbsC absC
1302 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1303 -- ToDo: strictly speaking, should chk "cost_centre" amode
1304 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1309 Just (pprExternDecl info_lbl PtrKind))
1311 info_lbl = infoTableLabelFromCI cl_info
1313 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1314 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1316 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1318 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1319 -- you get some nasty re-decls of stdio.h if you compile
1320 -- the prelude while looking inside those amodes;
1321 -- no real reason to, anyway.
1322 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1324 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1325 -- ToDo: strictly speaking, should chk "cost_centre" amode
1326 = ppr_decls_Amodes amodes
1328 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1329 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1330 ppr_decls_AbsC slow `thenTE` \ p2 ->
1332 Nothing -> returnTE (Nothing, Nothing)
1333 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1334 returnTE (maybe_uppAboves [p1, p2, p3])
1336 entry_lbl = CLbl slow_lbl CodePtrKind
1337 slow_lbl = case (nonemptyAbsC slow) of
1338 Nothing -> mkErrorStdEntryLabel
1339 Just _ -> entryLabelFromCI cl_info
1341 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1342 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1343 ppr_decls_AbsC absC `thenTE` \ p2 ->
1344 returnTE (maybe_uppAboves [p1, p2])
1346 ppr_decls_AbsC (CRetUnVector label amode)
1347 = ppr_decls_Amode amode
1349 ppr_decls_AbsC (CFlatRetVector label amodes)
1350 = ppr_decls_Amodes amodes
1353 ppr_decls_AbsC (CNativeInfoTableAndCode _ _ absC)
1354 = ppr_decls_AbsC absC
1355 #endif {- Data Parallel Haskell -}
1359 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
1360 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1361 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1362 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1363 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1364 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1365 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1366 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1368 -- CIntLike must be a literal -- no decls
1369 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1371 -- CCharLike may have be arbitrary value -- may have decls
1372 ppr_decls_Amode (CCharLike char)
1373 = ppr_decls_Amode char
1375 -- now, the only place where we actually print temps/externs...
1376 ppr_decls_Amode (CTemp uniq kind)
1378 VoidKind -> returnTE (Nothing, Nothing)
1380 tempSeenTE uniq `thenTE` \ temp_seen ->
1382 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1384 ppr_decls_Amode (CLbl label VoidKind)
1385 = returnTE (Nothing, Nothing)
1387 ppr_decls_Amode (CLbl label kind)
1388 = labelSeenTE label `thenTE` \ label_seen ->
1390 if label_seen then Nothing else Just (pprExternDecl label kind))
1393 ppr_decls_Amode (CUnVecLbl direct vectored)
1394 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1395 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1397 ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrKind
1398 vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrKind
1401 if (dlbl_seen || not (needsCDecl direct)) &&
1402 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1403 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1406 ppr_decls_Amode (CUnVecLbl direct vectored)
1407 = -- We don't mark either label as "seen", because
1408 -- we don't know which one will be used and which one tossed
1409 -- by the C macro...
1410 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1411 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1413 ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrKind
1414 vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrKind
1417 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1418 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1419 else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen]))
1421 ppr_decls_Amode (CTableEntry base index _)
1422 = ppr_decls_Amode base `thenTE` \ p1 ->
1423 ppr_decls_Amode index `thenTE` \ p2 ->
1424 returnTE (maybe_uppAboves [p1, p2])
1426 ppr_decls_Amode (CMacroExpr _ _ amodes)
1427 = ppr_decls_Amodes amodes
1429 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1432 maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
1434 = BIND (unzip ps) _TO_ (ts, es) ->
1435 BIND (catMaybes ts) _TO_ real_ts ->
1436 BIND (catMaybes es) _TO_ real_es ->
1437 (if (null real_ts) then Nothing else Just (uppAboves real_ts),
1438 if (null real_es) then Nothing else Just (uppAboves real_es))
1443 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
1444 ppr_decls_Amodes amodes
1445 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1446 returnTE ( maybe_uppAboves ps )