2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[PprAbsC]{Pretty-printing Abstract~C}
8 %************************************************************************
18 #include "HsVersions.h"
24 import AbsCUtils ( getAmodeRep, nonemptyAbsC,
25 mixedPtrLocn, mixedTypeLocn
28 import Constants ( mIN_UPD_SIZE )
29 import CallConv ( CallConv, callConvAttribute, cCallConv )
30 import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
31 isReadOnly, needsCDecl, pprCLabel,
32 mkReturnInfoLabel, mkReturnPtLabel,
33 CLabel, CLabelType(..), labelType
36 import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
37 import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
39 import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
40 import CStrings ( stringToC )
41 import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
42 import Const ( Literal(..) )
43 import Maybes ( maybeToBool, catMaybes )
44 import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
45 import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
46 import SMRep ( getSMRepStr )
47 import Unique ( pprUnique, Unique{-instance NamedThing-} )
48 import UniqSet ( emptyUniqSet, elementOfUniqSet,
49 addOneToUniqSet, UniqSet
51 import StgSyn ( SRT(..) )
52 import BitSet ( intBS )
54 import Util ( nOfThem )
63 For spitting out the costs of an abstract~C expression, @writeRealC@
64 now not only prints the C~code of the @absC@ arg but also adds a macro
65 call to a cost evaluation function @GRAN_EXEC@. For that,
66 @pprAbsC@ has a new ``costs'' argument. %% HWL
70 writeRealC :: Handle -> AbstractC -> IO ()
71 writeRealC handle absC
72 -- avoid holding on to the whole of absC in the !Gransim case.
74 then printForCFast fp (pprAbsC absC (costs absC))
75 else printForCFast fp (pprAbsC absC (panic "costs"))
76 --printForC handle (pprAbsC absC (panic "costs"))
77 dumpRealC :: AbstractC -> SDoc
78 dumpRealC absC = pprAbsC absC (costs absC)
81 writeRealC :: Handle -> AbstractC -> IO ()
82 --writeRealC handle absC =
84 -- printDoc LeftMode handle (pprAbsC absC (costs absC))
86 writeRealC handle absC
87 | opt_GranMacros = _scc_ "writeRealC" printForC handle $
88 pprCode CStyle (pprAbsC absC (costs absC))
89 | otherwise = _scc_ "writeRealC" printForC handle $
90 pprCode CStyle (pprAbsC absC (panic "costs"))
92 dumpRealC :: AbstractC -> SDoc
94 | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
95 | otherwise = pprCode CStyle (pprAbsC absC (panic "costs"))
99 This emits the macro, which is used in GrAnSim to compute the total costs
100 from a cost 5 tuple. %% HWL
103 emitMacro :: CostRes -> SDoc
105 emitMacro _ | not opt_GranMacros = empty
107 emitMacro (Cost (i,b,l,s,f))
108 = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
109 int i, comma, int b, comma, int l, comma,
110 int s, comma, int f, pp_paren_semi ]
112 pp_paren_semi = text ");"
115 New type: Now pprAbsC also takes the costs for evaluating the Abstract C
116 code as an argument (that's needed when spitting out the GRAN_EXEC macro
117 which must be done before the return i.e. inside absC code) HWL
120 pprAbsC :: AbstractC -> CostRes -> SDoc
121 pprAbsC AbsCNop _ = empty
122 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
124 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
126 pprAbsC (CJump target) c
127 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
128 (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
130 pprAbsC (CFallThrough target) c
131 = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
132 (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
134 -- --------------------------------------------------------------------------
135 -- Spit out GRAN_EXEC macro immediately before the return HWL
137 pprAbsC (CReturn am return_info) c
138 = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
139 (hcat [text jmp_lit, target, pp_paren_semi ])
141 target = case return_info of
142 DirectReturn -> hcat [char '(', pprAmode am, rparen]
143 DynamicVectoredReturn am' -> mk_vector (pprAmode am')
144 StaticVectoredReturn n -> mk_vector (int n) -- Always positive
145 mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
148 pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
150 -- we optimise various degenerate cases of CSwitches.
152 -- --------------------------------------------------------------------------
153 -- Assume: CSwitch is also end of basic block
154 -- costs function yields nullCosts for whole switch
155 -- ==> inherited costs c are those of basic block up to switch
156 -- ==> inherit c + costs for the corresponding branch
158 -- --------------------------------------------------------------------------
160 pprAbsC (CSwitch discrim [] deflt) c
161 = pprAbsC deflt (c + costs deflt)
162 -- Empty alternative list => no costs for discrim as nothing cond. here HWL
164 pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
165 = case (nonemptyAbsC deflt) of
166 Nothing -> -- one alt and no default
167 pprAbsC alt_code (c + costs alt_code)
168 -- Nothing conditional in here either HWL
170 Just dc -> -- make it an "if"
171 do_if_stmt discrim tag alt_code dc c
173 pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
174 (tag2@(MachInt i2 _), alt_code2)] deflt) c
175 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
177 do_if_stmt discrim tag1 alt_code1 alt_code2 c
179 do_if_stmt discrim tag2 alt_code2 alt_code1 c
181 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
183 pprAbsC (CSwitch discrim alts deflt) c -- general case
184 | isFloatingRep (getAmodeRep discrim)
185 = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
188 hcat [text "switch (", pp_discrim, text ") {"],
189 nest 2 (vcat (map ppr_alt alts)),
190 (case (nonemptyAbsC deflt) of
193 nest 2 (vcat [ptext SLIT("default:"),
194 pprAbsC dc (c + switch_head_cost
196 ptext SLIT("break;")])),
203 = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
204 nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
205 (ptext SLIT("break;"))) ]
207 -- Costs for addressing header of switch and cond. branching -- HWL
208 switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
210 pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
211 = pprCCall op args results vol_regs
213 pprAbsC stmt@(COpStmt results op args vol_regs) _
215 non_void_args = grab_non_void_amodes args
216 non_void_results = grab_non_void_amodes results
217 -- if just one result, we print in the obvious "assignment" style;
218 -- if 0 or many results, we emit a macro call, w/ the results
219 -- followed by the arguments. The macro presumably knows which
222 the_op = ppr_op_call non_void_results non_void_args
223 -- liveness mask is *in* the non_void_args
225 case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
226 if primOpNeedsWrapper op then
235 ppr_op_call results args
236 = hcat [ pprPrimOp op, lparen,
237 hcat (punctuate comma (map ppr_op_result results)),
238 if null results || null args then empty else comma,
239 hcat (punctuate comma (map pprAmode args)),
242 ppr_op_result r = ppr_amode r
243 -- primop macros do their own casting of result;
244 -- hence we can toss the provided cast...
246 pprAbsC stmt@(CSRT lbl closures) c
247 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
249 $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
250 $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
253 where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
255 pprAbsC stmt@(CBitmap lbl mask) c
257 hcat [ ptext SLIT("BITMAP"), lparen,
258 pprCLabel lbl, comma,
261 hcat (punctuate comma (map (int.intBS) mask)),
265 pprAbsC (CSimultaneous abs_c) c
266 = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
268 pprAbsC (CCheck macro as code) c
269 = hcat [text (show macro), lparen,
270 hcat (punctuate comma (map ppr_amode as)), comma,
271 pprAbsC code c, pp_paren_semi
273 pprAbsC (CMacroStmt macro as) _
274 = hcat [text (show macro), lparen,
275 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
276 pprAbsC (CCallProfCtrMacro op as) _
277 = hcat [ptext op, lparen,
278 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
279 pprAbsC (CCallProfCCMacro op as) _
280 = hcat [ptext op, lparen,
281 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
282 pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
283 = hsep [ ptext SLIT("typedef")
286 , parens (hsep (punctuate comma ccall_decl_ty_args))
289 fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
293 Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
296 case non_void_results of
297 [] -> ptext SLIT("void")
298 [amode] -> text (showPrimRep (getAmodeRep amode))
299 _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
301 ccall_decl_ty_args = tail ccall_arg_tys
302 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
304 -- the first argument will be the "I/O world" token (a VoidRep)
305 -- all others should be non-void
308 in ASSERT (all non_void nvas) nvas
310 -- there will usually be two results: a (void) state which we
311 -- should ignore and a (possibly void) result.
313 let nvrs = grab_non_void_amodes results
314 in ASSERT (length nvrs <= 1) nvrs
316 pprAbsC (CCodeBlock label abs_C) _
317 = if not (maybeToBool(nonemptyAbsC abs_C)) then
318 pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
320 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
322 hcat [text (if (externallyVisibleCLabel label)
323 then "FN_(" -- abbreviations to save on output
325 pprCLabel label, text ") {"],
329 nest 8 (ptext SLIT("FB_")),
330 nest 8 (pprAbsC abs_C (costs abs_C)),
331 nest 8 (ptext SLIT("FE_")),
336 pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
337 = hcat [ ptext SLIT("SET_HDR_"), char '(',
338 ppr_amode (CAddr reg_rel), comma,
339 pprCLabelAddr info_lbl, comma,
340 if_profiling (pprAmode cost_centre),
343 info_lbl = infoTableLabelFromCI cl_info
345 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
346 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
350 ptext SLIT("SET_STATIC_HDR"), char '(',
351 pprCLabel closure_lbl, comma,
352 pprCLabel info_lbl, comma,
353 if_profiling (pprAmode cost_centre), comma,
354 ppLocalness closure_lbl, comma,
355 ppLocalnessMacro info_lbl,
358 nest 2 (ppr_payload (amodes ++ padding_wds)),
362 info_lbl = infoTableLabelFromCI cl_info
364 ppr_payload [] = empty
365 ppr_payload ls = comma <+>
366 braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
369 | rep == VoidRep = text "0" -- might not even need this...
370 | rep == FloatRep = ppr_amode (floatToWord item)
371 | rep == DoubleRep = hcat (punctuate (text ", (L_)")
372 (map ppr_amode (doubleToWords item)))
373 | otherwise = ppr_amode item
375 rep = getAmodeRep item
377 -- always at least one padding word: this is the static link field for
378 -- the garbage collector.
380 if not (closureUpdReqd cl_info) then
383 case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
384 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
386 pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
389 ptext SLIT("INFO_TABLE"),
390 ( if is_selector then
391 ptext SLIT("_SELECTOR")
392 else if is_constr then
393 ptext SLIT("_CONSTR")
394 else if needs_srt then
396 else empty ), char '(',
398 pprCLabel info_lbl, comma,
399 pprCLabel slow_lbl, comma,
400 pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
402 ppLocalness info_lbl, comma,
403 ppLocalnessMacro slow_lbl, comma,
405 if_profiling pp_descr, comma,
406 if_profiling pp_type,
412 Just fast -> let stuff = CCodeBlock fast_lbl fast in
413 pprAbsC stuff (costs stuff)
416 info_lbl = infoTableLabelFromCI cl_info
417 fast_lbl = fastLabelFromCI cl_info
420 = case (nonemptyAbsC slow) of
421 Nothing -> (mkErrorStdEntryLabel, empty)
422 Just xx -> (entryLabelFromCI cl_info,
423 let stuff = CCodeBlock slow_lbl xx in
424 pprAbsC stuff (costs stuff))
426 maybe_selector = maybeSelectorInfo cl_info
427 is_selector = maybeToBool maybe_selector
428 (Just select_word_i) = maybe_selector
430 maybe_tag = closureSemiTag cl_info
431 is_constr = maybeToBool maybe_tag
432 (Just tag) = maybe_tag
434 needs_srt = has_srt srt && needsSRT cl_info
436 size = closureNonHdrSize cl_info
438 ptrs = closurePtrsSize cl_info
441 pp_rest | is_selector = int select_word_i
446 hcat [ int tag, comma ]
447 else if needs_srt then
452 type_str = text (getSMRepStr (closureSMRep cl_info))
454 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
455 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
457 pprAbsC stmt@(CRetDirect uniq code srt liveness) _
460 ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
461 pprCLabel info_lbl, comma,
462 pprCLabel entry_lbl, comma,
463 pp_liveness liveness, comma, -- bitmap
464 pp_srt_info srt, -- SRT
465 ptext type_str, comma, -- closure type
466 ppLocalness info_lbl, comma, -- info table storage class
467 ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
474 info_lbl = mkReturnInfoLabel uniq
475 entry_lbl = mkReturnPtLabel uniq
477 pp_code = let stuff = CCodeBlock entry_lbl code in
478 pprAbsC stuff (costs stuff)
480 type_str = case liveness of
481 LvSmall _ -> SLIT("RET_SMALL")
482 LvLarge _ -> SLIT("RET_BIG")
484 pprAbsC stmt@(CRetVector label amodes srt liveness) _
488 ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
490 pp_liveness liveness, comma, -- bitmap liveness mask
491 pp_srt_info srt, -- SRT
492 ptext type_str, -- or big, depending on the size
493 -- of the liveness mask.
501 case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
504 hcat [ppLocalness label,
505 ptext SLIT(" vec_info_"), int size, space,
506 pprCLabel label, text "= { {"
508 nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
511 ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
514 type_str = case liveness of
515 LvSmall _ -> SLIT("RET_VEC_SMALL")
516 LvLarge _ -> SLIT("RET_VEC_BIG")
519 pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
520 pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
527 static = if (externallyVisibleCLabel label)
529 else ptext SLIT("static ")
530 const = if not (isReadOnly label)
532 else ptext SLIT("const")
534 -- Horrible macros for declaring the types and locality of labels (see
537 ppLocalnessMacro clabel =
539 char (if externallyVisibleCLabel clabel then 'E' else 'I'),
540 case labelType clabel of
541 InfoTblType -> ptext SLIT("I_")
542 ClosureType -> ptext SLIT("C_")
543 CodeType -> ptext SLIT("F_")
544 DataType -> ptext SLIT("D_") <>
546 then ptext SLIT("RO_")
554 grab_non_void_amodes amodes
555 = filter non_void amodes
558 = case (getAmodeRep amode) of
564 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
566 ppr_vol_regs [] = (empty, empty)
567 ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
569 = let pp_reg = case r of
570 VanillaReg pk n -> pprVanillaReg n
572 (more_saves, more_restores) = ppr_vol_regs rs
574 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
575 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
577 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
578 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
579 -- depending on the platform. (The "volatile regs" stuff handles all
580 -- other registers.) Just be *sure* BaseReg is OK before trying to do
581 -- anything else. The correct sequence of saves&restores are
582 -- encoded by the CALLER_*_SYSTEM macros.
585 [ ptext SLIT("CALLER_SAVE_Base")
586 , ptext SLIT("CALLER_SAVE_SYSTEM")
589 pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
593 has_srt (_, NoSRT) = False
602 (lbl, SRT off len) ->
603 hcat [ pprCLabel lbl, comma,
610 = if opt_SccProfilingOn
612 else char '0' -- leave it out!
613 -- ---------------------------------------------------------------------------
614 -- Changes for GrAnSim:
615 -- draw costs for computation in head of if into both branches;
616 -- as no abstractC data structure is given for the head, one is constructed
617 -- guessing unknown values and fed into the costs function
618 -- ---------------------------------------------------------------------------
620 do_if_stmt discrim tag alt_code deflt c
622 -- This special case happens when testing the result of a comparison.
623 -- We can just avoid some redundant clutter in the output.
624 MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
626 (addrModeCosts discrim Rhs) c
628 cond = hcat [ pprAmode discrim,
630 pprAmode (CLit tag) ]
634 (addrModeCosts discrim Rhs) c
636 ppr_if_stmt pp_pred then_part else_part discrim_costs c
638 hcat [text "if (", pp_pred, text ") {"],
639 nest 8 (pprAbsC then_part (c + discrim_costs +
640 (Cost (0, 2, 0, 0, 0)) +
642 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
643 nest 8 (pprAbsC else_part (c + discrim_costs +
644 (Cost (0, 1, 0, 0, 0)) +
647 {- Total costs = inherited costs (before if) + costs for accessing discrim
648 + costs for cond branch ( = (0, 1, 0, 0, 0) )
649 + costs for that alternative
653 Historical note: this used to be two separate cases -- one for `ccall'
654 and one for `casm'. To get round a potential limitation to only 10
655 arguments, the numbering of arguments in @process_casm@ was beefed up a
658 Some rough notes on generating code for @CCallOp@:
660 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
661 2) Save any essential registers (heap, stack, etc).
663 ToDo: If stable pointers are in use, these must be saved in a place
664 where the runtime system can get at them so that the Stg world can
665 be restarted during the call.
667 3) Save any temporary registers that are currently in use.
668 4) Do the call, putting result into a local variable
669 5) Restore essential registers
670 6) Restore temporaries
672 (This happens after restoration of essential registers because we
673 might need the @Base@ register to access all the others correctly.)
675 Otherwise, copy local variable into result register.
677 8) If ccall (not casm), declare the function being called as extern so
678 that C knows if it returns anything other than an int.
681 { ResultType _ccall_result;
684 _ccall_result = f( args );
688 return_reg = _ccall_result;
692 Amendment to the above: if we can GC, we have to:
694 * make sure we save all our registers away where the garbage collector
696 * be sure that there are no live registers or we're in trouble.
697 (This can cause problems if you try something foolish like passing
698 an array or a foreign obj to a _ccall_GC_ thing.)
699 * increment/decrement the @inCCallGC@ counter before/after the call so
700 that the runtime check that PerformGC is being used sensibly will work.
703 pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
706 declare_local_vars, -- local var for *result*
707 vcat local_arg_decls,
709 declare_fun_extern, -- declare expected function type.
710 process_casm local_vars pp_non_void_args casm_str,
716 (pp_saves, pp_restores) = ppr_vol_regs vol_regs
717 (pp_save_context, pp_restore_context)
718 | may_gc = ( text "do { SaveThreadState();"
719 , text "LoadThreadState();} while(0);"
721 | otherwise = ( pp_basic_saves $$ pp_saves,
722 pp_basic_restores $$ pp_restores)
726 in ASSERT (all non_void nvas) nvas
727 -- the first argument will be the "I/O world" token (a VoidRep)
728 -- all others should be non-void
731 let nvrs = grab_non_void_amodes results
732 in ASSERT (length nvrs <= 1) nvrs
733 -- there will usually be two results: a (void) state which we
734 -- should ignore and a (possibly void) result.
736 (local_arg_decls, pp_non_void_args)
737 = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
741 In the non-casm case, to ensure that we're entering the given external
742 entry point using the correct calling convention, we have to do the following:
744 - When entering via a function pointer (the `dynamic' case) using the specified
745 calling convention, we emit a typedefn declaration attributed with the
746 calling convention to use together with the result and parameter types we're
747 assuming. Coerce the function pointer to this type and go.
749 - to enter the function at a given code label, we emit an extern declaration
750 for the label here, stating the calling convention together with result and
751 argument types we're assuming.
753 The C compiler will hopefully use this extern declaration to good effect,
754 reporting any discrepancies between our extern decl and any other that
757 Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
758 the external function `foo' use the calling convention of the first `foo'
759 prototype it encounters (nor does it complain about conflicting attribute
760 declarations). The consequence of this is that you cannot override the
761 calling convention of `foo' using an extern declaration (you'd have to use
762 a typedef), but why you would want to do such a thing in the first place
763 is totally beyond me.
765 ToDo: petition the gcc folks to add code to warn about conflicting attribute
770 | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
772 hsep [ typedef_or_extern
775 , parens (hsep (punctuate comma ccall_decl_ty_args))
779 | is_dynamic = ptext SLIT("typedef")
780 | otherwise = ptext SLIT("extern")
783 | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
784 | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
786 -- leave out function pointer
788 | is_dynamic = tail ccall_arg_tys
789 | otherwise = ccall_arg_tys
791 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
794 case non_void_results of
795 [] -> ptext SLIT("void")
796 [amode] -> text (showPrimRep (getAmodeRep amode))
797 _ -> panic "pprCCall: ccall_res_ty"
800 ptext SLIT("_ccall_fun_ty") <>
805 (declare_local_vars, local_vars, assign_results)
806 = ppr_casm_results non_void_results
808 (Left asm_str) = op_str
814 casm_str = if is_asm then _UNPK_ asm_str else ccall_str
816 -- Remainder only used for ccall
819 | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
820 | otherwise = ptext asm_str
824 if null non_void_results
827 lparen, fun_name, lparen,
828 hcat (punctuate comma ccall_fun_args),
833 | is_dynamic = tail ccall_args
834 | otherwise = ccall_args
836 ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
840 If the argument is a heap object, we need to reach inside and pull out
841 the bit the C world wants to see. The only heap objects which can be
842 passed are @Array@s and @ByteArray@s.
845 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
846 -- (a) decl and assignment, (b) local var to be used later
848 ppr_casm_arg amode a_num
850 a_kind = getAmodeRep amode
851 pp_amode = pprAmode amode
852 pp_kind = pprPrimKind a_kind
854 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
856 (arg_type, pp_amode2)
859 -- for array arguments, pass a pointer to the body of the array
860 -- (PTRS_ARR_CTS skips over all the header nonsense)
861 ArrayRep -> (pp_kind,
862 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
863 ByteArrayRep -> (pp_kind,
864 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
866 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
867 ForeignObjRep -> (pp_kind,
868 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
869 char '(', pp_amode, char ')'])
871 other -> (pp_kind, pp_amode)
874 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
876 (declare_local_var, local_var)
879 For l-values, the critical questions are:
881 1) Are there any results at all?
883 We only allow zero or one results.
887 :: [CAddrMode] -- list of results (length <= 1)
889 ( SDoc, -- declaration of any local vars
890 [SDoc], -- list of result vars (same length as results)
891 SDoc ) -- assignment (if any) of results in local var to registers
894 = (empty, [], empty) -- no results
898 result_reg = ppr_amode r
899 r_kind = getAmodeRep r
901 local_var = ptext SLIT("_ccall_result")
903 (result_type, assign_result)
904 = (pprPrimKind r_kind,
905 hcat [ result_reg, equals, local_var, semi ])
907 declare_local_var = hcat [ result_type, space, local_var, semi ]
909 (declare_local_var, [local_var], assign_result)
912 = panic "ppr_casm_results: ccall/casm with many results"
916 Note the sneaky way _the_ result is represented by a list so that we
917 can complain if it's used twice.
919 ToDo: Any chance of giving line numbers when process-casm fails?
920 Or maybe we should do a check _much earlier_ in compiler. ADR
923 process_casm :: [SDoc] -- results (length <= 1)
924 -> [SDoc] -- arguments
925 -> String -- format string (with embedded %'s)
926 -> SDoc -- code being generated
928 process_casm results args string = process results args string
930 process [] _ "" = empty
931 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
933 "\"\n(Try changing result type to PrimIO ()\n")
935 process ress args ('%':cs)
938 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
941 char '%' <> process ress args css
945 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
946 [r] -> r <> (process [] args css)
947 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
951 read_int :: ReadS Int
954 case (read_int other) of
956 if 0 <= num && num < length args
957 then parens (args !! num) <> process ress args css
958 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
959 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
961 process ress args (other_c:cs)
962 = char other_c <> process ress args cs
965 %************************************************************************
967 \subsection[a2r-assignments]{Assignments}
969 %************************************************************************
971 Printing assignments is a little tricky because of type coercion.
973 First of all, the kind of the thing being assigned can be gotten from
974 the destination addressing mode. (It should be the same as the kind
975 of the source addressing mode.) If the kind of the assignment is of
976 @VoidRep@, then don't generate any code at all.
979 pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
981 pprAssign VoidRep dest src = empty
984 Special treatment for floats and doubles, to avoid unwanted conversions.
987 pprAssign FloatRep dest@(CVal reg_rel _) src
988 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
990 pprAssign DoubleRep dest@(CVal reg_rel _) src
991 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
993 pprAssign Int64Rep dest@(CVal reg_rel _) src
994 = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
995 pprAssign Word64Rep dest@(CVal reg_rel _) src
996 = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
999 Lastly, the question is: will the C compiler think the types of the
1000 two sides of the assignment match?
1002 We assume that the types will match
1003 if neither side is a @CVal@ addressing mode for any register
1004 which can point into the heap or B stack.
1006 Why? Because the heap and B stack are used to store miscellaneous things,
1007 whereas the A stack, temporaries, registers, etc., are only used for things
1011 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
1012 = hcat [ pprVanillaReg dest, equals,
1013 pprVanillaReg src, semi ]
1015 pprAssign kind dest src
1016 | mixedTypeLocn dest
1017 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
1018 = hcat [ ppr_amode dest, equals,
1019 text "(W_)(", -- Here is the cast
1020 ppr_amode src, pp_paren_semi ]
1022 pprAssign kind dest src
1023 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
1024 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
1025 = hcat [ ppr_amode dest, equals,
1026 text "(P_)(", -- Here is the cast
1027 ppr_amode src, pp_paren_semi ]
1029 pprAssign ByteArrayRep dest src
1031 -- Add in a cast iff the source is mixed
1032 = hcat [ ppr_amode dest, equals,
1033 text "(StgByteArray)(", -- Here is the cast
1034 ppr_amode src, pp_paren_semi ]
1036 pprAssign kind other_dest src
1037 = hcat [ ppr_amode other_dest, equals,
1038 pprAmode src, semi ]
1042 %************************************************************************
1044 \subsection[a2r-CAddrModes]{Addressing modes}
1046 %************************************************************************
1048 @pprAmode@ is used to print r-values (which may need casts), whereas
1049 @ppr_amode@ is used for l-values {\em and} as a help function for
1053 pprAmode, ppr_amode :: CAddrMode -> SDoc
1056 For reasons discussed above under assignments, @CVal@ modes need
1057 to be treated carefully. First come special cases for floats and doubles,
1058 similar to those in @pprAssign@:
1060 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
1064 pprAmode (CVal reg_rel FloatRep)
1065 = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
1066 pprAmode (CVal reg_rel DoubleRep)
1067 = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
1068 pprAmode (CVal reg_rel Int64Rep)
1069 = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
1070 pprAmode (CVal reg_rel Word64Rep)
1071 = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
1074 Next comes the case where there is some other cast need, and the
1079 | mixedTypeLocn amode
1080 = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
1082 | otherwise -- No cast needed
1086 Now the rest of the cases for ``workhorse'' @ppr_amode@:
1089 ppr_amode (CVal reg_rel _)
1090 = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1091 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
1092 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
1094 ppr_amode (CAddr reg_rel)
1095 = case (pprRegRelative True{-sign wanted-} reg_rel) of
1096 (pp_reg, Nothing) -> pp_reg
1097 (pp_reg, Just offset) -> (<>) pp_reg offset
1099 ppr_amode (CReg magic_id) = pprMagicId magic_id
1101 ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
1103 ppr_amode (CLbl label kind) = pprCLabelAddr label
1105 ppr_amode (CCharLike ch)
1106 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
1107 ppr_amode (CIntLike int)
1108 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
1110 ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
1111 -- ToDo: are these *used* for anything?
1113 ppr_amode (CLit lit) = pprBasicLit lit
1115 ppr_amode (CLitLit str _) = ptext str
1117 ppr_amode (CJoinPoint _)
1118 = panic "ppr_amode: CJoinPoint"
1120 ppr_amode (CTableEntry base index kind)
1121 = hcat [text "((", pprPrimKind kind, text " *)(",
1122 ppr_amode base, text "))[(I_)(", ppr_amode index,
1125 ppr_amode (CMacroExpr pk macro as)
1126 = parens (pprPrimKind pk) <+>
1127 parens (text (show macro) <>
1128 parens (hcat (punctuate comma (map pprAmode as))))
1131 %************************************************************************
1133 \subsection[ppr-liveness-masks]{Liveness Masks}
1135 %************************************************************************
1138 pp_liveness :: Liveness -> SDoc
1141 LvSmall mask -> int (intBS mask)
1142 LvLarge lbl -> char '&' <> pprCLabel lbl
1145 %************************************************************************
1147 \subsection[a2r-MagicIds]{Magic ids}
1149 %************************************************************************
1151 @pprRegRelative@ returns a pair of the @Doc@ for the register
1152 (some casting may be required), and a @Maybe Doc@ for the offset
1153 (zero offset gives a @Nothing@).
1156 addPlusSign :: Bool -> SDoc -> SDoc
1157 addPlusSign False p = p
1158 addPlusSign True p = (<>) (char '+') p
1160 pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0
1161 pprSignedInt sign_wanted n
1162 = if n == 0 then Nothing else
1163 if n > 0 then Just (addPlusSign sign_wanted (int n))
1166 pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve)
1168 -> (SDoc, Maybe SDoc)
1170 pprRegRelative sign_wanted (SpRel off)
1171 = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
1173 pprRegRelative sign_wanted r@(HpRel o)
1174 = let pp_Hp = pprMagicId Hp; off = I# o
1179 (pp_Hp, Just ((<>) (char '-') (int off)))
1181 pprRegRelative sign_wanted (NodeRel o)
1182 = let pp_Node = pprMagicId node; off = I# o
1187 (pp_Node, Just (addPlusSign sign_wanted (int off)))
1191 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1192 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1193 to select the union tag.
1196 pprMagicId :: MagicId -> SDoc
1198 pprMagicId BaseReg = ptext SLIT("BaseReg")
1199 pprMagicId (VanillaReg pk n)
1200 = hcat [ pprVanillaReg n, char '.',
1202 pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
1203 pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
1204 pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
1205 pprMagicId Sp = ptext SLIT("Sp")
1206 pprMagicId Su = ptext SLIT("Su")
1207 pprMagicId SpLim = ptext SLIT("SpLim")
1208 pprMagicId Hp = ptext SLIT("Hp")
1209 pprMagicId HpLim = ptext SLIT("HpLim")
1210 pprMagicId CurCostCentre = ptext SLIT("CCCS")
1211 pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
1213 pprVanillaReg :: FAST_INT -> SDoc
1214 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1216 pprUnionTag :: PrimRep -> SDoc
1218 pprUnionTag PtrRep = char 'p'
1219 pprUnionTag CodePtrRep = ptext SLIT("fp")
1220 pprUnionTag DataPtrRep = char 'd'
1221 pprUnionTag RetRep = char 'p'
1222 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1224 pprUnionTag CharRep = char 'c'
1225 pprUnionTag IntRep = char 'i'
1226 pprUnionTag WordRep = char 'w'
1227 pprUnionTag AddrRep = char 'a'
1228 pprUnionTag FloatRep = char 'f'
1229 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1231 pprUnionTag StablePtrRep = char 'i'
1232 pprUnionTag WeakPtrRep = char 'p'
1233 pprUnionTag ForeignObjRep = char 'p'
1235 pprUnionTag ThreadIdRep = char 't'
1237 pprUnionTag ArrayRep = char 'p'
1238 pprUnionTag ByteArrayRep = char 'b'
1240 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1244 Find and print local and external declarations for a list of
1245 Abstract~C statements.
1247 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1248 pprTempAndExternDecls AbsCNop = (empty, empty)
1250 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1251 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1252 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1253 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1254 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1255 returnTE (vcat real_temps, vcat real_exts) }}
1258 pprTempAndExternDecls other_stmt
1259 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1270 pprBasicLit :: Literal -> SDoc
1271 pprPrimKind :: PrimRep -> SDoc
1273 pprBasicLit lit = ppr lit
1274 pprPrimKind k = ppr k
1278 %************************************************************************
1280 \subsection[a2r-monad]{Monadery}
1282 %************************************************************************
1284 We need some monadery to keep track of temps and externs we have already
1285 printed. This info must be threaded right through the Abstract~C, so
1286 it's most convenient to hide it in this monad.
1288 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1289 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1292 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1293 emptyCLabelSet = emptyFM
1294 x `elementOfCLabelSet` labs
1295 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1297 addToCLabelSet set x = addToFM set x ()
1299 type TEenv = (UniqSet Unique, CLabelSet)
1301 type TeM result = TEenv -> (TEenv, result)
1303 initTE :: TeM a -> a
1305 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1308 {-# INLINE thenTE #-}
1309 {-# INLINE returnTE #-}
1311 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1313 = case a u of { (u_1, result_of_a) ->
1316 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1317 mapTE f [] = returnTE []
1319 = f x `thenTE` \ r ->
1320 mapTE f xs `thenTE` \ rs ->
1323 returnTE :: a -> TeM a
1324 returnTE result env = (env, result)
1326 -- these next two check whether the thing is already
1327 -- recorded, and THEN THEY RECORD IT
1328 -- (subsequent calls will return False for the same uniq/label)
1330 tempSeenTE :: Unique -> TeM Bool
1331 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1332 = if (uniq `elementOfUniqSet` seen_uniqs)
1334 else ((addOneToUniqSet seen_uniqs uniq,
1338 labelSeenTE :: CLabel -> TeM Bool
1339 labelSeenTE label env@(seen_uniqs, seen_labels)
1340 = if (label `elementOfCLabelSet` seen_labels)
1343 addToCLabelSet seen_labels label),
1348 pprTempDecl :: Unique -> PrimRep -> SDoc
1349 pprTempDecl uniq kind
1350 = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
1352 pprExternDecl :: CLabel -> PrimRep -> SDoc
1354 pprExternDecl clabel kind
1355 = if not (needsCDecl clabel) then
1356 empty -- do not print anything for "known external" things
1358 hcat [ ppLocalnessMacro clabel,
1359 lparen, pprCLabel clabel, pp_paren_semi ]
1363 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1365 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1367 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1368 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1369 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1370 returnTE (maybe_vcat [p1, p2])
1372 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1374 ppr_decls_AbsC (CAssign dest source)
1375 = ppr_decls_Amode dest `thenTE` \ p1 ->
1376 ppr_decls_Amode source `thenTE` \ p2 ->
1377 returnTE (maybe_vcat [p1, p2])
1379 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1381 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1383 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1385 ppr_decls_AbsC (CSwitch discrim alts deflt)
1386 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1387 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1388 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1389 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1391 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1393 ppr_decls_AbsC (CCodeBlock label absC)
1394 = ppr_decls_AbsC absC
1396 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
1397 -- ToDo: strictly speaking, should chk "cost_centre" amode
1398 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1403 Just (pprExternDecl info_lbl PtrRep))
1405 info_lbl = infoTableLabelFromCI cl_info
1407 ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
1408 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1410 ppr_decls_AbsC (CCheck _ amodes code) =
1411 ppr_decls_Amodes amodes `thenTE` \p1 ->
1412 ppr_decls_AbsC code `thenTE` \p2 ->
1413 returnTE (maybe_vcat [p1,p2])
1415 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1417 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1418 -- you get some nasty re-decls of stdio.h if you compile
1419 -- the prelude while looking inside those amodes;
1420 -- no real reason to, anyway.
1421 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1423 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1424 -- ToDo: strictly speaking, should chk "cost_centre" amode
1425 = ppr_decls_Amodes amodes
1427 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
1428 = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
1429 ppr_decls_AbsC slow `thenTE` \ p2 ->
1431 Nothing -> returnTE (Nothing, Nothing)
1432 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1433 returnTE (maybe_vcat [p1, p2, p3])
1435 entry_lbl = CLbl slow_lbl CodePtrRep
1436 slow_lbl = case (nonemptyAbsC slow) of
1437 Nothing -> mkErrorStdEntryLabel
1438 Just _ -> entryLabelFromCI cl_info
1440 ppr_decls_AbsC (CSRT lbl closure_lbls)
1441 = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
1443 if and seen then Nothing
1444 else Just (vcat [ pprExternDecl l PtrRep
1445 | (l,False) <- zip closure_lbls seen ]))
1447 ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
1448 ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
1452 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1453 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1454 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1455 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1456 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1457 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1458 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1460 -- CIntLike must be a literal -- no decls
1461 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1463 -- CCharLike may have be arbitrary value -- may have decls
1464 ppr_decls_Amode (CCharLike char)
1465 = ppr_decls_Amode char
1467 -- now, the only place where we actually print temps/externs...
1468 ppr_decls_Amode (CTemp uniq kind)
1470 VoidRep -> returnTE (Nothing, Nothing)
1472 tempSeenTE uniq `thenTE` \ temp_seen ->
1474 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1476 ppr_decls_Amode (CLbl label VoidRep)
1477 = returnTE (Nothing, Nothing)
1479 ppr_decls_Amode (CLbl label kind)
1480 = labelSeenTE label `thenTE` \ label_seen ->
1482 if label_seen then Nothing else Just (pprExternDecl label kind))
1484 ppr_decls_Amode (CTableEntry base index _)
1485 = ppr_decls_Amode base `thenTE` \ p1 ->
1486 ppr_decls_Amode index `thenTE` \ p2 ->
1487 returnTE (maybe_vcat [p1, p2])
1489 ppr_decls_Amode (CMacroExpr _ _ amodes)
1490 = ppr_decls_Amodes amodes
1492 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1495 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1497 = case (unzip ps) of { (ts, es) ->
1498 case (catMaybes ts) of { real_ts ->
1499 case (catMaybes es) of { real_es ->
1500 (if (null real_ts) then Nothing else Just (vcat real_ts),
1501 if (null real_es) then Nothing else Just (vcat real_es))
1506 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1507 ppr_decls_Amodes amodes
1508 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1509 returnTE ( maybe_vcat ps )
1512 Print out a C Label where you want the *address* of the label, not the
1513 object it refers to. The distinction is important when the label may
1514 refer to a C structure (info tables and closures, for instance).
1516 When just generating a declaration for the label, use pprCLabel.
1519 pprCLabelAddr :: CLabel -> SDoc
1520 pprCLabelAddr clabel =
1521 case labelType clabel of
1522 InfoTblType -> addr_of_label
1523 ClosureType -> addr_of_label
1524 VecTblType -> addr_of_label
1527 addr_of_label = ptext SLIT("(P_)&") <> pp_label
1528 pp_label = pprCLabel clabel
1531 -----------------------------------------------------------------------------
1532 Initialising static objects with floating-point numbers. We can't
1533 just emit the floating point number, because C will cast it to an int
1534 by rounding it. We want the actual bit-representation of the float.
1536 This is a hack to turn the floating point numbers into ints that we
1537 can safely initialise to static locations.
1540 big_doubles = (getPrimRepSize DoubleRep) /= 1
1542 -- floatss are always 1 word
1543 floatToWord :: CAddrMode -> CAddrMode
1544 floatToWord (CLit (MachFloat r))
1546 arr <- newFloatArray (0,0)
1547 writeFloatArray arr 0 (fromRational r)
1548 i <- readIntArray arr 0
1549 return (CLit (MachInt (toInteger i) True))
1552 doubleToWords :: CAddrMode -> [CAddrMode]
1553 doubleToWords (CLit (MachDouble r))
1554 | big_doubles -- doubles are 2 words
1556 arr <- newDoubleArray (0,1)
1557 writeDoubleArray arr 0 (fromRational r)
1558 i1 <- readIntArray arr 0
1559 i2 <- readIntArray arr 1
1560 return [ CLit (MachInt (toInteger i1) True)
1561 , CLit (MachInt (toInteger i2) True)
1564 | otherwise -- doubles are 1 word
1566 arr <- newDoubleArray (0,0)
1567 writeDoubleArray arr 0 (fromRational r)
1568 i <- readIntArray arr 0
1569 return [ CLit (MachInt (toInteger i) True) ]