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
23 IMPORT_1_3(IO(Handle))
24 IMPORT_1_3(Char(isDigit,isPrint))
25 #if __GLASGOW_HASKELL__ == 201
26 IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
27 #elif __GLASGOW_HASKELL__ >= 202
28 import GlaExts (Addr(..))
31 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
32 IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
34 import {-# SOURCE #-} ClosureInfo
39 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
40 mixedPtrLocn, mixedTypeLocn
42 import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
43 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
44 isReadOnly, needsCDecl, pprCLabel,
45 CLabel{-instance Ord-}
47 import CmdLineOpts ( opt_SccProfilingOn )
48 import CostCentre ( uppCostCentre, uppCostCentreDecl )
49 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
50 import CStrings ( stringToC )
51 import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
52 import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
53 import Literal ( showLiteral, Literal(..) )
54 import Maybes ( maybeToBool, catMaybes )
56 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
57 import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
58 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
59 isConstantRep, isSpecRep, isPhantomRep
61 import Unique ( pprUnique, Unique{-instance NamedThing-} )
62 import UniqSet ( emptyUniqSet, elementOfUniqSet,
63 addOneToUniqSet, SYN_IE(UniqSet)
65 import Outputable ( PprStyle(..), printDoc )
66 import Util ( nOfThem, panic, assertPanic )
71 For spitting out the costs of an abstract~C expression, @writeRealC@
72 now not only prints the C~code of the @absC@ arg but also adds a macro
73 call to a cost evaluation function @GRAN_EXEC@. For that,
74 @pprAbsC@ has a new ``costs'' argument. %% HWL
77 writeRealC :: Handle -> AbstractC -> IO ()
78 writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
80 dumpRealC :: AbstractC -> String
81 dumpRealC absC = show (pprAbsC PprForC absC (costs absC))
84 This emits the macro, which is used in GrAnSim to compute the total costs
85 from a cost 5 tuple. %% HWL
88 emitMacro :: CostRes -> Doc
90 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
91 emitMacro (Cost (i,b,l,s,f))
92 = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
93 int i, comma, int b, comma, int l, comma,
94 int s, comma, int f, pp_paren_semi ]
98 pp_paren_semi = text ");"
100 -- ---------------------------------------------------------------------------
101 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
102 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
103 -- which must be done before the return i.e. inside absC code) HWL
104 -- ---------------------------------------------------------------------------
106 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
108 pprAbsC sty AbsCNop _ = empty
109 pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
111 pprAbsC sty (CClosureUpdInfo info) c
114 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
116 pprAbsC sty (CJump target) c
117 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
118 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
120 pprAbsC sty (CFallThrough target) c
121 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
122 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
124 -- --------------------------------------------------------------------------
125 -- Spit out GRAN_EXEC macro immediately before the return HWL
127 pprAbsC sty (CReturn am return_info) c
128 = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
129 (hcat [text jmp_lit, target, pp_paren_semi ])
131 target = case return_info of
132 DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
133 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
134 StaticVectoredReturn n -> mk_vector (int n) -- Always positive
135 mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
137 pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
139 -- we optimise various degenerate cases of CSwitches.
141 -- --------------------------------------------------------------------------
142 -- Assume: CSwitch is also end of basic block
143 -- costs function yields nullCosts for whole switch
144 -- ==> inherited costs c are those of basic block up to switch
145 -- ==> inherit c + costs for the corresponding branch
147 -- --------------------------------------------------------------------------
149 pprAbsC sty (CSwitch discrim [] deflt) c
150 = pprAbsC sty deflt (c + costs deflt)
151 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
153 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
154 = case (nonemptyAbsC deflt) of
155 Nothing -> -- one alt and no default
156 pprAbsC sty alt_code (c + costs alt_code)
157 -- Nothing conditional in here either HWL
159 Just dc -> -- make it an "if"
160 do_if_stmt sty discrim tag alt_code dc c
162 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
163 (tag2@(MachInt i2 _), alt_code2)] deflt) c
164 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
166 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
168 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
170 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
172 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
173 | isFloatingRep (getAmodeRep discrim)
174 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
177 hcat [text "switch (", pp_discrim, text ") {"],
178 nest 2 (vcat (map (ppr_alt sty) alts)),
179 (case (nonemptyAbsC deflt) of
182 nest 2 (vcat [ptext SLIT("default:"),
183 pprAbsC sty dc (c + switch_head_cost
185 ptext SLIT("break;")])),
189 = pprAmode sty discrim
191 ppr_alt sty (lit, absC)
192 = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
193 nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC))
194 (ptext SLIT("break;"))) ]
196 -- Costs for addressing header of switch and cond. branching -- HWL
197 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
199 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
200 = pprCCall sty op args results liveness_mask vol_regs
202 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
204 non_void_args = grab_non_void_amodes args
205 non_void_results = grab_non_void_amodes results
206 -- if just one result, we print in the obvious "assignment" style;
207 -- if 0 or many results, we emit a macro call, w/ the results
208 -- followed by the arguments. The macro presumably knows which
211 the_op = ppr_op_call non_void_results non_void_args
212 -- liveness mask is *in* the non_void_args
214 case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
215 if primOpNeedsWrapper op then
224 ppr_op_call results args
225 = hcat [ pprPrimOp sty op, lparen,
226 hcat (punctuate comma (map ppr_op_result results)),
227 if null results || null args then empty else comma,
228 hcat (punctuate comma (map (pprAmode sty) args)),
231 ppr_op_result r = ppr_amode sty r
232 -- primop macros do their own casting of result;
233 -- hence we can toss the provided cast...
235 pprAbsC sty (CSimultaneous abs_c) c
236 = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
238 pprAbsC sty stmt@(CMacroStmt macro as) _
239 = hcat [text (show macro), lparen,
240 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
241 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
242 = hcat [ptext op, lparen,
243 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
244 pprAbsC sty stmt@(CCallProfCCMacro op as) _
245 = hcat [ptext op, lparen,
246 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
248 pprAbsC sty (CCodeBlock label abs_C) _
249 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
250 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
252 hcat [text (if (externallyVisibleCLabel label)
253 then "FN_(" -- abbreviations to save on output
255 pprCLabel sty label, text ") {"],
257 PprForC -> ($$) pp_exts pp_temps
259 nest 8 (ptext SLIT("FB_")),
260 nest 8 (pprAbsC sty abs_C (costs abs_C)),
261 nest 8 (ptext SLIT("FE_")),
265 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
266 = hcat [ pp_init_hdr, text "_HDR(",
267 ppr_amode sty (CAddr reg_rel), comma,
268 pprCLabel sty info_lbl, comma,
269 if_profiling sty (pprAmode sty cost_centre), comma,
270 pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ]
272 info_lbl = infoTableLabelFromCI cl_info
273 sm_rep = closureSMRep cl_info
274 size = closureSizeWithoutFixedHdr cl_info
275 ptr_wds = closurePtrsSize cl_info
277 pp_init_hdr = text (if inplace_upd then
278 getSMUpdInplaceHdrStr sm_rep
280 getSMInitHdrStr sm_rep)
282 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
283 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
289 ptext SLIT("SET_STATIC_HDR"),char '(',
290 pprCLabel sty closure_lbl, comma,
291 pprCLabel sty info_lbl, comma,
292 if_profiling sty (pprAmode sty cost_centre), comma,
293 ppLocalness closure_lbl, comma,
294 ppLocalnessMacro False{-for data-} info_lbl,
297 nest 2 (hcat (map (ppr_item sty) amodes)),
298 nest 2 (hcat (map (ppr_item sty) padding_wds)),
302 info_lbl = infoTableLabelFromCI cl_info
305 = if getAmodeRep item == VoidRep
306 then text ", (W_) 0" -- might not even need this...
307 else (<>) (text ", (W_)") (ppr_amode sty item)
310 if not (closureUpdReqd cl_info) then
313 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
314 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
317 STATIC_INIT_HDR(c,i,localness) blows into:
318 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
320 then *NO VarHdr STUFF FOR STATIC*...
322 then the amodes are dropped in...
328 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
332 ptext SLIT("_ITBL"),char '(',
333 pprCLabel sty info_lbl, comma,
335 -- CONST_ITBL needs an extra label for
336 -- the static version of the object.
337 if isConstantRep sm_rep
338 then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
341 pprCLabel sty slow_lbl, comma,
342 pprAmode sty upd, comma,
349 ppLocalness info_lbl, comma,
350 ppLocalnessMacro True{-function-} slow_lbl, comma,
353 then (<>) (int select_word_i) comma
356 if_profiling sty pp_kind, comma,
357 if_profiling sty pp_descr, comma,
358 if_profiling sty pp_type,
364 Just fast -> let stuff = CCodeBlock fast_lbl fast in
365 pprAbsC sty stuff (costs stuff)
368 info_lbl = infoTableLabelFromCI cl_info
369 fast_lbl = fastLabelFromCI cl_info
370 sm_rep = closureSMRep cl_info
373 = case (nonemptyAbsC slow) of
374 Nothing -> (mkErrorStdEntryLabel, empty)
375 Just xx -> (entryLabelFromCI cl_info,
376 let stuff = CCodeBlock slow_lbl xx in
377 pprAbsC sty stuff (costs stuff))
379 maybe_selector = maybeSelectorInfo cl_info
380 is_selector = maybeToBool maybe_selector
381 (Just (_, select_word_i)) = maybe_selector
383 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
384 = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
386 pp_tag = int (closureSemiTag cl_info)
388 is_phantom = isPhantomRep sm_rep
390 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
391 int (closureNonHdrSize cl_info)
393 else if is_phantom then -- do not have sizes for these
396 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
398 pp_ptr_wds = if is_phantom then
401 int (closurePtrsSize cl_info)
403 pp_kind = text (closureKind cl_info)
404 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
405 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
407 pprAbsC sty (CRetVector lbl maybes deflt) c
408 = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
409 nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
410 text "} /*default=*/ {", pprAbsC sty deflt c,
413 ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/")
414 ppr_maybe_amode sty (Just a) = pprAmode sty a
416 pprAbsC sty stmt@(CRetUnVector label amode) _
417 = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
418 pprAmode sty amode, rparen]
420 pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
422 pprAbsC sty stmt@(CFlatRetVector label amodes) _
423 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
428 hcat [ppLocalness label, ptext SLIT(" W_ "),
429 pprCLabel sty label, text "[] = {"],
430 nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
433 ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
435 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
442 static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
443 const = if not (isReadOnly label) then empty else ptext SLIT("const")
445 ppLocalnessMacro for_fun{-vs data-} clabel
446 = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
450 (<>) (ptext SLIT("D_"))
451 (if isReadOnly clabel then
460 grab_non_void_amodes amodes
461 = filter non_void amodes
464 = case (getAmodeRep amode) of
470 ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
472 ppr_vol_regs sty [] = (empty, empty)
473 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
474 ppr_vol_regs sty (r:rs)
475 = let pp_reg = case r of
476 VanillaReg pk n -> pprVanillaReg n
477 _ -> pprMagicId sty r
478 (more_saves, more_restores) = ppr_vol_regs sty rs
480 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
481 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
483 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
484 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
485 -- depending on the platform. (The "volatile regs" stuff handles all
486 -- other registers.) Just be *sure* BaseReg is OK before trying to do
490 ptext SLIT("CALLER_SAVE_Base"),
491 ptext SLIT("CALLER_SAVE_SpA"),
492 ptext SLIT("CALLER_SAVE_SuA"),
493 ptext SLIT("CALLER_SAVE_SpB"),
494 ptext SLIT("CALLER_SAVE_SuB"),
495 ptext SLIT("CALLER_SAVE_Ret"),
496 -- ptext SLIT("CALLER_SAVE_Activity"),
497 ptext SLIT("CALLER_SAVE_Hp"),
498 ptext SLIT("CALLER_SAVE_HpLim") ]
502 ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
503 ptext SLIT("CALLER_RESTORE_SpA"),
504 ptext SLIT("CALLER_RESTORE_SuA"),
505 ptext SLIT("CALLER_RESTORE_SpB"),
506 ptext SLIT("CALLER_RESTORE_SuB"),
507 ptext SLIT("CALLER_RESTORE_Ret"),
508 -- ptext SLIT("CALLER_RESTORE_Activity"),
509 ptext SLIT("CALLER_RESTORE_Hp"),
510 ptext SLIT("CALLER_RESTORE_HpLim"),
511 ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
512 ptext SLIT("CALLER_RESTORE_StkStub") ]
516 if_profiling sty pretty
518 PprForC -> if opt_SccProfilingOn
520 else char '0' -- leave it out!
522 _ -> {-print it anyway-} pretty
524 -- ---------------------------------------------------------------------------
525 -- Changes for GrAnSim:
526 -- draw costs for computation in head of if into both branches;
527 -- as no abstractC data structure is given for the head, one is constructed
528 -- guessing unknown values and fed into the costs function
529 -- ---------------------------------------------------------------------------
531 do_if_stmt sty discrim tag alt_code deflt c
533 -- This special case happens when testing the result of a comparison.
534 -- We can just avoid some redundant clutter in the output.
535 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
537 (addrModeCosts discrim Rhs) c
539 cond = hcat [ pprAmode sty discrim,
541 pprAmode sty (CLit tag) ]
545 (addrModeCosts discrim Rhs) c
547 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
549 hcat [text "if (", pp_pred, text ") {"],
550 nest 8 (pprAbsC sty then_part (c + discrim_costs +
551 (Cost (0, 2, 0, 0, 0)) +
553 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
554 nest 8 (pprAbsC sty else_part (c + discrim_costs +
555 (Cost (0, 1, 0, 0, 0)) +
558 {- Total costs = inherited costs (before if) + costs for accessing discrim
559 + costs for cond branch ( = (0, 1, 0, 0, 0) )
560 + costs for that alternative
564 Historical note: this used to be two separate cases -- one for `ccall'
565 and one for `casm'. To get round a potential limitation to only 10
566 arguments, the numbering of arguments in @process_casm@ was beefed up a
569 Some rough notes on generating code for @CCallOp@:
571 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
572 2) Save any essential registers (heap, stack, etc).
574 ToDo: If stable pointers are in use, these must be saved in a place
575 where the runtime system can get at them so that the Stg world can
576 be restarted during the call.
578 3) Save any temporary registers that are currently in use.
579 4) Do the call putting result into a local variable
580 5) Restore essential registers
581 6) Restore temporaries
583 (This happens after restoration of essential registers because we
584 might need the @Base@ register to access all the others correctly.)
586 {- Doesn't apply anymore with ForeignObj, structure create via primop.
587 makeForeignObj (ForeignObj is not CReturnable)
588 7) If returning Malloc Pointer, build a closure containing the
591 Otherwise, copy local variable into result register.
593 8) If ccall (not casm), declare the function being called as extern so
594 that C knows if it returns anything other than an int.
597 { ResultType _ccall_result;
600 _ccall_result = f( args );
604 return_reg = _ccall_result;
608 Amendment to the above: if we can GC, we have to:
610 * make sure we save all our registers away where the garbage collector
612 * be sure that there are no live registers or we're in trouble.
613 (This can cause problems if you try something foolish like passing
614 an array or foreign obj to a _ccall_GC_ thing.)
615 * increment/decrement the @inCCallGC@ counter before/after the call so
616 that the runtime check that PerformGC is being used sensibly will work.
619 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
620 = if (may_gc && liveness_mask /= noLiveRegsMask)
621 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
625 declare_local_vars, -- local var for *result*
626 vcat local_arg_decls,
627 -- if is_asm then empty else declareExtern,
629 process_casm local_vars pp_non_void_args casm_str,
635 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
636 (pp_save_context, pp_restore_context) =
638 then ( text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
639 text "inCCallGC--; RestoreAllStgRegs();")
640 else ( pp_basic_saves $$ pp_saves,
641 pp_basic_restores $$ pp_restores)
645 in ASSERT (all non_void nvas) nvas
646 -- the first argument will be the "I/O world" token (a VoidRep)
647 -- all others should be non-void
650 let nvrs = grab_non_void_amodes results
651 in ASSERT (length nvrs <= 1) nvrs
652 -- there will usually be two results: a (void) state which we
653 -- should ignore and a (possibly void) result.
655 (local_arg_decls, pp_non_void_args)
656 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
658 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
660 (declare_local_vars, local_vars, assign_results)
661 = ppr_casm_results sty non_void_results pp_liveness
663 casm_str = if is_asm then _UNPK_ op_str else ccall_str
665 -- Remainder only used for ccall
669 if null non_void_results
672 lparen, ptext op_str, lparen,
673 hcat (punctuate comma ccall_args),
676 num_args = length non_void_args
677 ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
680 If the argument is a heap object, we need to reach inside and pull out
681 the bit the C world wants to see. The only heap objects which can be
682 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
685 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
686 -- (a) decl and assignment, (b) local var to be used later
688 ppr_casm_arg sty amode a_num
690 a_kind = getAmodeRep amode
691 pp_amode = pprAmode sty amode
692 pp_kind = pprPrimKind sty a_kind
694 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
696 (arg_type, pp_amode2)
699 -- for array arguments, pass a pointer to the body of the array
700 -- (PTRS_ARR_CTS skips over all the header nonsense)
701 ArrayRep -> (pp_kind,
702 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
703 ByteArrayRep -> (pp_kind,
704 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
706 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
707 ForeignObjRep -> (ptext SLIT("StgForeignObj"),
708 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
710 other -> (pp_kind, pp_amode)
713 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
715 (declare_local_var, local_var)
718 For l-values, the critical questions are:
720 1) Are there any results at all?
722 We only allow zero or one results.
724 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
725 2) Is the result is a foreign obj?
727 The mallocptr must be encapsulated immediately in a heap object.
732 -> [CAddrMode] -- list of results (length <= 1)
733 -> Doc -- liveness mask
735 ( Doc, -- declaration of any local vars
736 [Doc], -- list of result vars (same length as results)
737 Doc ) -- assignment (if any) of results in local var to registers
739 ppr_casm_results sty [] liveness
740 = (empty, [], empty) -- no results
742 ppr_casm_results sty [r] liveness
744 result_reg = ppr_amode sty r
745 r_kind = getAmodeRep r
747 local_var = ptext SLIT("_ccall_result")
749 (result_type, assign_result)
752 @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
753 Instead, external references have to explicitly turned into ForeignObjs
754 using the primop makeForeignObj#. Benefit: Multiple finalisation
755 routines can be accommodated and the below special case is not needed.
756 Price is, of course, that you have to explicitly wrap `foreign objects'
757 with makeForeignObj#.
760 (ptext SLIT("StgForeignObj"),
761 hcat [ ptext SLIT("constructForeignObj"),char '(',
768 (pprPrimKind sty r_kind,
769 hcat [ result_reg, equals, local_var, semi ])
771 declare_local_var = hcat [ result_type, space, local_var, semi ]
773 (declare_local_var, [local_var], assign_result)
775 ppr_casm_results sty rs liveness
776 = panic "ppr_casm_results: ccall/casm with many results"
780 Note the sneaky way _the_ result is represented by a list so that we
781 can complain if it's used twice.
783 ToDo: Any chance of giving line numbers when process-casm fails?
784 Or maybe we should do a check _much earlier_ in compiler. ADR
788 [Doc] -- results (length <= 1)
789 -> [Doc] -- arguments
790 -> String -- format string (with embedded %'s)
792 Doc -- code being generated
794 process_casm results args string = process results args string
796 process [] _ "" = empty
797 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
799 process ress args ('%':cs)
802 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
805 (<>) (char '%') (process ress args css)
809 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
810 [r] -> (<>) r (process [] args css)
811 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
815 read_int :: ReadS Int
818 case (read_int other) of
820 if 0 <= num && num < length args
821 then (<>) (parens (args !! num))
822 (process ress args css)
823 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
824 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
826 process ress args (other_c:cs)
827 = (<>) (char other_c) (process ress args cs)
830 %************************************************************************
832 \subsection[a2r-assignments]{Assignments}
834 %************************************************************************
836 Printing assignments is a little tricky because of type coercion.
838 First of all, the kind of the thing being assigned can be gotten from
839 the destination addressing mode. (It should be the same as the kind
840 of the source addressing mode.) If the kind of the assignment is of
841 @VoidRep@, then don't generate any code at all.
844 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
846 pprAssign sty VoidRep dest src = empty
849 Special treatment for floats and doubles, to avoid unwanted conversions.
852 pprAssign sty FloatRep dest@(CVal reg_rel _) src
853 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
855 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
856 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
859 Lastly, the question is: will the C compiler think the types of the
860 two sides of the assignment match?
862 We assume that the types will match
863 if neither side is a @CVal@ addressing mode for any register
864 which can point into the heap or B stack.
866 Why? Because the heap and B stack are used to store miscellaneous things,
867 whereas the A stack, temporaries, registers, etc., are only used for things
871 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
872 = hcat [ pprVanillaReg dest, equals,
873 pprVanillaReg src, semi ]
875 pprAssign sty kind dest src
877 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
878 = hcat [ ppr_amode sty dest, equals,
879 text "(W_)(", -- Here is the cast
880 ppr_amode sty src, pp_paren_semi ]
882 pprAssign sty kind dest src
883 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
884 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
885 = hcat [ ppr_amode sty dest, equals,
886 text "(P_)(", -- Here is the cast
887 ppr_amode sty src, pp_paren_semi ]
889 pprAssign sty ByteArrayRep dest src
891 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
892 = hcat [ ppr_amode sty dest, equals,
893 text "(B_)(", -- Here is the cast
894 ppr_amode sty src, pp_paren_semi ]
896 pprAssign sty kind other_dest src
897 = hcat [ ppr_amode sty other_dest, equals,
898 pprAmode sty src, semi ]
902 %************************************************************************
904 \subsection[a2r-CAddrModes]{Addressing modes}
906 %************************************************************************
908 @pprAmode@ is used to print r-values (which may need casts), whereas
909 @ppr_amode@ is used for l-values {\em and} as a help function for
913 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
916 For reasons discussed above under assignments, @CVal@ modes need
917 to be treated carefully. First come special cases for floats and doubles,
918 similar to those in @pprAssign@:
920 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
924 pprAmode sty (CVal reg_rel FloatRep)
925 = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
926 pprAmode sty (CVal reg_rel DoubleRep)
927 = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
930 Next comes the case where there is some other cast need, and the
935 | mixedTypeLocn amode
936 = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
937 ppr_amode sty amode ])
938 | otherwise -- No cast needed
939 = ppr_amode sty amode
942 Now the rest of the cases for ``workhorse'' @ppr_amode@:
945 ppr_amode sty (CVal reg_rel _)
946 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
947 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
948 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
950 ppr_amode sty (CAddr reg_rel)
951 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
952 (pp_reg, Nothing) -> pp_reg
953 (pp_reg, Just offset) -> (<>) pp_reg offset
955 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
957 ppr_amode sty (CTemp uniq kind) = pprUnique uniq
959 ppr_amode sty (CLbl label kind) = pprCLabel sty label
961 ppr_amode sty (CUnVecLbl direct vectored)
962 = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
963 pprCLabel sty vectored, rparen]
965 ppr_amode sty (CCharLike ch)
966 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
967 ppr_amode sty (CIntLike int)
968 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ]
970 ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
971 -- ToDo: are these *used* for anything?
973 ppr_amode sty (CLit lit) = pprBasicLit sty lit
975 ppr_amode sty (CLitLit str _) = ptext str
977 ppr_amode sty (COffset off) = pprHeapOffset sty off
979 ppr_amode sty (CCode abs_C)
980 = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
982 ppr_amode sty (CLabelledCode label abs_C)
983 = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
984 nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
986 ppr_amode sty (CJoinPoint _ _)
987 = panic "ppr_amode: CJoinPoint"
989 ppr_amode sty (CTableEntry base index kind)
990 = hcat [text "((", pprPrimKind sty kind, text " *)(",
991 ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
994 ppr_amode sty (CMacroExpr pk macro as)
995 = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
996 hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
998 ppr_amode sty (CCostCentre cc print_as_string)
999 = uppCostCentre sty print_as_string cc
1002 %************************************************************************
1004 \subsection[a2r-MagicIds]{Magic ids}
1006 %************************************************************************
1008 @pprRegRelative@ returns a pair of the @Doc@ for the register
1009 (some casting may be required), and a @Maybe Doc@ for the offset
1010 (zero offset gives a @Nothing@).
1013 addPlusSign :: Bool -> Doc -> Doc
1014 addPlusSign False p = p
1015 addPlusSign True p = (<>) (char '+') p
1017 pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0
1018 pprSignedInt sign_wanted n
1019 = if n == 0 then Nothing else
1020 if n > 0 then Just (addPlusSign sign_wanted (int n))
1023 pprRegRelative :: PprStyle
1024 -> Bool -- True <=> Print leading plus sign (if +ve)
1028 pprRegRelative sty sign_wanted (SpARel spA off)
1029 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1031 pprRegRelative sty sign_wanted (SpBRel spB off)
1032 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1034 pprRegRelative sty sign_wanted r@(HpRel hp off)
1035 = let to_print = hp `subOff` off
1036 pp_Hp = pprMagicId sty Hp
1038 if isZeroOff to_print then
1041 (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print)))
1042 -- No parens needed because pprHeapOffset
1043 -- does them when necessary
1045 pprRegRelative sty sign_wanted (NodeRel off)
1046 = let pp_Node = pprMagicId sty node
1048 if isZeroOff off then
1051 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1055 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1056 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1057 to select the union tag.
1060 pprMagicId :: PprStyle -> MagicId -> Doc
1062 pprMagicId sty BaseReg = ptext SLIT("BaseReg")
1063 pprMagicId sty StkOReg = ptext SLIT("StkOReg")
1064 pprMagicId sty (VanillaReg pk n)
1065 = hcat [ pprVanillaReg n, char '.',
1067 pprMagicId sty (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1068 pprMagicId sty (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1069 pprMagicId sty TagReg = ptext SLIT("TagReg")
1070 pprMagicId sty RetReg = ptext SLIT("RetReg")
1071 pprMagicId sty SpA = ptext SLIT("SpA")
1072 pprMagicId sty SuA = ptext SLIT("SuA")
1073 pprMagicId sty SpB = ptext SLIT("SpB")
1074 pprMagicId sty SuB = ptext SLIT("SuB")
1075 pprMagicId sty Hp = ptext SLIT("Hp")
1076 pprMagicId sty HpLim = ptext SLIT("HpLim")
1077 pprMagicId sty LivenessReg = ptext SLIT("LivenessReg")
1078 pprMagicId sty StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
1079 pprMagicId sty StkStubReg = ptext SLIT("StkStubReg")
1080 pprMagicId sty CurCostCentre = ptext SLIT("CCC")
1081 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1083 pprVanillaReg :: FAST_INT -> Doc
1085 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1087 pprUnionTag :: PrimRep -> Doc
1089 pprUnionTag PtrRep = char 'p'
1090 pprUnionTag CodePtrRep = ptext SLIT("fp")
1091 pprUnionTag DataPtrRep = char 'd'
1092 pprUnionTag RetRep = char 'r'
1093 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1095 pprUnionTag CharRep = char 'c'
1096 pprUnionTag IntRep = char 'i'
1097 pprUnionTag WordRep = char 'w'
1098 pprUnionTag AddrRep = char 'v'
1099 pprUnionTag FloatRep = char 'f'
1100 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1102 pprUnionTag StablePtrRep = char 'i'
1103 pprUnionTag ForeignObjRep = char 'p'
1105 pprUnionTag ArrayRep = char 'p'
1106 pprUnionTag ByteArrayRep = char 'b'
1108 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1112 Find and print local and external declarations for a list of
1113 Abstract~C statements.
1115 pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
1116 pprTempAndExternDecls AbsCNop = (empty, empty)
1118 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1119 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1120 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1121 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1122 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1123 returnTE (vcat real_temps, vcat real_exts) }}
1126 pprTempAndExternDecls other_stmt
1127 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1138 pprBasicLit :: PprStyle -> Literal -> Doc
1139 pprPrimKind :: PprStyle -> PrimRep -> Doc
1141 pprBasicLit sty lit = text (showLiteral sty lit)
1142 pprPrimKind sty k = text (showPrimRep k)
1146 %************************************************************************
1148 \subsection[a2r-monad]{Monadery}
1150 %************************************************************************
1152 We need some monadery to keep track of temps and externs we have already
1153 printed. This info must be threaded right through the Abstract~C, so
1154 it's most convenient to hide it in this monad.
1156 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1157 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1160 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1161 emptyCLabelSet = emptyFM
1162 x `elementOfCLabelSet` labs
1163 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1164 addToCLabelSet set x = addToFM set x ()
1166 type TEenv = (UniqSet Unique, CLabelSet)
1168 type TeM result = TEenv -> (TEenv, result)
1170 initTE :: TeM a -> a
1172 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1175 {-# INLINE thenTE #-}
1176 {-# INLINE returnTE #-}
1178 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1180 = case a u of { (u_1, result_of_a) ->
1183 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1184 mapTE f [] = returnTE []
1186 = f x `thenTE` \ r ->
1187 mapTE f xs `thenTE` \ rs ->
1190 returnTE :: a -> TeM a
1191 returnTE result env = (env, result)
1193 -- these next two check whether the thing is already
1194 -- recorded, and THEN THEY RECORD IT
1195 -- (subsequent calls will return False for the same uniq/label)
1197 tempSeenTE :: Unique -> TeM Bool
1198 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1199 = if (uniq `elementOfUniqSet` seen_uniqs)
1201 else ((addOneToUniqSet seen_uniqs uniq,
1205 labelSeenTE :: CLabel -> TeM Bool
1206 labelSeenTE label env@(seen_uniqs, seen_labels)
1207 = if (label `elementOfCLabelSet` seen_labels)
1210 addToCLabelSet seen_labels label),
1215 pprTempDecl :: Unique -> PrimRep -> Doc
1216 pprTempDecl uniq kind
1217 = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
1219 pprExternDecl :: CLabel -> PrimRep -> Doc
1221 pprExternDecl clabel kind
1222 = if not (needsCDecl clabel) then
1223 empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1227 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1228 _ -> ppLocalnessMacro False{-data-} clabel
1229 ) of { pp_macro_str ->
1231 hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
1236 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
1238 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1240 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1241 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1242 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1243 returnTE (maybe_vcat [p1, p2])
1245 ppr_decls_AbsC (CClosureUpdInfo info)
1246 = ppr_decls_AbsC info
1248 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1250 ppr_decls_AbsC (CAssign dest source)
1251 = ppr_decls_Amode dest `thenTE` \ p1 ->
1252 ppr_decls_Amode source `thenTE` \ p2 ->
1253 returnTE (maybe_vcat [p1, p2])
1255 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1257 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1259 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1261 ppr_decls_AbsC (CSwitch discrim alts deflt)
1262 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1263 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1264 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1265 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1267 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1269 ppr_decls_AbsC (CCodeBlock label absC)
1270 = ppr_decls_AbsC absC
1272 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1273 -- ToDo: strictly speaking, should chk "cost_centre" amode
1274 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1279 Just (pprExternDecl info_lbl PtrRep))
1281 info_lbl = infoTableLabelFromCI cl_info
1283 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1284 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1286 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1288 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1289 -- you get some nasty re-decls of stdio.h if you compile
1290 -- the prelude while looking inside those amodes;
1291 -- no real reason to, anyway.
1292 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1294 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1295 -- ToDo: strictly speaking, should chk "cost_centre" amode
1296 = ppr_decls_Amodes amodes
1298 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1299 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1300 ppr_decls_AbsC slow `thenTE` \ p2 ->
1302 Nothing -> returnTE (Nothing, Nothing)
1303 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1304 returnTE (maybe_vcat [p1, p2, p3])
1306 entry_lbl = CLbl slow_lbl CodePtrRep
1307 slow_lbl = case (nonemptyAbsC slow) of
1308 Nothing -> mkErrorStdEntryLabel
1309 Just _ -> entryLabelFromCI cl_info
1311 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1312 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1313 ppr_decls_AbsC absC `thenTE` \ p2 ->
1314 returnTE (maybe_vcat [p1, p2])
1316 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1317 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1321 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
1322 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1323 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1324 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1325 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1326 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1327 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1328 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1330 -- CIntLike must be a literal -- no decls
1331 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1333 -- CCharLike may have be arbitrary value -- may have decls
1334 ppr_decls_Amode (CCharLike char)
1335 = ppr_decls_Amode char
1337 -- now, the only place where we actually print temps/externs...
1338 ppr_decls_Amode (CTemp uniq kind)
1340 VoidRep -> returnTE (Nothing, Nothing)
1342 tempSeenTE uniq `thenTE` \ temp_seen ->
1344 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1346 ppr_decls_Amode (CLbl label VoidRep)
1347 = returnTE (Nothing, Nothing)
1349 ppr_decls_Amode (CLbl label kind)
1350 = labelSeenTE label `thenTE` \ label_seen ->
1352 if label_seen then Nothing else Just (pprExternDecl label kind))
1355 ppr_decls_Amode (CUnVecLbl direct vectored)
1356 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1357 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1359 ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1360 vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1363 if (dlbl_seen || not (needsCDecl direct)) &&
1364 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1365 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1368 ppr_decls_Amode (CUnVecLbl direct vectored)
1369 = -- We don't mark either label as "seen", because
1370 -- we don't know which one will be used and which one tossed
1371 -- by the C macro...
1372 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1373 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1375 ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1376 vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1379 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1380 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1381 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1383 ppr_decls_Amode (CTableEntry base index _)
1384 = ppr_decls_Amode base `thenTE` \ p1 ->
1385 ppr_decls_Amode index `thenTE` \ p2 ->
1386 returnTE (maybe_vcat [p1, p2])
1388 ppr_decls_Amode (CMacroExpr _ _ amodes)
1389 = ppr_decls_Amodes amodes
1391 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1394 maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
1396 = case (unzip ps) of { (ts, es) ->
1397 case (catMaybes ts) of { real_ts ->
1398 case (catMaybes es) of { real_es ->
1399 (if (null real_ts) then Nothing else Just (vcat real_ts),
1400 if (null real_es) then Nothing else Just (vcat real_es))
1405 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
1406 ppr_decls_Amodes amodes
1407 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1408 returnTE ( maybe_vcat ps )