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 )
49 import PprStyle ( PprStyle(..) )
51 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
52 import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
53 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
54 isConstantRep, isSpecRep, isPhantomRep
56 import Unique ( pprUnique, Unique{-instance NamedThing-} )
57 import UniqSet ( emptyUniqSet, elementOfUniqSet,
58 addOneToUniqSet, SYN_IE(UniqSet)
60 import Outputable ( printDoc )
61 import Util ( nOfThem, panic, assertPanic )
66 For spitting out the costs of an abstract~C expression, @writeRealC@
67 now not only prints the C~code of the @absC@ arg but also adds a macro
68 call to a cost evaluation function @GRAN_EXEC@. For that,
69 @pprAbsC@ has a new ``costs'' argument. %% HWL
72 writeRealC :: Handle -> AbstractC -> IO ()
73 writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
75 dumpRealC :: AbstractC -> String
76 dumpRealC absC = show (pprAbsC PprForC absC (costs absC))
79 This emits the macro, which is used in GrAnSim to compute the total costs
80 from a cost 5 tuple. %% HWL
83 emitMacro :: CostRes -> Doc
85 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
86 emitMacro (Cost (i,b,l,s,f))
87 = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
88 int i, comma, int b, comma, int l, comma,
89 int s, comma, int f, pp_paren_semi ]
93 pp_paren_semi = text ");"
95 -- ---------------------------------------------------------------------------
96 -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
97 -- code as an argument (that's needed when spitting out the GRAN_EXEC macro
98 -- which must be done before the return i.e. inside absC code) HWL
99 -- ---------------------------------------------------------------------------
101 pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
103 pprAbsC sty AbsCNop _ = empty
104 pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
106 pprAbsC sty (CClosureUpdInfo info) c
109 pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
111 pprAbsC sty (CJump target) c
112 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
113 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
115 pprAbsC sty (CFallThrough target) c
116 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
117 (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
119 -- --------------------------------------------------------------------------
120 -- Spit out GRAN_EXEC macro immediately before the return HWL
122 pprAbsC sty (CReturn am return_info) c
123 = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
124 (hcat [text jmp_lit, target, pp_paren_semi ])
126 target = case return_info of
127 DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
128 DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
129 StaticVectoredReturn n -> mk_vector (int n) -- Always positive
130 mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
132 pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
134 -- we optimise various degenerate cases of CSwitches.
136 -- --------------------------------------------------------------------------
137 -- Assume: CSwitch is also end of basic block
138 -- costs function yields nullCosts for whole switch
139 -- ==> inherited costs c are those of basic block up to switch
140 -- ==> inherit c + costs for the corresponding branch
142 -- --------------------------------------------------------------------------
144 pprAbsC sty (CSwitch discrim [] deflt) c
145 = pprAbsC sty deflt (c + costs deflt)
146 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
148 pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
149 = case (nonemptyAbsC deflt) of
150 Nothing -> -- one alt and no default
151 pprAbsC sty alt_code (c + costs alt_code)
152 -- Nothing conditional in here either HWL
154 Just dc -> -- make it an "if"
155 do_if_stmt sty discrim tag alt_code dc c
157 pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
158 (tag2@(MachInt i2 _), alt_code2)] deflt) c
159 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
161 do_if_stmt sty discrim tag1 alt_code1 alt_code2 c
163 do_if_stmt sty discrim tag2 alt_code2 alt_code1 c
165 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
167 pprAbsC sty (CSwitch discrim alts deflt) c -- general case
168 | isFloatingRep (getAmodeRep discrim)
169 = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
172 hcat [text "switch (", pp_discrim, text ") {"],
173 nest 2 (vcat (map (ppr_alt sty) alts)),
174 (case (nonemptyAbsC deflt) of
177 nest 2 (vcat [ptext SLIT("default:"),
178 pprAbsC sty dc (c + switch_head_cost
180 ptext SLIT("break;")])),
184 = pprAmode sty discrim
186 ppr_alt sty (lit, absC)
187 = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
188 nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC))
189 (ptext SLIT("break;"))) ]
191 -- Costs for addressing header of switch and cond. branching -- HWL
192 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
194 pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _
195 = pprCCall sty op args results liveness_mask vol_regs
197 pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
199 non_void_args = grab_non_void_amodes args
200 non_void_results = grab_non_void_amodes results
201 -- if just one result, we print in the obvious "assignment" style;
202 -- if 0 or many results, we emit a macro call, w/ the results
203 -- followed by the arguments. The macro presumably knows which
206 the_op = ppr_op_call non_void_results non_void_args
207 -- liveness mask is *in* the non_void_args
209 case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
210 if primOpNeedsWrapper op then
219 ppr_op_call results args
220 = hcat [ pprPrimOp sty op, lparen,
221 hcat (punctuate comma (map ppr_op_result results)),
222 if null results || null args then empty else comma,
223 hcat (punctuate comma (map (pprAmode sty) args)),
226 ppr_op_result r = ppr_amode sty r
227 -- primop macros do their own casting of result;
228 -- hence we can toss the provided cast...
230 pprAbsC sty (CSimultaneous abs_c) c
231 = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
233 pprAbsC sty stmt@(CMacroStmt macro as) _
234 = hcat [text (show macro), lparen,
235 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
236 pprAbsC sty stmt@(CCallProfCtrMacro op as) _
237 = hcat [ptext op, lparen,
238 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
239 pprAbsC sty stmt@(CCallProfCCMacro op as) _
240 = hcat [ptext op, lparen,
241 hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
243 pprAbsC sty (CCodeBlock label abs_C) _
244 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
245 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
247 hcat [text (if (externallyVisibleCLabel label)
248 then "FN_(" -- abbreviations to save on output
250 pprCLabel sty label, text ") {"],
252 PprForC -> ($$) pp_exts pp_temps
254 nest 8 (ptext SLIT("FB_")),
255 nest 8 (pprAbsC sty abs_C (costs abs_C)),
256 nest 8 (ptext SLIT("FE_")),
260 pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
261 = hcat [ pp_init_hdr, text "_HDR(",
262 ppr_amode sty (CAddr reg_rel), comma,
263 pprCLabel sty info_lbl, comma,
264 if_profiling sty (pprAmode sty cost_centre), comma,
265 pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ]
267 info_lbl = infoTableLabelFromCI cl_info
268 sm_rep = closureSMRep cl_info
269 size = closureSizeWithoutFixedHdr cl_info
270 ptr_wds = closurePtrsSize cl_info
272 pp_init_hdr = text (if inplace_upd then
273 getSMUpdInplaceHdrStr sm_rep
275 getSMInitHdrStr sm_rep)
277 pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
278 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
284 ptext SLIT("SET_STATIC_HDR"),char '(',
285 pprCLabel sty closure_lbl, comma,
286 pprCLabel sty info_lbl, comma,
287 if_profiling sty (pprAmode sty cost_centre), comma,
288 ppLocalness closure_lbl, comma,
289 ppLocalnessMacro False{-for data-} info_lbl,
292 nest 2 (hcat (map (ppr_item sty) amodes)),
293 nest 2 (hcat (map (ppr_item sty) padding_wds)),
297 info_lbl = infoTableLabelFromCI cl_info
300 = if getAmodeRep item == VoidRep
301 then text ", (W_) 0" -- might not even need this...
302 else (<>) (text ", (W_)") (ppr_amode sty item)
305 if not (closureUpdReqd cl_info) then
308 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
309 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
312 STATIC_INIT_HDR(c,i,localness) blows into:
313 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
315 then *NO VarHdr STUFF FOR STATIC*...
317 then the amodes are dropped in...
323 pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
327 ptext SLIT("_ITBL"),char '(',
328 pprCLabel sty info_lbl, comma,
330 -- CONST_ITBL needs an extra label for
331 -- the static version of the object.
332 if isConstantRep sm_rep
333 then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
336 pprCLabel sty slow_lbl, comma,
337 pprAmode sty upd, comma,
344 ppLocalness info_lbl, comma,
345 ppLocalnessMacro True{-function-} slow_lbl, comma,
348 then (<>) (int select_word_i) comma
351 if_profiling sty pp_kind, comma,
352 if_profiling sty pp_descr, comma,
353 if_profiling sty pp_type,
359 Just fast -> let stuff = CCodeBlock fast_lbl fast in
360 pprAbsC sty stuff (costs stuff)
363 info_lbl = infoTableLabelFromCI cl_info
364 fast_lbl = fastLabelFromCI cl_info
365 sm_rep = closureSMRep cl_info
368 = case (nonemptyAbsC slow) of
369 Nothing -> (mkErrorStdEntryLabel, empty)
370 Just xx -> (entryLabelFromCI cl_info,
371 let stuff = CCodeBlock slow_lbl xx in
372 pprAbsC sty stuff (costs stuff))
374 maybe_selector = maybeSelectorInfo cl_info
375 is_selector = maybeToBool maybe_selector
376 (Just (_, select_word_i)) = maybe_selector
378 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
379 = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
381 pp_tag = int (closureSemiTag cl_info)
383 is_phantom = isPhantomRep sm_rep
385 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
386 int (closureNonHdrSize cl_info)
388 else if is_phantom then -- do not have sizes for these
391 pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
393 pp_ptr_wds = if is_phantom then
396 int (closurePtrsSize cl_info)
398 pp_kind = text (closureKind cl_info)
399 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
400 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
402 pprAbsC sty (CRetVector lbl maybes deflt) c
403 = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
404 nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
405 text "} /*default=*/ {", pprAbsC sty deflt c,
408 ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/")
409 ppr_maybe_amode sty (Just a) = pprAmode sty a
411 pprAbsC sty stmt@(CRetUnVector label amode) _
412 = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
413 pprAmode sty amode, rparen]
415 pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
417 pprAbsC sty stmt@(CFlatRetVector label amodes) _
418 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
423 hcat [ppLocalness label, ptext SLIT(" W_ "),
424 pprCLabel sty label, text "[] = {"],
425 nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
428 ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
430 pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
437 static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
438 const = if not (isReadOnly label) then empty else ptext SLIT("const")
440 ppLocalnessMacro for_fun{-vs data-} clabel
441 = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
445 (<>) (ptext SLIT("D_"))
446 (if isReadOnly clabel then
455 grab_non_void_amodes amodes
456 = filter non_void amodes
459 = case (getAmodeRep amode) of
465 ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
467 ppr_vol_regs sty [] = (empty, empty)
468 ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
469 ppr_vol_regs sty (r:rs)
470 = let pp_reg = case r of
471 VanillaReg pk n -> pprVanillaReg n
472 _ -> pprMagicId sty r
473 (more_saves, more_restores) = ppr_vol_regs sty rs
475 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
476 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
478 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
479 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
480 -- depending on the platform. (The "volatile regs" stuff handles all
481 -- other registers.) Just be *sure* BaseReg is OK before trying to do
485 ptext SLIT("CALLER_SAVE_Base"),
486 ptext SLIT("CALLER_SAVE_SpA"),
487 ptext SLIT("CALLER_SAVE_SuA"),
488 ptext SLIT("CALLER_SAVE_SpB"),
489 ptext SLIT("CALLER_SAVE_SuB"),
490 ptext SLIT("CALLER_SAVE_Ret"),
491 -- ptext SLIT("CALLER_SAVE_Activity"),
492 ptext SLIT("CALLER_SAVE_Hp"),
493 ptext SLIT("CALLER_SAVE_HpLim") ]
497 ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
498 ptext SLIT("CALLER_RESTORE_SpA"),
499 ptext SLIT("CALLER_RESTORE_SuA"),
500 ptext SLIT("CALLER_RESTORE_SpB"),
501 ptext SLIT("CALLER_RESTORE_SuB"),
502 ptext SLIT("CALLER_RESTORE_Ret"),
503 -- ptext SLIT("CALLER_RESTORE_Activity"),
504 ptext SLIT("CALLER_RESTORE_Hp"),
505 ptext SLIT("CALLER_RESTORE_HpLim"),
506 ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
507 ptext SLIT("CALLER_RESTORE_StkStub") ]
511 if_profiling sty pretty
513 PprForC -> if opt_SccProfilingOn
515 else char '0' -- leave it out!
517 _ -> {-print it anyway-} pretty
519 -- ---------------------------------------------------------------------------
520 -- Changes for GrAnSim:
521 -- draw costs for computation in head of if into both branches;
522 -- as no abstractC data structure is given for the head, one is constructed
523 -- guessing unknown values and fed into the costs function
524 -- ---------------------------------------------------------------------------
526 do_if_stmt sty discrim tag alt_code deflt c
528 -- This special case happens when testing the result of a comparison.
529 -- We can just avoid some redundant clutter in the output.
530 MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
532 (addrModeCosts discrim Rhs) c
534 cond = hcat [ pprAmode sty discrim,
536 pprAmode sty (CLit tag) ]
540 (addrModeCosts discrim Rhs) c
542 ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
544 hcat [text "if (", pp_pred, text ") {"],
545 nest 8 (pprAbsC sty then_part (c + discrim_costs +
546 (Cost (0, 2, 0, 0, 0)) +
548 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
549 nest 8 (pprAbsC sty else_part (c + discrim_costs +
550 (Cost (0, 1, 0, 0, 0)) +
553 {- Total costs = inherited costs (before if) + costs for accessing discrim
554 + costs for cond branch ( = (0, 1, 0, 0, 0) )
555 + costs for that alternative
559 Historical note: this used to be two separate cases -- one for `ccall'
560 and one for `casm'. To get round a potential limitation to only 10
561 arguments, the numbering of arguments in @process_casm@ was beefed up a
564 Some rough notes on generating code for @CCallOp@:
566 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
567 2) Save any essential registers (heap, stack, etc).
569 ToDo: If stable pointers are in use, these must be saved in a place
570 where the runtime system can get at them so that the Stg world can
571 be restarted during the call.
573 3) Save any temporary registers that are currently in use.
574 4) Do the call putting result into a local variable
575 5) Restore essential registers
576 6) Restore temporaries
578 (This happens after restoration of essential registers because we
579 might need the @Base@ register to access all the others correctly.)
581 {- Doesn't apply anymore with ForeignObj, structure create via primop.
582 makeForeignObj (ForeignObj is not CReturnable)
583 7) If returning Malloc Pointer, build a closure containing the
586 Otherwise, copy local variable into result register.
588 8) If ccall (not casm), declare the function being called as extern so
589 that C knows if it returns anything other than an int.
592 { ResultType _ccall_result;
595 _ccall_result = f( args );
599 return_reg = _ccall_result;
603 Amendment to the above: if we can GC, we have to:
605 * make sure we save all our registers away where the garbage collector
607 * be sure that there are no live registers or we're in trouble.
608 (This can cause problems if you try something foolish like passing
609 an array or foreign obj to a _ccall_GC_ thing.)
610 * increment/decrement the @inCCallGC@ counter before/after the call so
611 that the runtime check that PerformGC is being used sensibly will work.
614 pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs
615 = if (may_gc && liveness_mask /= noLiveRegsMask)
616 then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
620 declare_local_vars, -- local var for *result*
621 vcat local_arg_decls,
622 -- if is_asm then empty else declareExtern,
624 process_casm local_vars pp_non_void_args casm_str,
630 (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
631 (pp_save_context, pp_restore_context) =
633 then ( text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
634 text "inCCallGC--; RestoreAllStgRegs();")
635 else ( pp_basic_saves $$ pp_saves,
636 pp_basic_restores $$ pp_restores)
640 in ASSERT (all non_void nvas) nvas
641 -- the first argument will be the "I/O world" token (a VoidRep)
642 -- all others should be non-void
645 let nvrs = grab_non_void_amodes results
646 in ASSERT (length nvrs <= 1) nvrs
647 -- there will usually be two results: a (void) state which we
648 -- should ignore and a (possibly void) result.
650 (local_arg_decls, pp_non_void_args)
651 = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ]
653 pp_liveness = pprAmode sty (mkIntCLit liveness_mask)
655 (declare_local_vars, local_vars, assign_results)
656 = ppr_casm_results sty non_void_results pp_liveness
658 casm_str = if is_asm then _UNPK_ op_str else ccall_str
660 -- Remainder only used for ccall
664 if null non_void_results
667 lparen, ptext op_str, lparen,
668 hcat (punctuate comma ccall_args),
671 num_args = length non_void_args
672 ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
675 If the argument is a heap object, we need to reach inside and pull out
676 the bit the C world wants to see. The only heap objects which can be
677 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
680 ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
681 -- (a) decl and assignment, (b) local var to be used later
683 ppr_casm_arg sty amode a_num
685 a_kind = getAmodeRep amode
686 pp_amode = pprAmode sty amode
687 pp_kind = pprPrimKind sty a_kind
689 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
691 (arg_type, pp_amode2)
694 -- for array arguments, pass a pointer to the body of the array
695 -- (PTRS_ARR_CTS skips over all the header nonsense)
696 ArrayRep -> (pp_kind,
697 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
698 ByteArrayRep -> (pp_kind,
699 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
701 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
702 ForeignObjRep -> (ptext SLIT("StgForeignObj"),
703 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
705 other -> (pp_kind, pp_amode)
708 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
710 (declare_local_var, local_var)
713 For l-values, the critical questions are:
715 1) Are there any results at all?
717 We only allow zero or one results.
719 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
720 2) Is the result is a foreign obj?
722 The mallocptr must be encapsulated immediately in a heap object.
727 -> [CAddrMode] -- list of results (length <= 1)
728 -> Doc -- liveness mask
730 ( Doc, -- declaration of any local vars
731 [Doc], -- list of result vars (same length as results)
732 Doc ) -- assignment (if any) of results in local var to registers
734 ppr_casm_results sty [] liveness
735 = (empty, [], empty) -- no results
737 ppr_casm_results sty [r] liveness
739 result_reg = ppr_amode sty r
740 r_kind = getAmodeRep r
742 local_var = ptext SLIT("_ccall_result")
744 (result_type, assign_result)
747 @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
748 Instead, external references have to explicitly turned into ForeignObjs
749 using the primop makeForeignObj#. Benefit: Multiple finalisation
750 routines can be accommodated and the below special case is not needed.
751 Price is, of course, that you have to explicitly wrap `foreign objects'
752 with makeForeignObj#.
755 (ptext SLIT("StgForeignObj"),
756 hcat [ ptext SLIT("constructForeignObj"),char '(',
763 (pprPrimKind sty r_kind,
764 hcat [ result_reg, equals, local_var, semi ])
766 declare_local_var = hcat [ result_type, space, local_var, semi ]
768 (declare_local_var, [local_var], assign_result)
770 ppr_casm_results sty rs liveness
771 = panic "ppr_casm_results: ccall/casm with many results"
775 Note the sneaky way _the_ result is represented by a list so that we
776 can complain if it's used twice.
778 ToDo: Any chance of giving line numbers when process-casm fails?
779 Or maybe we should do a check _much earlier_ in compiler. ADR
783 [Doc] -- results (length <= 1)
784 -> [Doc] -- arguments
785 -> String -- format string (with embedded %'s)
787 Doc -- code being generated
789 process_casm results args string = process results args string
791 process [] _ "" = empty
792 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
794 process ress args ('%':cs)
797 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
800 (<>) (char '%') (process ress args css)
804 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
805 [r] -> (<>) r (process [] args css)
806 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
810 read_int :: ReadS Int
813 case (read_int other) of
815 if 0 <= num && num < length args
816 then (<>) (parens (args !! num))
817 (process ress args css)
818 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
819 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
821 process ress args (other_c:cs)
822 = (<>) (char other_c) (process ress args cs)
825 %************************************************************************
827 \subsection[a2r-assignments]{Assignments}
829 %************************************************************************
831 Printing assignments is a little tricky because of type coercion.
833 First of all, the kind of the thing being assigned can be gotten from
834 the destination addressing mode. (It should be the same as the kind
835 of the source addressing mode.) If the kind of the assignment is of
836 @VoidRep@, then don't generate any code at all.
839 pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
841 pprAssign sty VoidRep dest src = empty
844 Special treatment for floats and doubles, to avoid unwanted conversions.
847 pprAssign sty FloatRep dest@(CVal reg_rel _) src
848 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
850 pprAssign sty DoubleRep dest@(CVal reg_rel _) src
851 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
854 Lastly, the question is: will the C compiler think the types of the
855 two sides of the assignment match?
857 We assume that the types will match
858 if neither side is a @CVal@ addressing mode for any register
859 which can point into the heap or B stack.
861 Why? Because the heap and B stack are used to store miscellaneous things,
862 whereas the A stack, temporaries, registers, etc., are only used for things
866 pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
867 = hcat [ pprVanillaReg dest, equals,
868 pprVanillaReg src, semi ]
870 pprAssign sty kind dest src
872 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
873 = hcat [ ppr_amode sty dest, equals,
874 text "(W_)(", -- Here is the cast
875 ppr_amode sty src, pp_paren_semi ]
877 pprAssign sty kind dest src
878 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
879 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
880 = hcat [ ppr_amode sty dest, equals,
881 text "(P_)(", -- Here is the cast
882 ppr_amode sty src, pp_paren_semi ]
884 pprAssign sty ByteArrayRep dest src
886 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
887 = hcat [ ppr_amode sty dest, equals,
888 text "(B_)(", -- Here is the cast
889 ppr_amode sty src, pp_paren_semi ]
891 pprAssign sty kind other_dest src
892 = hcat [ ppr_amode sty other_dest, equals,
893 pprAmode sty src, semi ]
897 %************************************************************************
899 \subsection[a2r-CAddrModes]{Addressing modes}
901 %************************************************************************
903 @pprAmode@ is used to print r-values (which may need casts), whereas
904 @ppr_amode@ is used for l-values {\em and} as a help function for
908 pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
911 For reasons discussed above under assignments, @CVal@ modes need
912 to be treated carefully. First come special cases for floats and doubles,
913 similar to those in @pprAssign@:
915 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
919 pprAmode sty (CVal reg_rel FloatRep)
920 = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
921 pprAmode sty (CVal reg_rel DoubleRep)
922 = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
925 Next comes the case where there is some other cast need, and the
930 | mixedTypeLocn amode
931 = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
932 ppr_amode sty amode ])
933 | otherwise -- No cast needed
934 = ppr_amode sty amode
937 Now the rest of the cases for ``workhorse'' @ppr_amode@:
940 ppr_amode sty (CVal reg_rel _)
941 = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
942 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
943 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
945 ppr_amode sty (CAddr reg_rel)
946 = case (pprRegRelative sty True{-sign wanted-} reg_rel) of
947 (pp_reg, Nothing) -> pp_reg
948 (pp_reg, Just offset) -> (<>) pp_reg offset
950 ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
952 ppr_amode sty (CTemp uniq kind) = pprUnique uniq
954 ppr_amode sty (CLbl label kind) = pprCLabel sty label
956 ppr_amode sty (CUnVecLbl direct vectored)
957 = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
958 pprCLabel sty vectored, rparen]
960 ppr_amode sty (CCharLike ch)
961 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
962 ppr_amode sty (CIntLike int)
963 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ]
965 ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
966 -- ToDo: are these *used* for anything?
968 ppr_amode sty (CLit lit) = pprBasicLit sty lit
970 ppr_amode sty (CLitLit str _) = ptext str
972 ppr_amode sty (COffset off) = pprHeapOffset sty off
974 ppr_amode sty (CCode abs_C)
975 = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
977 ppr_amode sty (CLabelledCode label abs_C)
978 = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
979 nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
981 ppr_amode sty (CJoinPoint _ _)
982 = panic "ppr_amode: CJoinPoint"
984 ppr_amode sty (CTableEntry base index kind)
985 = hcat [text "((", pprPrimKind sty kind, text " *)(",
986 ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
989 ppr_amode sty (CMacroExpr pk macro as)
990 = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
991 hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
993 ppr_amode sty (CCostCentre cc print_as_string)
994 = uppCostCentre sty print_as_string cc
997 %************************************************************************
999 \subsection[a2r-MagicIds]{Magic ids}
1001 %************************************************************************
1003 @pprRegRelative@ returns a pair of the @Doc@ for the register
1004 (some casting may be required), and a @Maybe Doc@ for the offset
1005 (zero offset gives a @Nothing@).
1008 addPlusSign :: Bool -> Doc -> Doc
1009 addPlusSign False p = p
1010 addPlusSign True p = (<>) (char '+') p
1012 pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0
1013 pprSignedInt sign_wanted n
1014 = if n == 0 then Nothing else
1015 if n > 0 then Just (addPlusSign sign_wanted (int n))
1018 pprRegRelative :: PprStyle
1019 -> Bool -- True <=> Print leading plus sign (if +ve)
1023 pprRegRelative sty sign_wanted (SpARel spA off)
1024 = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1026 pprRegRelative sty sign_wanted (SpBRel spB off)
1027 = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1029 pprRegRelative sty sign_wanted r@(HpRel hp off)
1030 = let to_print = hp `subOff` off
1031 pp_Hp = pprMagicId sty Hp
1033 if isZeroOff to_print then
1036 (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print)))
1037 -- No parens needed because pprHeapOffset
1038 -- does them when necessary
1040 pprRegRelative sty sign_wanted (NodeRel off)
1041 = let pp_Node = pprMagicId sty node
1043 if isZeroOff off then
1046 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off)))
1050 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1051 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1052 to select the union tag.
1055 pprMagicId :: PprStyle -> MagicId -> Doc
1057 pprMagicId sty BaseReg = ptext SLIT("BaseReg")
1058 pprMagicId sty StkOReg = ptext SLIT("StkOReg")
1059 pprMagicId sty (VanillaReg pk n)
1060 = hcat [ pprVanillaReg n, char '.',
1062 pprMagicId sty (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1063 pprMagicId sty (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1064 pprMagicId sty TagReg = ptext SLIT("TagReg")
1065 pprMagicId sty RetReg = ptext SLIT("RetReg")
1066 pprMagicId sty SpA = ptext SLIT("SpA")
1067 pprMagicId sty SuA = ptext SLIT("SuA")
1068 pprMagicId sty SpB = ptext SLIT("SpB")
1069 pprMagicId sty SuB = ptext SLIT("SuB")
1070 pprMagicId sty Hp = ptext SLIT("Hp")
1071 pprMagicId sty HpLim = ptext SLIT("HpLim")
1072 pprMagicId sty LivenessReg = ptext SLIT("LivenessReg")
1073 pprMagicId sty StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
1074 pprMagicId sty StkStubReg = ptext SLIT("StkStubReg")
1075 pprMagicId sty CurCostCentre = ptext SLIT("CCC")
1076 pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
1078 pprVanillaReg :: FAST_INT -> Doc
1080 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1082 pprUnionTag :: PrimRep -> Doc
1084 pprUnionTag PtrRep = char 'p'
1085 pprUnionTag CodePtrRep = ptext SLIT("fp")
1086 pprUnionTag DataPtrRep = char 'd'
1087 pprUnionTag RetRep = char 'r'
1088 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1090 pprUnionTag CharRep = char 'c'
1091 pprUnionTag IntRep = char 'i'
1092 pprUnionTag WordRep = char 'w'
1093 pprUnionTag AddrRep = char 'v'
1094 pprUnionTag FloatRep = char 'f'
1095 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1097 pprUnionTag StablePtrRep = char 'i'
1098 pprUnionTag ForeignObjRep = char 'p'
1100 pprUnionTag ArrayRep = char 'p'
1101 pprUnionTag ByteArrayRep = char 'b'
1103 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1107 Find and print local and external declarations for a list of
1108 Abstract~C statements.
1110 pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
1111 pprTempAndExternDecls AbsCNop = (empty, empty)
1113 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1114 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1115 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1116 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1117 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1118 returnTE (vcat real_temps, vcat real_exts) }}
1121 pprTempAndExternDecls other_stmt
1122 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1133 pprBasicLit :: PprStyle -> Literal -> Doc
1134 pprPrimKind :: PprStyle -> PrimRep -> Doc
1136 pprBasicLit sty lit = text (showLiteral sty lit)
1137 pprPrimKind sty k = text (showPrimRep k)
1141 %************************************************************************
1143 \subsection[a2r-monad]{Monadery}
1145 %************************************************************************
1147 We need some monadery to keep track of temps and externs we have already
1148 printed. This info must be threaded right through the Abstract~C, so
1149 it's most convenient to hide it in this monad.
1151 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1152 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1155 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1156 emptyCLabelSet = emptyFM
1157 x `elementOfCLabelSet` labs
1158 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1159 addToCLabelSet set x = addToFM set x ()
1161 type TEenv = (UniqSet Unique, CLabelSet)
1163 type TeM result = TEenv -> (TEenv, result)
1165 initTE :: TeM a -> a
1167 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1170 {-# INLINE thenTE #-}
1171 {-# INLINE returnTE #-}
1173 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1175 = case a u of { (u_1, result_of_a) ->
1178 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1179 mapTE f [] = returnTE []
1181 = f x `thenTE` \ r ->
1182 mapTE f xs `thenTE` \ rs ->
1185 returnTE :: a -> TeM a
1186 returnTE result env = (env, result)
1188 -- these next two check whether the thing is already
1189 -- recorded, and THEN THEY RECORD IT
1190 -- (subsequent calls will return False for the same uniq/label)
1192 tempSeenTE :: Unique -> TeM Bool
1193 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1194 = if (uniq `elementOfUniqSet` seen_uniqs)
1196 else ((addOneToUniqSet seen_uniqs uniq,
1200 labelSeenTE :: CLabel -> TeM Bool
1201 labelSeenTE label env@(seen_uniqs, seen_labels)
1202 = if (label `elementOfCLabelSet` seen_labels)
1205 addToCLabelSet seen_labels label),
1210 pprTempDecl :: Unique -> PrimRep -> Doc
1211 pprTempDecl uniq kind
1212 = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
1214 pprExternDecl :: CLabel -> PrimRep -> Doc
1216 pprExternDecl clabel kind
1217 = if not (needsCDecl clabel) then
1218 empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1222 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1223 _ -> ppLocalnessMacro False{-data-} clabel
1224 ) of { pp_macro_str ->
1226 hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
1231 ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
1233 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1235 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1236 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1237 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1238 returnTE (maybe_vcat [p1, p2])
1240 ppr_decls_AbsC (CClosureUpdInfo info)
1241 = ppr_decls_AbsC info
1243 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1245 ppr_decls_AbsC (CAssign dest source)
1246 = ppr_decls_Amode dest `thenTE` \ p1 ->
1247 ppr_decls_Amode source `thenTE` \ p2 ->
1248 returnTE (maybe_vcat [p1, p2])
1250 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1252 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1254 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1256 ppr_decls_AbsC (CSwitch discrim alts deflt)
1257 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1258 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1259 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1260 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1262 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1264 ppr_decls_AbsC (CCodeBlock label absC)
1265 = ppr_decls_AbsC absC
1267 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1268 -- ToDo: strictly speaking, should chk "cost_centre" amode
1269 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1274 Just (pprExternDecl info_lbl PtrRep))
1276 info_lbl = infoTableLabelFromCI cl_info
1278 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1279 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1281 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1283 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1284 -- you get some nasty re-decls of stdio.h if you compile
1285 -- the prelude while looking inside those amodes;
1286 -- no real reason to, anyway.
1287 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1289 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1290 -- ToDo: strictly speaking, should chk "cost_centre" amode
1291 = ppr_decls_Amodes amodes
1293 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1294 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1295 ppr_decls_AbsC slow `thenTE` \ p2 ->
1297 Nothing -> returnTE (Nothing, Nothing)
1298 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1299 returnTE (maybe_vcat [p1, p2, p3])
1301 entry_lbl = CLbl slow_lbl CodePtrRep
1302 slow_lbl = case (nonemptyAbsC slow) of
1303 Nothing -> mkErrorStdEntryLabel
1304 Just _ -> entryLabelFromCI cl_info
1306 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1307 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1308 ppr_decls_AbsC absC `thenTE` \ p2 ->
1309 returnTE (maybe_vcat [p1, p2])
1311 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1312 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1316 ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
1317 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1318 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1319 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1320 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1321 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1322 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1323 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1325 -- CIntLike must be a literal -- no decls
1326 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1328 -- CCharLike may have be arbitrary value -- may have decls
1329 ppr_decls_Amode (CCharLike char)
1330 = ppr_decls_Amode char
1332 -- now, the only place where we actually print temps/externs...
1333 ppr_decls_Amode (CTemp uniq kind)
1335 VoidRep -> returnTE (Nothing, Nothing)
1337 tempSeenTE uniq `thenTE` \ temp_seen ->
1339 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1341 ppr_decls_Amode (CLbl label VoidRep)
1342 = returnTE (Nothing, Nothing)
1344 ppr_decls_Amode (CLbl label kind)
1345 = labelSeenTE label `thenTE` \ label_seen ->
1347 if label_seen then Nothing else Just (pprExternDecl label kind))
1350 ppr_decls_Amode (CUnVecLbl direct vectored)
1351 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1352 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1354 ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1355 vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1358 if (dlbl_seen || not (needsCDecl direct)) &&
1359 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1360 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1363 ppr_decls_Amode (CUnVecLbl direct vectored)
1364 = -- We don't mark either label as "seen", because
1365 -- we don't know which one will be used and which one tossed
1366 -- by the C macro...
1367 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1368 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1370 ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1371 vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1374 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1375 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1376 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1378 ppr_decls_Amode (CTableEntry base index _)
1379 = ppr_decls_Amode base `thenTE` \ p1 ->
1380 ppr_decls_Amode index `thenTE` \ p2 ->
1381 returnTE (maybe_vcat [p1, p2])
1383 ppr_decls_Amode (CMacroExpr _ _ amodes)
1384 = ppr_decls_Amodes amodes
1386 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1389 maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
1391 = case (unzip ps) of { (ts, es) ->
1392 case (catMaybes ts) of { real_ts ->
1393 case (catMaybes es) of { real_es ->
1394 (if (null real_ts) then Nothing else Just (vcat real_ts),
1395 if (null real_es) then Nothing else Just (vcat real_es))
1400 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
1401 ppr_decls_Amodes amodes
1402 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1403 returnTE ( maybe_vcat ps )