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 #if __GLASGOW_HASKELL__ == 201
26 IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
27 #elif __GLASGOW_HASKELL__ >= 202
28 import GlaExts (Addr(..))
33 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
34 mixedPtrLocn, mixedTypeLocn
36 import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
37 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
38 isReadOnly, needsCDecl, pprCLabel,
39 CLabel{-instance Ord-}
41 import CmdLineOpts ( opt_SccProfilingOn )
42 import CostCentre ( uppCostCentre, uppCostCentreDecl )
43 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
44 import CStrings ( stringToC )
45 import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
46 import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
47 import Literal ( showLiteral, Literal(..) )
48 import Maybes ( maybeToBool, catMaybes )
50 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
51 import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
52 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
53 isConstantRep, isSpecRep, isPhantomRep
55 import Unique ( pprUnique, Unique{-instance NamedThing-} )
56 import UniqSet ( emptyUniqSet, elementOfUniqSet,
57 addOneToUniqSet, SYN_IE(UniqSet)
59 import Outputable ( PprStyle(..), printDoc )
60 import Util ( nOfThem, panic, assertPanic )
65 For spitting out the costs of an abstract~C expression, @writeRealC@
66 now not only prints the C~code of the @absC@ arg but also adds a macro
67 call to a cost evaluation function @GRAN_EXEC@. For that,
68 @pprAbsC@ has a new ``costs'' argument. %% HWL
71 writeRealC :: Handle -> AbstractC -> IO ()
72 writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
74 dumpRealC :: AbstractC -> String
75 dumpRealC absC = show (pprAbsC PprForC absC (costs absC))
78 This emits the macro, which is used in GrAnSim to compute the total costs
79 from a cost 5 tuple. %% HWL
82 emitMacro :: CostRes -> Doc
84 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
85 emitMacro (Cost (i,b,l,s,f))
86 = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
87 int i, comma, int b, comma, int l, comma,
88 int s, comma, int f, pp_paren_semi ]
92 pp_paren_semi = text ");"
94 -- ---------------------------------------------------------------------------
95 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
96 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
97 -- which must be done before the return i.e. inside absC code) HWL
98 -- ---------------------------------------------------------------------------
100 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
102 pprAbsC sty AbsCNop _ = empty
103 pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
105 pprAbsC sty (CClosureUpdInfo info) c
108 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
110 pprAbsC sty (CJump target) c
111 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
112 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
114 pprAbsC sty (CFallThrough target) c
115 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
116 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
118 -- --------------------------------------------------------------------------
119 -- Spit out GRAN_EXEC macro immediately before the return HWL
121 pprAbsC sty (CReturn am return_info) c
122 = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
123 (hcat [text jmp_lit, target, pp_paren_semi ])
125 target = case return_info of
126 DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
127 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
128 StaticVectoredReturn n -> mk_vector (int n) -- Always positive
129 mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
131 pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
133 -- we optimise various degenerate cases of CSwitches.
135 -- --------------------------------------------------------------------------
136 -- Assume: CSwitch is also end of basic block
137 -- costs function yields nullCosts for whole switch
138 -- ==> inherited costs c are those of basic block up to switch
139 -- ==> inherit c + costs for the corresponding branch
141 -- --------------------------------------------------------------------------
143 pprAbsC sty (CSwitch discrim [] deflt) c
144 = pprAbsC sty deflt (c + costs deflt)
145 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
147 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
148 = case (nonemptyAbsC deflt) of
149 Nothing -> -- one alt and no default
150 pprAbsC sty alt_code (c + costs alt_code)
151 -- Nothing conditional in here either HWL
153 Just dc -> -- make it an "if"
154 do_if_stmt sty discrim tag alt_code dc c
156 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
157 (tag2@(MachInt i2 _), alt_code2)] deflt) c
158 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
160 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
162 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
164 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
166 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
167 | isFloatingRep (getAmodeRep discrim)
168 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
171 hcat [text "switch (", pp_discrim, text ") {"],
172 nest 2 (vcat (map (ppr_alt sty) alts)),
173 (case (nonemptyAbsC deflt) of
176 nest 2 (vcat [ptext SLIT("default:"),
177 pprAbsC sty dc (c + switch_head_cost
179 ptext SLIT("break;")])),
183 = pprAmode sty discrim
185 ppr_alt sty (lit, absC)
186 = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
187 nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC))
188 (ptext SLIT("break;"))) ]
190 -- Costs for addressing header of switch and cond. branching -- HWL
191 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
193 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
194 = pprCCall sty op args results liveness_mask vol_regs
196 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
198 non_void_args = grab_non_void_amodes args
199 non_void_results = grab_non_void_amodes results
200 -- if just one result, we print in the obvious "assignment" style;
201 -- if 0 or many results, we emit a macro call, w/ the results
202 -- followed by the arguments. The macro presumably knows which
205 the_op = ppr_op_call non_void_results non_void_args
206 -- liveness mask is *in* the non_void_args
208 case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
209 if primOpNeedsWrapper op then
218 ppr_op_call results args
219 = hcat [ pprPrimOp sty op, lparen,
220 hcat (punctuate comma (map ppr_op_result results)),
221 if null results || null args then empty else comma,
222 hcat (punctuate comma (map (pprAmode sty) args)),
225 ppr_op_result r = ppr_amode sty r
226 -- primop macros do their own casting of result;
227 -- hence we can toss the provided cast...
229 pprAbsC sty (CSimultaneous abs_c) c
230 = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
232 pprAbsC sty stmt@(CMacroStmt macro as) _
233 = hcat [text (show macro), lparen,
234 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
235 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
236 = hcat [ptext op, lparen,
237 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
238 pprAbsC sty stmt@(CCallProfCCMacro op as) _
239 = hcat [ptext op, lparen,
240 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
242 pprAbsC sty (CCodeBlock label abs_C) _
243 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
244 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
246 hcat [text (if (externallyVisibleCLabel label)
247 then "FN_(" -- abbreviations to save on output
249 pprCLabel sty label, text ") {"],
251 PprForC -> ($$) pp_exts pp_temps
253 nest 8 (ptext SLIT("FB_")),
254 nest 8 (pprAbsC sty abs_C (costs abs_C)),
255 nest 8 (ptext SLIT("FE_")),
259 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
260 = hcat [ pp_init_hdr, text "_HDR(",
261 ppr_amode sty (CAddr reg_rel), comma,
262 pprCLabel sty info_lbl, comma,
263 if_profiling sty (pprAmode sty cost_centre), comma,
264 pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ]
266 info_lbl = infoTableLabelFromCI cl_info
267 sm_rep = closureSMRep cl_info
268 size = closureSizeWithoutFixedHdr cl_info
269 ptr_wds = closurePtrsSize cl_info
271 pp_init_hdr = text (if inplace_upd then
272 getSMUpdInplaceHdrStr sm_rep
274 getSMInitHdrStr sm_rep)
276 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
277 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
283 ptext SLIT("SET_STATIC_HDR"),char '(',
284 pprCLabel sty closure_lbl, comma,
285 pprCLabel sty info_lbl, comma,
286 if_profiling sty (pprAmode sty cost_centre), comma,
287 ppLocalness closure_lbl, comma,
288 ppLocalnessMacro False{-for data-} info_lbl,
291 nest 2 (hcat (map (ppr_item sty) amodes)),
292 nest 2 (hcat (map (ppr_item sty) padding_wds)),
296 info_lbl = infoTableLabelFromCI cl_info
299 = if getAmodeRep item == VoidRep
300 then text ", (W_) 0" -- might not even need this...
301 else (<>) (text ", (W_)") (ppr_amode sty item)
304 if not (closureUpdReqd cl_info) then
307 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
308 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
311 STATIC_INIT_HDR(c,i,localness) blows into:
312 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
314 then *NO VarHdr STUFF FOR STATIC*...
316 then the amodes are dropped in...
322 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
326 ptext SLIT("_ITBL"),char '(',
327 pprCLabel sty info_lbl, comma,
329 -- CONST_ITBL needs an extra label for
330 -- the static version of the object.
331 if isConstantRep sm_rep
332 then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
335 pprCLabel sty slow_lbl, comma,
336 pprAmode sty upd, comma,
343 ppLocalness info_lbl, comma,
344 ppLocalnessMacro True{-function-} slow_lbl, comma,
347 then (<>) (int select_word_i) comma
350 if_profiling sty pp_kind, comma,
351 if_profiling sty pp_descr, comma,
352 if_profiling sty pp_type,
358 Just fast -> let stuff = CCodeBlock fast_lbl fast in
359 pprAbsC sty stuff (costs stuff)
362 info_lbl = infoTableLabelFromCI cl_info
363 fast_lbl = fastLabelFromCI cl_info
364 sm_rep = closureSMRep cl_info
367 = case (nonemptyAbsC slow) of
368 Nothing -> (mkErrorStdEntryLabel, empty)
369 Just xx -> (entryLabelFromCI cl_info,
370 let stuff = CCodeBlock slow_lbl xx in
371 pprAbsC sty stuff (costs stuff))
373 maybe_selector = maybeSelectorInfo cl_info
374 is_selector = maybeToBool maybe_selector
375 (Just (_, select_word_i)) = maybe_selector
377 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
378 = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
380 pp_tag = int (closureSemiTag cl_info)
382 is_phantom = isPhantomRep sm_rep
384 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
385 int (closureNonHdrSize cl_info)
387 else if is_phantom then -- do not have sizes for these
390 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
392 pp_ptr_wds = if is_phantom then
395 int (closurePtrsSize cl_info)
397 pp_kind = text (closureKind cl_info)
398 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
399 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
401 pprAbsC sty (CRetVector lbl maybes deflt) c
402 = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
403 nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
404 text "} /*default=*/ {", pprAbsC sty deflt c,
407 ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/")
408 ppr_maybe_amode sty (Just a) = pprAmode sty a
410 pprAbsC sty stmt@(CRetUnVector label amode) _
411 = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
412 pprAmode sty amode, rparen]
414 pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
416 pprAbsC sty stmt@(CFlatRetVector label amodes) _
417 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
422 hcat [ppLocalness label, ptext SLIT(" W_ "),
423 pprCLabel sty label, text "[] = {"],
424 nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
427 ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
429 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
436 static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
437 const = if not (isReadOnly label) then empty else ptext SLIT("const")
439 ppLocalnessMacro for_fun{-vs data-} clabel
440 = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
444 (<>) (ptext SLIT("D_"))
445 (if isReadOnly clabel then
454 grab_non_void_amodes amodes
455 = filter non_void amodes
458 = case (getAmodeRep amode) of
464 ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
466 ppr_vol_regs sty [] = (empty, empty)
467 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
468 ppr_vol_regs sty (r:rs)
469 = let pp_reg = case r of
470 VanillaReg pk n -> pprVanillaReg n
471 _ -> pprMagicId sty r
472 (more_saves, more_restores) = ppr_vol_regs sty rs
474 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
475 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
477 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
478 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
479 -- depending on the platform. (The "volatile regs" stuff handles all
480 -- other registers.) Just be *sure* BaseReg is OK before trying to do
484 ptext SLIT("CALLER_SAVE_Base"),
485 ptext SLIT("CALLER_SAVE_SpA"),
486 ptext SLIT("CALLER_SAVE_SuA"),
487 ptext SLIT("CALLER_SAVE_SpB"),
488 ptext SLIT("CALLER_SAVE_SuB"),
489 ptext SLIT("CALLER_SAVE_Ret"),
490 -- ptext SLIT("CALLER_SAVE_Activity"),
491 ptext SLIT("CALLER_SAVE_Hp"),
492 ptext SLIT("CALLER_SAVE_HpLim") ]
496 ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
497 ptext SLIT("CALLER_RESTORE_SpA"),
498 ptext SLIT("CALLER_RESTORE_SuA"),
499 ptext SLIT("CALLER_RESTORE_SpB"),
500 ptext SLIT("CALLER_RESTORE_SuB"),
501 ptext SLIT("CALLER_RESTORE_Ret"),
502 -- ptext SLIT("CALLER_RESTORE_Activity"),
503 ptext SLIT("CALLER_RESTORE_Hp"),
504 ptext SLIT("CALLER_RESTORE_HpLim"),
505 ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
506 ptext SLIT("CALLER_RESTORE_StkStub") ]
510 if_profiling sty pretty
512 PprForC -> if opt_SccProfilingOn
514 else char '0' -- leave it out!
516 _ -> {-print it anyway-} pretty
518 -- ---------------------------------------------------------------------------
519 -- Changes for GrAnSim:
520 -- draw costs for computation in head of if into both branches;
521 -- as no abstractC data structure is given for the head, one is constructed
522 -- guessing unknown values and fed into the costs function
523 -- ---------------------------------------------------------------------------
525 do_if_stmt sty discrim tag alt_code deflt c
527 -- This special case happens when testing the result of a comparison.
528 -- We can just avoid some redundant clutter in the output.
529 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
531 (addrModeCosts discrim Rhs) c
533 cond = hcat [ pprAmode sty discrim,
535 pprAmode sty (CLit tag) ]
539 (addrModeCosts discrim Rhs) c
541 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
543 hcat [text "if (", pp_pred, text ") {"],
544 nest 8 (pprAbsC sty then_part (c + discrim_costs +
545 (Cost (0, 2, 0, 0, 0)) +
547 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
548 nest 8 (pprAbsC sty else_part (c + discrim_costs +
549 (Cost (0, 1, 0, 0, 0)) +
552 {- Total costs = inherited costs (before if) + costs for accessing discrim
553 + costs for cond branch ( = (0, 1, 0, 0, 0) )
554 + costs for that alternative
558 Historical note: this used to be two separate cases -- one for `ccall'
559 and one for `casm'. To get round a potential limitation to only 10
560 arguments, the numbering of arguments in @process_casm@ was beefed up a
563 Some rough notes on generating code for @CCallOp@:
565 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
566 2) Save any essential registers (heap, stack, etc).
568 ToDo: If stable pointers are in use, these must be saved in a place
569 where the runtime system can get at them so that the Stg world can
570 be restarted during the call.
572 3) Save any temporary registers that are currently in use.
573 4) Do the call putting result into a local variable
574 5) Restore essential registers
575 6) Restore temporaries
577 (This happens after restoration of essential registers because we
578 might need the @Base@ register to access all the others correctly.)
580 {- Doesn't apply anymore with ForeignObj, structure create via primop.
581 makeForeignObj (ForeignObj is not CReturnable)
582 7) If returning Malloc Pointer, build a closure containing the
585 Otherwise, copy local variable into result register.
587 8) If ccall (not casm), declare the function being called as extern so
588 that C knows if it returns anything other than an int.
591 { ResultType _ccall_result;
594 _ccall_result = f( args );
598 return_reg = _ccall_result;
602 Amendment to the above: if we can GC, we have to:
604 * make sure we save all our registers away where the garbage collector
606 * be sure that there are no live registers or we're in trouble.
607 (This can cause problems if you try something foolish like passing
608 an array or foreign obj to a _ccall_GC_ thing.)
609 * increment/decrement the @inCCallGC@ counter before/after the call so
610 that the runtime check that PerformGC is being used sensibly will work.
613 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
614 = if (may_gc && liveness_mask /= noLiveRegsMask)
615 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
619 declare_local_vars, -- local var for *result*
620 vcat local_arg_decls,
621 -- if is_asm then empty else declareExtern,
623 process_casm local_vars pp_non_void_args casm_str,
629 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
630 (pp_save_context, pp_restore_context) =
632 then ( text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
633 text "inCCallGC--; RestoreAllStgRegs();")
634 else ( pp_basic_saves $$ pp_saves,
635 pp_basic_restores $$ pp_restores)
639 in ASSERT (all non_void nvas) nvas
640 -- the first argument will be the "I/O world" token (a VoidRep)
641 -- all others should be non-void
644 let nvrs = grab_non_void_amodes results
645 in ASSERT (length nvrs <= 1) nvrs
646 -- there will usually be two results: a (void) state which we
647 -- should ignore and a (possibly void) result.
649 (local_arg_decls, pp_non_void_args)
650 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
652 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
654 (declare_local_vars, local_vars, assign_results)
655 = ppr_casm_results sty non_void_results pp_liveness
657 casm_str = if is_asm then _UNPK_ op_str else ccall_str
659 -- Remainder only used for ccall
663 if null non_void_results
666 lparen, ptext op_str, lparen,
667 hcat (punctuate comma ccall_args),
670 num_args = length non_void_args
671 ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
674 If the argument is a heap object, we need to reach inside and pull out
675 the bit the C world wants to see. The only heap objects which can be
676 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
679 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
680 -- (a) decl and assignment, (b) local var to be used later
682 ppr_casm_arg sty amode a_num
684 a_kind = getAmodeRep amode
685 pp_amode = pprAmode sty amode
686 pp_kind = pprPrimKind sty a_kind
688 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
690 (arg_type, pp_amode2)
693 -- for array arguments, pass a pointer to the body of the array
694 -- (PTRS_ARR_CTS skips over all the header nonsense)
695 ArrayRep -> (pp_kind,
696 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
697 ByteArrayRep -> (pp_kind,
698 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
700 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
701 ForeignObjRep -> (ptext SLIT("StgForeignObj"),
702 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
704 other -> (pp_kind, pp_amode)
707 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
709 (declare_local_var, local_var)
712 For l-values, the critical questions are:
714 1) Are there any results at all?
716 We only allow zero or one results.
718 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
719 2) Is the result is a foreign obj?
721 The mallocptr must be encapsulated immediately in a heap object.
726 -> [CAddrMode] -- list of results (length <= 1)
727 -> Doc -- liveness mask
729 ( Doc, -- declaration of any local vars
730 [Doc], -- list of result vars (same length as results)
731 Doc ) -- assignment (if any) of results in local var to registers
733 ppr_casm_results sty [] liveness
734 = (empty, [], empty) -- no results
736 ppr_casm_results sty [r] liveness
738 result_reg = ppr_amode sty r
739 r_kind = getAmodeRep r
741 local_var = ptext SLIT("_ccall_result")
743 (result_type, assign_result)
746 @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
747 Instead, external references have to explicitly turned into ForeignObjs
748 using the primop makeForeignObj#. Benefit: Multiple finalisation
749 routines can be accommodated and the below special case is not needed.
750 Price is, of course, that you have to explicitly wrap `foreign objects'
751 with makeForeignObj#.
754 (ptext SLIT("StgForeignObj"),
755 hcat [ ptext SLIT("constructForeignObj"),char '(',
762 (pprPrimKind sty r_kind,
763 hcat [ result_reg, equals, local_var, semi ])
765 declare_local_var = hcat [ result_type, space, local_var, semi ]
767 (declare_local_var, [local_var], assign_result)
769 ppr_casm_results sty rs liveness
770 = panic "ppr_casm_results: ccall/casm with many results"
774 Note the sneaky way _the_ result is represented by a list so that we
775 can complain if it's used twice.
777 ToDo: Any chance of giving line numbers when process-casm fails?
778 Or maybe we should do a check _much earlier_ in compiler. ADR
782 [Doc] -- results (length <= 1)
783 -> [Doc] -- arguments
784 -> String -- format string (with embedded %'s)
786 Doc -- code being generated
788 process_casm results args string = process results args string
790 process [] _ "" = empty
791 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
793 process ress args ('%':cs)
796 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
799 (<>) (char '%') (process ress args css)
803 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
804 [r] -> (<>) r (process [] args css)
805 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
809 read_int :: ReadS Int
812 case (read_int other) of
814 if 0 <= num && num < length args
815 then (<>) (parens (args !! num))
816 (process ress args css)
817 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
818 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
820 process ress args (other_c:cs)
821 = (<>) (char other_c) (process ress args cs)
824 %************************************************************************
826 \subsection[a2r-assignments]{Assignments}
828 %************************************************************************
830 Printing assignments is a little tricky because of type coercion.
832 First of all, the kind of the thing being assigned can be gotten from
833 the destination addressing mode. (It should be the same as the kind
834 of the source addressing mode.) If the kind of the assignment is of
835 @VoidRep@, then don't generate any code at all.
838 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
840 pprAssign sty VoidRep dest src = empty
843 Special treatment for floats and doubles, to avoid unwanted conversions.
846 pprAssign sty FloatRep dest@(CVal reg_rel _) src
847 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
849 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
850 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
853 Lastly, the question is: will the C compiler think the types of the
854 two sides of the assignment match?
856 We assume that the types will match
857 if neither side is a @CVal@ addressing mode for any register
858 which can point into the heap or B stack.
860 Why? Because the heap and B stack are used to store miscellaneous things,
861 whereas the A stack, temporaries, registers, etc., are only used for things
865 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
866 = hcat [ pprVanillaReg dest, equals,
867 pprVanillaReg src, semi ]
869 pprAssign sty kind dest src
871 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
872 = hcat [ ppr_amode sty dest, equals,
873 text "(W_)(", -- Here is the cast
874 ppr_amode sty src, pp_paren_semi ]
876 pprAssign sty kind dest src
877 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
878 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
879 = hcat [ ppr_amode sty dest, equals,
880 text "(P_)(", -- Here is the cast
881 ppr_amode sty src, pp_paren_semi ]
883 pprAssign sty ByteArrayRep dest src
885 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
886 = hcat [ ppr_amode sty dest, equals,
887 text "(B_)(", -- Here is the cast
888 ppr_amode sty src, pp_paren_semi ]
890 pprAssign sty kind other_dest src
891 = hcat [ ppr_amode sty other_dest, equals,
892 pprAmode sty src, semi ]
896 %************************************************************************
898 \subsection[a2r-CAddrModes]{Addressing modes}
900 %************************************************************************
902 @pprAmode@ is used to print r-values (which may need casts), whereas
903 @ppr_amode@ is used for l-values {\em and} as a help function for
907 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
910 For reasons discussed above under assignments, @CVal@ modes need
911 to be treated carefully. First come special cases for floats and doubles,
912 similar to those in @pprAssign@:
914 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
918 pprAmode sty (CVal reg_rel FloatRep)
919 = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
920 pprAmode sty (CVal reg_rel DoubleRep)
921 = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
924 Next comes the case where there is some other cast need, and the
929 | mixedTypeLocn amode
930 = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
931 ppr_amode sty amode ])
932 | otherwise -- No cast needed
933 = ppr_amode sty amode
936 Now the rest of the cases for ``workhorse'' @ppr_amode@:
939 ppr_amode sty (CVal reg_rel _)
940 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
941 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
942 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
944 ppr_amode sty (CAddr reg_rel)
945 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
946 (pp_reg, Nothing) -> pp_reg
947 (pp_reg, Just offset) -> (<>) pp_reg offset
949 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
951 ppr_amode sty (CTemp uniq kind) = pprUnique uniq
953 ppr_amode sty (CLbl label kind) = pprCLabel sty label
955 ppr_amode sty (CUnVecLbl direct vectored)
956 = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
957 pprCLabel sty vectored, rparen]
959 ppr_amode sty (CCharLike ch)
960 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
961 ppr_amode sty (CIntLike int)
962 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ]
964 ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
965 -- ToDo: are these *used* for anything?
967 ppr_amode sty (CLit lit) = pprBasicLit sty lit
969 ppr_amode sty (CLitLit str _) = ptext str
971 ppr_amode sty (COffset off) = pprHeapOffset sty off
973 ppr_amode sty (CCode abs_C)
974 = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
976 ppr_amode sty (CLabelledCode label abs_C)
977 = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
978 nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
980 ppr_amode sty (CJoinPoint _ _)
981 = panic "ppr_amode: CJoinPoint"
983 ppr_amode sty (CTableEntry base index kind)
984 = hcat [text "((", pprPrimKind sty kind, text " *)(",
985 ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
988 ppr_amode sty (CMacroExpr pk macro as)
989 = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
990 hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
992 ppr_amode sty (CCostCentre cc print_as_string)
993 = uppCostCentre sty print_as_string cc
996 %************************************************************************
998 \subsection[a2r-MagicIds]{Magic ids}
1000 %************************************************************************
1002 @pprRegRelative@ returns a pair of the @Doc@ for the register
1003 (some casting may be required), and a @Maybe Doc@ for the offset
1004 (zero offset gives a @Nothing@).
1007 addPlusSign :: Bool -> Doc -> Doc
1008 addPlusSign False p = p
1009 addPlusSign True p = (<>) (char '+') p
1011 pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0
1012 pprSignedInt sign_wanted n
1013 = if n == 0 then Nothing else
1014 if n > 0 then Just (addPlusSign sign_wanted (int n))
1017 pprRegRelative :: PprStyle
1018 -> Bool -- True <=> Print leading plus sign (if +ve)
1022 pprRegRelative sty sign_wanted (SpARel spA off)
1023 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1025 pprRegRelative sty sign_wanted (SpBRel spB off)
1026 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1028 pprRegRelative sty sign_wanted r@(HpRel hp off)
1029 = let to_print = hp `subOff` off
1030 pp_Hp = pprMagicId sty Hp
1032 if isZeroOff to_print then
1035 (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print)))
1036 -- No parens needed because pprHeapOffset
1037 -- does them when necessary
1039 pprRegRelative sty sign_wanted (NodeRel off)
1040 = let pp_Node = pprMagicId sty node
1042 if isZeroOff off then
1045 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1049 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1050 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1051 to select the union tag.
1054 pprMagicId :: PprStyle -> MagicId -> Doc
1056 pprMagicId sty BaseReg = ptext SLIT("BaseReg")
1057 pprMagicId sty StkOReg = ptext SLIT("StkOReg")
1058 pprMagicId sty (VanillaReg pk n)
1059 = hcat [ pprVanillaReg n, char '.',
1061 pprMagicId sty (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1062 pprMagicId sty (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1063 pprMagicId sty TagReg = ptext SLIT("TagReg")
1064 pprMagicId sty RetReg = ptext SLIT("RetReg")
1065 pprMagicId sty SpA = ptext SLIT("SpA")
1066 pprMagicId sty SuA = ptext SLIT("SuA")
1067 pprMagicId sty SpB = ptext SLIT("SpB")
1068 pprMagicId sty SuB = ptext SLIT("SuB")
1069 pprMagicId sty Hp = ptext SLIT("Hp")
1070 pprMagicId sty HpLim = ptext SLIT("HpLim")
1071 pprMagicId sty LivenessReg = ptext SLIT("LivenessReg")
1072 pprMagicId sty StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
1073 pprMagicId sty StkStubReg = ptext SLIT("StkStubReg")
1074 pprMagicId sty CurCostCentre = ptext SLIT("CCC")
1075 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1077 pprVanillaReg :: FAST_INT -> Doc
1079 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1081 pprUnionTag :: PrimRep -> Doc
1083 pprUnionTag PtrRep = char 'p'
1084 pprUnionTag CodePtrRep = ptext SLIT("fp")
1085 pprUnionTag DataPtrRep = char 'd'
1086 pprUnionTag RetRep = char 'r'
1087 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1089 pprUnionTag CharRep = char 'c'
1090 pprUnionTag IntRep = char 'i'
1091 pprUnionTag WordRep = char 'w'
1092 pprUnionTag AddrRep = char 'v'
1093 pprUnionTag FloatRep = char 'f'
1094 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1096 pprUnionTag StablePtrRep = char 'i'
1097 pprUnionTag ForeignObjRep = char 'p'
1099 pprUnionTag ArrayRep = char 'p'
1100 pprUnionTag ByteArrayRep = char 'b'
1102 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1106 Find and print local and external declarations for a list of
1107 Abstract~C statements.
1109 pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
1110 pprTempAndExternDecls AbsCNop = (empty, empty)
1112 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1113 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1114 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1115 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1116 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1117 returnTE (vcat real_temps, vcat real_exts) }}
1120 pprTempAndExternDecls other_stmt
1121 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1132 pprBasicLit :: PprStyle -> Literal -> Doc
1133 pprPrimKind :: PprStyle -> PrimRep -> Doc
1135 pprBasicLit sty lit = text (showLiteral sty lit)
1136 pprPrimKind sty k = text (showPrimRep k)
1140 %************************************************************************
1142 \subsection[a2r-monad]{Monadery}
1144 %************************************************************************
1146 We need some monadery to keep track of temps and externs we have already
1147 printed. This info must be threaded right through the Abstract~C, so
1148 it's most convenient to hide it in this monad.
1150 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1151 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1154 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1155 emptyCLabelSet = emptyFM
1156 x `elementOfCLabelSet` labs
1157 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1158 addToCLabelSet set x = addToFM set x ()
1160 type TEenv = (UniqSet Unique, CLabelSet)
1162 type TeM result = TEenv -> (TEenv, result)
1164 initTE :: TeM a -> a
1166 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1169 {-# INLINE thenTE #-}
1170 {-# INLINE returnTE #-}
1172 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1174 = case a u of { (u_1, result_of_a) ->
1177 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1178 mapTE f [] = returnTE []
1180 = f x `thenTE` \ r ->
1181 mapTE f xs `thenTE` \ rs ->
1184 returnTE :: a -> TeM a
1185 returnTE result env = (env, result)
1187 -- these next two check whether the thing is already
1188 -- recorded, and THEN THEY RECORD IT
1189 -- (subsequent calls will return False for the same uniq/label)
1191 tempSeenTE :: Unique -> TeM Bool
1192 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1193 = if (uniq `elementOfUniqSet` seen_uniqs)
1195 else ((addOneToUniqSet seen_uniqs uniq,
1199 labelSeenTE :: CLabel -> TeM Bool
1200 labelSeenTE label env@(seen_uniqs, seen_labels)
1201 = if (label `elementOfCLabelSet` seen_labels)
1204 addToCLabelSet seen_labels label),
1209 pprTempDecl :: Unique -> PrimRep -> Doc
1210 pprTempDecl uniq kind
1211 = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
1213 pprExternDecl :: CLabel -> PrimRep -> Doc
1215 pprExternDecl clabel kind
1216 = if not (needsCDecl clabel) then
1217 empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1221 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1222 _ -> ppLocalnessMacro False{-data-} clabel
1223 ) of { pp_macro_str ->
1225 hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
1230 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
1232 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1234 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1235 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1236 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1237 returnTE (maybe_vcat [p1, p2])
1239 ppr_decls_AbsC (CClosureUpdInfo info)
1240 = ppr_decls_AbsC info
1242 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1244 ppr_decls_AbsC (CAssign dest source)
1245 = ppr_decls_Amode dest `thenTE` \ p1 ->
1246 ppr_decls_Amode source `thenTE` \ p2 ->
1247 returnTE (maybe_vcat [p1, p2])
1249 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1251 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1253 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1255 ppr_decls_AbsC (CSwitch discrim alts deflt)
1256 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1257 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1258 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1259 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1261 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1263 ppr_decls_AbsC (CCodeBlock label absC)
1264 = ppr_decls_AbsC absC
1266 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1267 -- ToDo: strictly speaking, should chk "cost_centre" amode
1268 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1273 Just (pprExternDecl info_lbl PtrRep))
1275 info_lbl = infoTableLabelFromCI cl_info
1277 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1278 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1280 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1282 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1283 -- you get some nasty re-decls of stdio.h if you compile
1284 -- the prelude while looking inside those amodes;
1285 -- no real reason to, anyway.
1286 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1288 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1289 -- ToDo: strictly speaking, should chk "cost_centre" amode
1290 = ppr_decls_Amodes amodes
1292 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1293 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1294 ppr_decls_AbsC slow `thenTE` \ p2 ->
1296 Nothing -> returnTE (Nothing, Nothing)
1297 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1298 returnTE (maybe_vcat [p1, p2, p3])
1300 entry_lbl = CLbl slow_lbl CodePtrRep
1301 slow_lbl = case (nonemptyAbsC slow) of
1302 Nothing -> mkErrorStdEntryLabel
1303 Just _ -> entryLabelFromCI cl_info
1305 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1306 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1307 ppr_decls_AbsC absC `thenTE` \ p2 ->
1308 returnTE (maybe_vcat [p1, p2])
1310 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1311 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1315 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
1316 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1317 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1318 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1319 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1320 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1321 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1322 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1324 -- CIntLike must be a literal -- no decls
1325 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1327 -- CCharLike may have be arbitrary value -- may have decls
1328 ppr_decls_Amode (CCharLike char)
1329 = ppr_decls_Amode char
1331 -- now, the only place where we actually print temps/externs...
1332 ppr_decls_Amode (CTemp uniq kind)
1334 VoidRep -> returnTE (Nothing, Nothing)
1336 tempSeenTE uniq `thenTE` \ temp_seen ->
1338 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1340 ppr_decls_Amode (CLbl label VoidRep)
1341 = returnTE (Nothing, Nothing)
1343 ppr_decls_Amode (CLbl label kind)
1344 = labelSeenTE label `thenTE` \ label_seen ->
1346 if label_seen then Nothing else Just (pprExternDecl label kind))
1349 ppr_decls_Amode (CUnVecLbl direct vectored)
1350 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1351 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1353 ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1354 vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1357 if (dlbl_seen || not (needsCDecl direct)) &&
1358 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1359 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1362 ppr_decls_Amode (CUnVecLbl direct vectored)
1363 = -- We don't mark either label as "seen", because
1364 -- we don't know which one will be used and which one tossed
1365 -- by the C macro...
1366 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1367 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1369 ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1370 vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1373 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1374 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1375 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1377 ppr_decls_Amode (CTableEntry base index _)
1378 = ppr_decls_Amode base `thenTE` \ p1 ->
1379 ppr_decls_Amode index `thenTE` \ p2 ->
1380 returnTE (maybe_vcat [p1, p2])
1382 ppr_decls_Amode (CMacroExpr _ _ amodes)
1383 = ppr_decls_Amodes amodes
1385 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1388 maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
1390 = case (unzip ps) of { (ts, es) ->
1391 case (catMaybes ts) of { real_ts ->
1392 case (catMaybes es) of { real_es ->
1393 (if (null real_ts) then Nothing else Just (vcat real_ts),
1394 if (null real_es) then Nothing else Just (vcat real_es))
1399 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
1400 ppr_decls_Amodes amodes
1401 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1402 returnTE ( maybe_vcat ps )