2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[PprAbsC]{Pretty-printing Abstract~C}
8 %************************************************************************
15 , pprAmode -- otherwise, not exported
19 #include "HsVersions.h"
25 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
26 mixedPtrLocn, mixedTypeLocn
28 import CallConv ( CallConv, callConvAttribute, cCallConv )
29 import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
30 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
31 isReadOnly, needsCDecl, pprCLabel,
32 CLabel{-instance Ord-}
34 import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
35 import CostCentre ( uppCostCentre, uppCostCentreDecl )
36 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
37 import CStrings ( stringToC )
38 import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
39 import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
40 import Literal ( showLiteral, Literal(..) )
41 import Maybes ( maybeToBool, catMaybes )
42 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
43 import PrimRep ( isFloatingRep, PrimRep(..), showPrimRep )
44 import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
45 isConstantRep, isSpecRep, isPhantomRep
47 import Unique ( pprUnique, Unique{-instance NamedThing-} )
48 import UniqSet ( emptyUniqSet, elementOfUniqSet,
49 addOneToUniqSet, UniqSet
52 import Util ( nOfThem, panic, assertPanic )
57 For spitting out the costs of an abstract~C expression, @writeRealC@
58 now not only prints the C~code of the @absC@ arg but also adds a macro
59 call to a cost evaluation function @GRAN_EXEC@. For that,
60 @pprAbsC@ has a new ``costs'' argument. %% HWL
63 writeRealC :: Handle -> AbstractC -> SDoc -> IO ()
64 --writeRealC handle absC postlude =
66 -- printDoc LeftMode handle (pprAbsC absC (costs absC))
67 writeRealC handle absC postlude =
69 printForC handle (pprAbsC absC (costs absC) $$ postlude)
71 dumpRealC :: AbstractC -> SDoc -> SDoc
72 dumpRealC absC postlude
73 | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC) $$ postlude)
74 | otherwise = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude)
77 This emits the macro, which is used in GrAnSim to compute the total costs
78 from a cost 5 tuple. %% HWL
81 emitMacro :: CostRes -> SDoc
83 -- ToDo: Check a compile time flag to decide whether a macro should be emitted
84 emitMacro (Cost (i,b,l,s,f))
85 = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
86 int i, comma, int b, comma, int l, comma,
87 int s, comma, int f, pp_paren_semi ]
89 pp_paren_semi = text ");"
92 New type: Now pprAbsC also takes the costs for evaluating the Abstract C
93 code as an argument (that's needed when spitting out the GRAN_EXEC macro
94 which must be done before the return i.e. inside absC code) HWL
97 pprAbsC :: AbstractC -> CostRes -> SDoc
98 pprAbsC AbsCNop _ = empty
99 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
101 pprAbsC (CClosureUpdInfo info) c
104 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
105 pprAbsC (CJump target) c
106 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
107 (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
109 pprAbsC (CFallThrough target) c
110 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
111 (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
113 -- --------------------------------------------------------------------------
114 -- Spit out GRAN_EXEC macro immediately before the return HWL
116 pprAbsC (CReturn am return_info) c
117 = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
118 (hcat [text jmp_lit, target, pp_paren_semi ])
120 target = case return_info of
121 DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen]
122 DynamicVectoredReturn am' -> mk_vector (pprAmode am')
123 StaticVectoredReturn n -> mk_vector (int n) -- Always positive
124 mk_vector x = hcat [parens (pprAmode am), brackets (text "RVREL" <> parens x)]
126 pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
128 -- we optimise various degenerate cases of CSwitches.
130 -- --------------------------------------------------------------------------
131 -- Assume: CSwitch is also end of basic block
132 -- costs function yields nullCosts for whole switch
133 -- ==> inherited costs c are those of basic block up to switch
134 -- ==> inherit c + costs for the corresponding branch
136 -- --------------------------------------------------------------------------
138 pprAbsC (CSwitch discrim [] deflt) c
139 = pprAbsC deflt (c + costs deflt)
140 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
142 pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
143 = case (nonemptyAbsC deflt) of
144 Nothing -> -- one alt and no default
145 pprAbsC alt_code (c + costs alt_code)
146 -- Nothing conditional in here either HWL
148 Just dc -> -- make it an "if"
149 do_if_stmt discrim tag alt_code dc c
151 pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
152 (tag2@(MachInt i2 _), alt_code2)] deflt) c
153 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
155 do_if_stmt discrim tag1 alt_code1 alt_code2 c
157 do_if_stmt discrim tag2 alt_code2 alt_code1 c
159 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
161 pprAbsC (CSwitch discrim alts deflt) c -- general case
162 | isFloatingRep (getAmodeRep discrim)
163 = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
166 hcat [text "switch (", pp_discrim, text ") {"],
167 nest 2 (vcat (map ppr_alt alts)),
168 (case (nonemptyAbsC deflt) of
171 nest 2 (vcat [ptext SLIT("default:"),
172 pprAbsC dc (c + switch_head_cost
174 ptext SLIT("break;")])),
181 = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
182 nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
183 (ptext SLIT("break;"))) ]
185 -- Costs for addressing header of switch and cond. branching -- HWL
186 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
188 pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _ _) args liveness_mask vol_regs) _
189 = pprCCall op args results liveness_mask vol_regs
191 pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
193 non_void_args = grab_non_void_amodes args
194 non_void_results = grab_non_void_amodes results
195 -- if just one result, we print in the obvious "assignment" style;
196 -- if 0 or many results, we emit a macro call, w/ the results
197 -- followed by the arguments. The macro presumably knows which
200 the_op = ppr_op_call non_void_results non_void_args
201 -- liveness mask is *in* the non_void_args
203 case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
204 if primOpNeedsWrapper op then
213 ppr_op_call results args
214 = hcat [ pprPrimOp op, lparen,
215 hcat (punctuate comma (map ppr_op_result results)),
216 if null results || null args then empty else comma,
217 hcat (punctuate comma (map pprAmode args)),
220 ppr_op_result r = ppr_amode r
221 -- primop macros do their own casting of result;
222 -- hence we can toss the provided cast...
224 pprAbsC (CSimultaneous abs_c) c
225 = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
227 pprAbsC stmt@(CMacroStmt macro as) _
228 = hcat [text (show macro), lparen,
229 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
230 pprAbsC stmt@(CCallProfCtrMacro op as) _
231 = hcat [ptext op, lparen,
232 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
233 pprAbsC stmt@(CCallProfCCMacro op as) _
234 = hcat [ptext op, lparen,
235 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
236 pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results args) _
237 = hsep [ ptext SLIT("typedef")
240 , parens (hsep (punctuate comma ccall_decl_ty_args))
243 fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
247 Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
250 case non_void_results of
251 [] -> ptext SLIT("void")
252 [amode] -> text (showPrimRep (getAmodeRep amode))
253 _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
255 ccall_decl_ty_args = tail ccall_arg_tys
256 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
258 -- the first argument will be the "I/O world" token (a VoidRep)
259 -- all others should be non-void
262 in ASSERT (all non_void nvas) nvas
264 -- there will usually be two results: a (void) state which we
265 -- should ignore and a (possibly void) result.
267 let nvrs = grab_non_void_amodes results
268 in ASSERT (length nvrs <= 1) nvrs
270 pprAbsC (CCodeBlock label abs_C) _
271 = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
272 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
274 hcat [text (if (externallyVisibleCLabel label)
275 then "FN_(" -- abbreviations to save on output
277 pprCLabel label, text ") {"],
281 nest 8 (ptext SLIT("FB_")),
282 nest 8 (pprAbsC abs_C (costs abs_C)),
283 nest 8 (ptext SLIT("FE_")),
287 pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
288 = hcat [ pp_init_hdr, text "_HDR(",
289 ppr_amode (CAddr reg_rel), comma,
290 pprCLabel info_lbl, comma,
291 if_profiling (pprAmode cost_centre), comma,
292 pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
294 info_lbl = infoTableLabelFromCI cl_info
295 sm_rep = closureSMRep cl_info
296 size = closureSizeWithoutFixedHdr cl_info
297 ptr_wds = closurePtrsSize cl_info
299 pp_init_hdr = text (if inplace_upd then
300 getSMUpdInplaceHdrStr sm_rep
302 getSMInitHdrStr sm_rep)
304 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
305 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
309 ptext SLIT("SET_STATIC_HDR"),char '(',
310 pprCLabel closure_lbl, comma,
311 pprCLabel info_lbl, comma,
312 if_profiling (pprAmode cost_centre), comma,
313 ppLocalness closure_lbl, comma,
314 ppLocalnessMacro False{-for data-} info_lbl,
317 nest 2 (hcat (map ppr_item amodes)),
318 nest 2 (hcat (map ppr_item padding_wds)),
322 info_lbl = infoTableLabelFromCI cl_info
325 = if getAmodeRep item == VoidRep
326 then text ", (W_) 0" -- might not even need this...
327 else (<>) (text ", (W_)") (ppr_amode item)
330 if not (closureUpdReqd cl_info) then
333 case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
334 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
337 STATIC_INIT_HDR(c,i,localness) blows into:
338 localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
340 then *NO VarHdr STUFF FOR STATIC*...
342 then the amodes are dropped in...
348 pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
352 ptext SLIT("_ITBL"),char '(',
353 pprCLabel info_lbl, comma,
355 -- CONST_ITBL needs an extra label for
356 -- the static version of the object.
357 if isConstantRep sm_rep
358 then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma
361 pprCLabel slow_lbl, comma,
369 ppLocalness info_lbl, comma,
370 ppLocalnessMacro True{-function-} slow_lbl, comma,
373 then (<>) (int select_word_i) comma
376 if_profiling pp_kind, comma,
377 if_profiling pp_descr, comma,
378 if_profiling pp_type,
384 Just fast -> let stuff = CCodeBlock fast_lbl fast in
385 pprAbsC stuff (costs stuff)
388 info_lbl = infoTableLabelFromCI cl_info
389 fast_lbl = fastLabelFromCI cl_info
390 sm_rep = closureSMRep cl_info
393 = case (nonemptyAbsC slow) of
394 Nothing -> (mkErrorStdEntryLabel, empty)
395 Just xx -> (entryLabelFromCI cl_info,
396 let stuff = CCodeBlock slow_lbl xx in
397 pprAbsC stuff (costs stuff))
399 maybe_selector = maybeSelectorInfo cl_info
400 is_selector = maybeToBool maybe_selector
401 (Just (_, select_word_i)) = maybe_selector
403 pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
404 = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
406 pp_tag = int (closureSemiTag cl_info)
408 is_phantom = isPhantomRep sm_rep
410 pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
411 int (closureNonHdrSize cl_info)
413 else if is_phantom then -- do not have sizes for these
416 pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
418 pp_ptr_wds = if is_phantom then
421 int (closurePtrsSize cl_info)
423 pp_kind = text (closureKind cl_info)
424 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
425 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
427 pprAbsC (CRetVector lbl maybes deflt) c
428 = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
429 nest 8 (sep (map ppr_maybe_amode maybes)),
430 text "} /*default=*/ {", pprAbsC deflt c,
433 ppr_maybe_amode Nothing = ptext SLIT("/*default*/")
434 ppr_maybe_amode (Just a) = pprAmode a
436 pprAbsC stmt@(CRetUnVector label amode) _
437 = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
438 pprAmode amode, rparen]
440 pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
442 pprAbsC stmt@(CFlatRetVector label amodes) _
443 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
446 hcat [ppLocalness label, ptext SLIT(" W_ "),
447 pprCLabel label, text "[] = {"],
448 nest 2 (sep (punctuate comma (map ppr_item amodes))),
451 ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
453 pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
460 static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
461 const = if not (isReadOnly label) then empty else ptext SLIT("const")
463 ppLocalnessMacro for_fun{-vs data-} clabel
464 = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
468 (<>) (ptext SLIT("D_"))
469 (if isReadOnly clabel then
478 grab_non_void_amodes amodes
479 = filter non_void amodes
482 = case (getAmodeRep amode) of
488 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
490 ppr_vol_regs [] = (empty, empty)
491 ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
493 = let pp_reg = case r of
494 VanillaReg pk n -> pprVanillaReg n
496 (more_saves, more_restores) = ppr_vol_regs rs
498 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
499 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
501 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
502 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
503 -- depending on the platform. (The "volatile regs" stuff handles all
504 -- other registers.) Just be *sure* BaseReg is OK before trying to do
508 ptext SLIT("CALLER_SAVE_Base"),
509 ptext SLIT("CALLER_SAVE_SpA"),
510 ptext SLIT("CALLER_SAVE_SuA"),
511 ptext SLIT("CALLER_SAVE_SpB"),
512 ptext SLIT("CALLER_SAVE_SuB"),
513 ptext SLIT("CALLER_SAVE_Ret"),
514 -- ptext SLIT("CALLER_SAVE_Activity"),
515 ptext SLIT("CALLER_SAVE_Hp"),
516 ptext SLIT("CALLER_SAVE_HpLim") ]
520 ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
521 ptext SLIT("CALLER_RESTORE_SpA"),
522 ptext SLIT("CALLER_RESTORE_SuA"),
523 ptext SLIT("CALLER_RESTORE_SpB"),
524 ptext SLIT("CALLER_RESTORE_SuB"),
525 ptext SLIT("CALLER_RESTORE_Ret"),
526 -- ptext SLIT("CALLER_RESTORE_Activity"),
527 ptext SLIT("CALLER_RESTORE_Hp"),
528 ptext SLIT("CALLER_RESTORE_HpLim"),
529 ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
530 ptext SLIT("CALLER_RESTORE_StkStub") ]
535 = if opt_SccProfilingOn
537 else char '0' -- leave it out!
538 -- ---------------------------------------------------------------------------
539 -- Changes for GrAnSim:
540 -- draw costs for computation in head of if into both branches;
541 -- as no abstractC data structure is given for the head, one is constructed
542 -- guessing unknown values and fed into the costs function
543 -- ---------------------------------------------------------------------------
545 do_if_stmt discrim tag alt_code deflt c
547 -- This special case happens when testing the result of a comparison.
548 -- We can just avoid some redundant clutter in the output.
549 MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
551 (addrModeCosts discrim Rhs) c
553 cond = hcat [ pprAmode discrim,
555 pprAmode (CLit tag) ]
559 (addrModeCosts discrim Rhs) c
561 ppr_if_stmt pp_pred then_part else_part discrim_costs c
563 hcat [text "if (", pp_pred, text ") {"],
564 nest 8 (pprAbsC then_part (c + discrim_costs +
565 (Cost (0, 2, 0, 0, 0)) +
567 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
568 nest 8 (pprAbsC else_part (c + discrim_costs +
569 (Cost (0, 1, 0, 0, 0)) +
572 {- Total costs = inherited costs (before if) + costs for accessing discrim
573 + costs for cond branch ( = (0, 1, 0, 0, 0) )
574 + costs for that alternative
578 Historical note: this used to be two separate cases -- one for `ccall'
579 and one for `casm'. To get round a potential limitation to only 10
580 arguments, the numbering of arguments in @process_casm@ was beefed up a
583 Some rough notes on generating code for @CCallOp@:
585 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
586 2) Save any essential registers (heap, stack, etc).
588 ToDo: If stable pointers are in use, these must be saved in a place
589 where the runtime system can get at them so that the Stg world can
590 be restarted during the call.
592 3) Save any temporary registers that are currently in use.
593 4) Do the call, putting result into a local variable
594 5) Restore essential registers
595 6) Restore temporaries
597 (This happens after restoration of essential registers because we
598 might need the @Base@ register to access all the others correctly.)
600 {- Doesn't apply anymore with ForeignObj, structure created via the primop.
601 makeForeignObj (i.e., ForeignObj is not CReturnable)
602 7) If returning Malloc Pointer, build a closure containing the
605 Otherwise, copy local variable into result register.
607 8) If ccall (not casm), declare the function being called as extern so
608 that C knows if it returns anything other than an int.
611 { ResultType _ccall_result;
614 _ccall_result = f( args );
618 return_reg = _ccall_result;
622 Amendment to the above: if we can GC, we have to:
624 * make sure we save all our registers away where the garbage collector
626 * be sure that there are no live registers or we're in trouble.
627 (This can cause problems if you try something foolish like passing
628 an array or foreign obj to a _ccall_GC_ thing.)
629 * increment/decrement the @inCCallGC@ counter before/after the call so
630 that the runtime check that PerformGC is being used sensibly will work.
633 pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask vol_regs
634 = if (may_gc && liveness_mask /= noLiveRegsMask)
635 then pprPanic "Live register in _casm_GC_ "
636 (doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
640 declare_local_vars, -- local var for *result*
641 vcat local_arg_decls,
643 declare_fun_extern, -- declare expected function type.
644 process_casm local_vars pp_non_void_args casm_str,
650 (pp_saves, pp_restores) = ppr_vol_regs vol_regs
652 (pp_save_context, pp_restore_context)
654 ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;"
655 , text "inCCallGC--; RestoreAllStgRegs();} while(0);"
658 ( pp_basic_saves $$ pp_saves
659 , pp_basic_restores $$ pp_restores
664 in ASSERT (all non_void nvas) nvas
665 -- the first argument will be the "I/O world" token (a VoidRep)
666 -- all others should be non-void
669 let nvrs = grab_non_void_amodes results
670 in ASSERT (length nvrs <= 1) nvrs
671 -- there will usually be two results: a (void) state which we
672 -- should ignore and a (possibly void) result.
674 (local_arg_decls, pp_non_void_args)
675 = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
677 pp_liveness = pprAmode (mkIntCLit liveness_mask)
680 In the non-casm case, to ensure that we're entering the given external
681 entry point using the correct calling convention, we have to do the following:
683 - When entering via a function pointer (the `dynamic' case) using the specified
684 calling convention, we emit a typedefn declaration attributed with the
685 calling convention to use together with the result and parameter types we're
686 assuming. Coerce the function pointer to this type and go.
688 - to enter the function at a given code label, we emit an extern declaration
689 for the label here, stating the calling convention together with result and
690 argument types we're assuming.
692 The C compiler will hopefully use this extern declaration to good effect,
693 reporting any discrepancies between our extern decl and any other that
696 Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
697 the external function `foo' use the calling convention of the first `foo'
698 prototype it encounters (nor does it complain about conflicting attribute
699 declarations). The consequence of this is that you cannot override the
700 calling convention of `foo' using an extern declaration (you'd have to use
701 a typedef), but why you would want to do such a thing in the first place
702 is totally beyond me.
704 ToDo: petition the gcc folks to add code to warn about conflicting attribute
709 | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
711 hsep [ typedef_or_extern
714 , parens (hsep (punctuate comma ccall_decl_ty_args))
718 | is_dynamic = ptext SLIT("typedef")
719 | otherwise = ptext SLIT("extern")
722 | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
723 | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
725 -- leave out function pointer
727 | is_dynamic = tail ccall_arg_tys
728 | otherwise = ccall_arg_tys
730 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
733 case non_void_results of
734 [] -> ptext SLIT("void")
735 [amode] -> text (showPrimRep (getAmodeRep amode))
736 _ -> panic "pprCCall: ccall_res_ty"
739 ptext SLIT("_ccall_fun_ty") <>
744 (declare_local_vars, local_vars, assign_results)
745 = ppr_casm_results non_void_results pp_liveness
747 (Left asm_str) = op_str
753 casm_str = if is_asm then _UNPK_ asm_str else ccall_str
755 -- Remainder only used for ccall
758 | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
759 | otherwise = ptext asm_str
763 if null non_void_results
766 lparen, fun_name, lparen,
767 hcat (punctuate comma ccall_fun_args),
772 | is_dynamic = tail ccall_args
773 | otherwise = ccall_args
775 ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
779 If the argument is a heap object, we need to reach inside and pull out
780 the bit the C world wants to see. The only heap objects which can be
781 passed are @Array@s, @ByteArray@s and @ForeignObj@s.
784 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
785 -- (a) decl and assignment, (b) local var to be used later
787 ppr_casm_arg amode a_num
789 a_kind = getAmodeRep amode
790 pp_amode = pprAmode amode
791 pp_kind = pprPrimKind a_kind
793 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
795 (arg_type, pp_amode2)
798 -- for array arguments, pass a pointer to the body of the array
799 -- (PTRS_ARR_CTS skips over all the header nonsense)
800 ArrayRep -> (pp_kind,
801 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
802 ByteArrayRep -> (pp_kind,
803 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
805 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
806 ForeignObjRep -> (ptext SLIT("StgForeignObj"),
807 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
809 other -> (pp_kind, pp_amode)
812 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
814 (declare_local_var, local_var)
817 For l-values, the critical questions are:
819 1) Are there any results at all?
821 We only allow zero or one results.
823 {- With the introduction of ForeignObj (MallocPtr++), no longer necess.
824 2) Is the result is a foreign obj?
826 The mallocptr must be encapsulated immediately in a heap object.
830 :: [CAddrMode] -- list of results (length <= 1)
831 -> SDoc -- liveness mask
833 ( SDoc, -- declaration of any local vars
834 [SDoc], -- list of result vars (same length as results)
835 SDoc ) -- assignment (if any) of results in local var to registers
837 ppr_casm_results [] liveness
838 = (empty, [], empty) -- no results
840 ppr_casm_results [r] liveness
842 result_reg = ppr_amode r
843 r_kind = getAmodeRep r
845 local_var = ptext SLIT("_ccall_result")
847 (result_type, assign_result)
850 @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
851 Instead, external references have to explicitly turned into ForeignObjs
852 using the primop makeForeignObj#. Benefit: Multiple finalisation
853 routines can be accommodated and the below special case is not needed.
854 Price is, of course, that you have to explicitly wrap `foreign objects'
855 with makeForeignObj#.
858 (ptext SLIT("StgForeignObj"),
859 hcat [ ptext SLIT("constructForeignObj"),char '(',
867 hcat [ result_reg, equals, local_var, semi ])
869 declare_local_var = hcat [ result_type, space, local_var, semi ]
871 (declare_local_var, [local_var], assign_result)
873 ppr_casm_results rs liveness
874 = panic "ppr_casm_results: ccall/casm with many results"
878 Note the sneaky way _the_ result is represented by a list so that we
879 can complain if it's used twice.
881 ToDo: Any chance of giving line numbers when process-casm fails?
882 Or maybe we should do a check _much earlier_ in compiler. ADR
885 process_casm :: [SDoc] -- results (length <= 1)
886 -> [SDoc] -- arguments
887 -> String -- format string (with embedded %'s)
888 -> SDoc -- code being generated
890 process_casm results args string = process results args string
892 process [] _ "" = empty
893 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
895 process ress args ('%':cs)
898 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
901 (<>) (char '%') (process ress args css)
905 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
906 [r] -> (<>) r (process [] args css)
907 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
911 read_int :: ReadS Int
914 case (read_int other) of
916 if 0 <= num && num < length args
917 then (<>) (parens (args !! num))
918 (process ress args css)
919 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
920 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
922 process ress args (other_c:cs)
923 = (<>) (char other_c) (process ress args cs)
926 %************************************************************************
928 \subsection[a2r-assignments]{Assignments}
930 %************************************************************************
932 Printing assignments is a little tricky because of type coercion.
934 First of all, the kind of the thing being assigned can be gotten from
935 the destination addressing mode. (It should be the same as the kind
936 of the source addressing mode.) If the kind of the assignment is of
937 @VoidRep@, then don't generate any code at all.
940 pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
942 pprAssign VoidRep dest src = empty
945 Special treatment for floats and doubles, to avoid unwanted conversions.
948 pprAssign FloatRep dest@(CVal reg_rel _) src
949 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
951 pprAssign DoubleRep dest@(CVal reg_rel _) src
952 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
954 pprAssign Int64Rep dest@(CVal reg_rel _) src
955 = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
956 pprAssign Word64Rep dest@(CVal reg_rel _) src
957 = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
960 Lastly, the question is: will the C compiler think the types of the
961 two sides of the assignment match?
963 We assume that the types will match
964 if neither side is a @CVal@ addressing mode for any register
965 which can point into the heap or B stack.
967 Why? Because the heap and B stack are used to store miscellaneous things,
968 whereas the A stack, temporaries, registers, etc., are only used for things
972 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
973 = hcat [ pprVanillaReg dest, equals,
974 pprVanillaReg src, semi ]
976 pprAssign kind dest src
978 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
979 = hcat [ ppr_amode dest, equals,
980 text "(W_)(", -- Here is the cast
981 ppr_amode src, pp_paren_semi ]
983 pprAssign kind dest src
984 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
985 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
986 = hcat [ ppr_amode dest, equals,
987 text "(P_)(", -- Here is the cast
988 ppr_amode src, pp_paren_semi ]
990 pprAssign ByteArrayRep dest src
992 -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
993 = hcat [ ppr_amode dest, equals,
994 text "(B_)(", -- Here is the cast
995 ppr_amode src, pp_paren_semi ]
997 pprAssign kind other_dest src
998 = hcat [ ppr_amode other_dest, equals,
1003 %************************************************************************
1005 \subsection[a2r-CAddrModes]{Addressing modes}
1007 %************************************************************************
1009 @pprAmode@ is used to print r-values (which may need casts), whereas
1010 @ppr_amode@ is used for l-values {\em and} as a help function for
1014 pprAmode, ppr_amode :: CAddrMode -> SDoc
1017 For reasons discussed above under assignments, @CVal@ modes need
1018 to be treated carefully. First come special cases for floats and doubles,
1019 similar to those in @pprAssign@:
1021 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
1025 pprAmode (CVal reg_rel FloatRep)
1026 = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
1027 pprAmode (CVal reg_rel DoubleRep)
1028 = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
1029 pprAmode (CVal reg_rel Int64Rep)
1030 = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
1031 pprAmode (CVal reg_rel Word64Rep)
1032 = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
1035 Next comes the case where there is some other cast need, and the
1040 | mixedTypeLocn amode
1041 = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
1043 | otherwise -- No cast needed
1047 Now the rest of the cases for ``workhorse'' @ppr_amode@:
1050 ppr_amode (CVal reg_rel _)
1051 = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1052 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
1053 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
1055 ppr_amode (CAddr reg_rel)
1056 = case (pprRegRelative True{-sign wanted-} reg_rel) of
1057 (pp_reg, Nothing) -> pp_reg
1058 (pp_reg, Just offset) -> (<>) pp_reg offset
1060 ppr_amode (CReg magic_id) = pprMagicId magic_id
1062 ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_'
1064 ppr_amode (CLbl label kind) = pprCLabel label
1066 ppr_amode (CUnVecLbl direct vectored)
1067 = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma,
1068 pprCLabel vectored, rparen]
1070 ppr_amode (CCharLike ch)
1071 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
1072 ppr_amode (CIntLike int)
1073 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
1075 ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
1076 -- ToDo: are these *used* for anything?
1078 ppr_amode (CLit lit) = pprBasicLit lit
1080 ppr_amode (CLitLit str _) = ptext str
1082 ppr_amode (COffset off) = pprHeapOffset off
1084 ppr_amode (CCode abs_C)
1085 = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
1087 ppr_amode (CLabelledCode label abs_C)
1088 = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")],
1089 nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
1091 ppr_amode (CJoinPoint _ _)
1092 = panic "ppr_amode: CJoinPoint"
1094 ppr_amode (CTableEntry base index kind)
1095 = hcat [text "((", pprPrimKind kind, text " *)(",
1096 ppr_amode base, text "))[(I_)(", ppr_amode index,
1099 ppr_amode (CMacroExpr pk macro as)
1100 = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen,
1101 hcat (punctuate comma (map pprAmode as)), text "))"]
1103 ppr_amode (CCostCentre cc print_as_string)
1104 = uppCostCentre print_as_string cc
1107 %************************************************************************
1109 \subsection[a2r-MagicIds]{Magic ids}
1111 %************************************************************************
1113 @pprRegRelative@ returns a pair of the @Doc@ for the register
1114 (some casting may be required), and a @Maybe Doc@ for the offset
1115 (zero offset gives a @Nothing@).
1118 addPlusSign :: Bool -> SDoc -> SDoc
1119 addPlusSign False p = p
1120 addPlusSign True p = (<>) (char '+') p
1122 pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0
1123 pprSignedInt sign_wanted n
1124 = if n == 0 then Nothing else
1125 if n > 0 then Just (addPlusSign sign_wanted (int n))
1128 pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve)
1130 -> (SDoc, Maybe SDoc)
1132 pprRegRelative sign_wanted (SpARel spA off)
1133 = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off))
1135 pprRegRelative sign_wanted (SpBRel spB off)
1136 = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
1138 pprRegRelative sign_wanted r@(HpRel hp off)
1139 = let to_print = hp `subOff` off
1140 pp_Hp = pprMagicId Hp
1142 if isZeroOff to_print then
1145 (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print)))
1146 -- No parens needed because pprHeapOffset
1147 -- does them when necessary
1149 pprRegRelative sign_wanted (NodeRel off)
1150 = let pp_Node = pprMagicId node
1152 if isZeroOff off then
1155 (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off)))
1159 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1160 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1161 to select the union tag.
1164 pprMagicId :: MagicId -> SDoc
1166 pprMagicId BaseReg = ptext SLIT("BaseReg")
1167 pprMagicId StkOReg = ptext SLIT("StkOReg")
1168 pprMagicId (VanillaReg pk n)
1169 = hcat [ pprVanillaReg n, char '.',
1171 pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
1172 pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
1173 pprMagicId (LongReg _ n) = (<>) (ptext SLIT("LngReg")) (int IBOX(n))
1174 pprMagicId TagReg = ptext SLIT("TagReg")
1175 pprMagicId RetReg = ptext SLIT("RetReg")
1176 pprMagicId SpA = ptext SLIT("SpA")
1177 pprMagicId SuA = ptext SLIT("SuA")
1178 pprMagicId SpB = ptext SLIT("SpB")
1179 pprMagicId SuB = ptext SLIT("SuB")
1180 pprMagicId Hp = ptext SLIT("Hp")
1181 pprMagicId HpLim = ptext SLIT("HpLim")
1182 pprMagicId LivenessReg = ptext SLIT("LivenessReg")
1183 pprMagicId StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
1184 pprMagicId StkStubReg = ptext SLIT("StkStubReg")
1185 pprMagicId CurCostCentre = ptext SLIT("CCC")
1186 pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
1188 pprVanillaReg :: FAST_INT -> SDoc
1190 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1192 pprUnionTag :: PrimRep -> SDoc
1194 pprUnionTag PtrRep = char 'p'
1195 pprUnionTag CodePtrRep = ptext SLIT("fp")
1196 pprUnionTag DataPtrRep = char 'd'
1197 pprUnionTag RetRep = char 'r'
1198 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1200 pprUnionTag CharRep = char 'c'
1201 pprUnionTag IntRep = char 'i'
1202 pprUnionTag WordRep = char 'w'
1203 pprUnionTag AddrRep = char 'v'
1204 pprUnionTag FloatRep = char 'f'
1205 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1207 pprUnionTag StablePtrRep = char 'i'
1208 pprUnionTag ForeignObjRep = char 'p'
1210 pprUnionTag ArrayRep = char 'p'
1211 pprUnionTag ByteArrayRep = char 'b'
1213 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1217 Find and print local and external declarations for a list of
1218 Abstract~C statements.
1220 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1221 pprTempAndExternDecls AbsCNop = (empty, empty)
1223 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1224 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1225 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1226 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1227 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1228 returnTE (vcat real_temps, vcat real_exts) }}
1231 pprTempAndExternDecls other_stmt
1232 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1243 pprBasicLit :: Literal -> SDoc
1244 pprPrimKind :: PrimRep -> SDoc
1246 pprBasicLit lit = ppr lit
1247 pprPrimKind k = ppr k
1251 %************************************************************************
1253 \subsection[a2r-monad]{Monadery}
1255 %************************************************************************
1257 We need some monadery to keep track of temps and externs we have already
1258 printed. This info must be threaded right through the Abstract~C, so
1259 it's most convenient to hide it in this monad.
1261 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1262 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1265 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1266 emptyCLabelSet = emptyFM
1267 x `elementOfCLabelSet` labs
1268 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1270 addToCLabelSet set x = addToFM set x ()
1272 type TEenv = (UniqSet Unique, CLabelSet)
1274 type TeM result = TEenv -> (TEenv, result)
1276 initTE :: TeM a -> a
1278 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1281 {-# INLINE thenTE #-}
1282 {-# INLINE returnTE #-}
1284 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1286 = case a u of { (u_1, result_of_a) ->
1289 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1290 mapTE f [] = returnTE []
1292 = f x `thenTE` \ r ->
1293 mapTE f xs `thenTE` \ rs ->
1296 returnTE :: a -> TeM a
1297 returnTE result env = (env, result)
1299 -- these next two check whether the thing is already
1300 -- recorded, and THEN THEY RECORD IT
1301 -- (subsequent calls will return False for the same uniq/label)
1303 tempSeenTE :: Unique -> TeM Bool
1304 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1305 = if (uniq `elementOfUniqSet` seen_uniqs)
1307 else ((addOneToUniqSet seen_uniqs uniq,
1311 labelSeenTE :: CLabel -> TeM Bool
1312 labelSeenTE label env@(seen_uniqs, seen_labels)
1313 = if (label `elementOfCLabelSet` seen_labels)
1316 addToCLabelSet seen_labels label),
1321 pprTempDecl :: Unique -> PrimRep -> SDoc
1322 pprTempDecl uniq kind
1323 = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
1325 pprExternDecl :: CLabel -> PrimRep -> SDoc
1327 pprExternDecl clabel kind
1328 = if not (needsCDecl clabel) then
1329 empty -- do not print anything for "known external" things (e.g., < PreludeCore)
1333 CodePtrRep -> ppLocalnessMacro True{-function-} clabel
1334 _ -> ppLocalnessMacro False{-data-} clabel
1335 ) of { pp_macro_str ->
1337 hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
1342 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1344 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1346 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1347 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1348 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1349 returnTE (maybe_vcat [p1, p2])
1351 ppr_decls_AbsC (CClosureUpdInfo info)
1352 = ppr_decls_AbsC info
1354 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1356 ppr_decls_AbsC (CAssign dest source)
1357 = ppr_decls_Amode dest `thenTE` \ p1 ->
1358 ppr_decls_Amode source `thenTE` \ p2 ->
1359 returnTE (maybe_vcat [p1, p2])
1361 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1363 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1365 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1367 ppr_decls_AbsC (CSwitch discrim alts deflt)
1368 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1369 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1370 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1371 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1373 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1375 ppr_decls_AbsC (CCodeBlock label absC)
1376 = ppr_decls_AbsC absC
1378 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
1379 -- ToDo: strictly speaking, should chk "cost_centre" amode
1380 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1385 Just (pprExternDecl info_lbl PtrRep))
1387 info_lbl = infoTableLabelFromCI cl_info
1389 ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
1390 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1392 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1394 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1395 -- you get some nasty re-decls of stdio.h if you compile
1396 -- the prelude while looking inside those amodes;
1397 -- no real reason to, anyway.
1398 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1400 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1401 -- ToDo: strictly speaking, should chk "cost_centre" amode
1402 = ppr_decls_Amodes amodes
1404 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
1405 = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
1406 ppr_decls_AbsC slow `thenTE` \ p2 ->
1408 Nothing -> returnTE (Nothing, Nothing)
1409 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1410 returnTE (maybe_vcat [p1, p2, p3])
1412 entry_lbl = CLbl slow_lbl CodePtrRep
1413 slow_lbl = case (nonemptyAbsC slow) of
1414 Nothing -> mkErrorStdEntryLabel
1415 Just _ -> entryLabelFromCI cl_info
1417 ppr_decls_AbsC (CRetVector label maybe_amodes absC)
1418 = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
1419 ppr_decls_AbsC absC `thenTE` \ p2 ->
1420 returnTE (maybe_vcat [p1, p2])
1422 ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
1423 ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
1427 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1428 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1429 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1430 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1431 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1432 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1433 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1434 ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
1436 -- CIntLike must be a literal -- no decls
1437 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1439 -- CCharLike may have be arbitrary value -- may have decls
1440 ppr_decls_Amode (CCharLike char)
1441 = ppr_decls_Amode char
1443 -- now, the only place where we actually print temps/externs...
1444 ppr_decls_Amode (CTemp uniq kind)
1446 VoidRep -> returnTE (Nothing, Nothing)
1448 tempSeenTE uniq `thenTE` \ temp_seen ->
1450 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1452 ppr_decls_Amode (CLbl label VoidRep)
1453 = returnTE (Nothing, Nothing)
1455 ppr_decls_Amode (CLbl label kind)
1456 = labelSeenTE label `thenTE` \ label_seen ->
1458 if label_seen then Nothing else Just (pprExternDecl label kind))
1461 ppr_decls_Amode (CUnVecLbl direct vectored)
1462 = labelSeenTE direct `thenTE` \ dlbl_seen ->
1463 labelSeenTE vectored `thenTE` \ vlbl_seen ->
1465 ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
1466 vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
1469 if (dlbl_seen || not (needsCDecl direct)) &&
1470 (vlbl_seen || not (needsCDecl vectored)) then Nothing
1471 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1474 ppr_decls_Amode (CUnVecLbl direct vectored)
1475 = -- We don't mark either label as "seen", because
1476 -- we don't know which one will be used and which one tossed
1477 -- by the C macro...
1478 --labelSeenTE direct `thenTE` \ dlbl_seen ->
1479 --labelSeenTE vectored `thenTE` \ vlbl_seen ->
1481 ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
1482 vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
1485 if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
1486 ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
1487 else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
1489 ppr_decls_Amode (CTableEntry base index _)
1490 = ppr_decls_Amode base `thenTE` \ p1 ->
1491 ppr_decls_Amode index `thenTE` \ p2 ->
1492 returnTE (maybe_vcat [p1, p2])
1494 ppr_decls_Amode (CMacroExpr _ _ amodes)
1495 = ppr_decls_Amodes amodes
1497 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1500 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1502 = case (unzip ps) of { (ts, es) ->
1503 case (catMaybes ts) of { real_ts ->
1504 case (catMaybes es) of { real_es ->
1505 (if (null real_ts) then Nothing else Just (vcat real_ts),
1506 if (null real_es) then Nothing else Just (vcat real_es))
1511 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1512 ppr_decls_Amodes amodes
1513 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1514 returnTE ( maybe_vcat ps )