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))
211 pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _) args vol_regs) _
212 = pprCCall op args results vol_regs
214 pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
215 = pprCCall op args results vol_regs
217 pprAbsC stmt@(COpStmt results op args vol_regs) _
219 non_void_args = grab_non_void_amodes args
220 non_void_results = grab_non_void_amodes results
221 -- if just one result, we print in the obvious "assignment" style;
222 -- if 0 or many results, we emit a macro call, w/ the results
223 -- followed by the arguments. The macro presumably knows which
226 the_op = ppr_op_call non_void_results non_void_args
227 -- liveness mask is *in* the non_void_args
229 case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
230 if primOpNeedsWrapper op then
239 ppr_op_call results args
240 = hcat [ pprPrimOp op, lparen,
241 hcat (punctuate comma (map ppr_op_result results)),
242 if null results || null args then empty else comma,
243 hcat (punctuate comma (map pprAmode args)),
246 ppr_op_result r = ppr_amode r
247 -- primop macros do their own casting of result;
248 -- hence we can toss the provided cast...
250 pprAbsC stmt@(CSRT lbl closures) c
251 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
253 $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
254 $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
257 where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
259 pprAbsC stmt@(CBitmap lbl mask) c
261 hcat [ ptext SLIT("BITMAP"), lparen,
262 pprCLabel lbl, comma,
265 hcat (punctuate comma (map (int.intBS) mask)),
269 pprAbsC (CSimultaneous abs_c) c
270 = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
272 pprAbsC (CCheck macro as code) c
273 = hcat [text (show macro), lparen,
274 hcat (punctuate comma (map ppr_amode as)), comma,
275 pprAbsC code c, pp_paren_semi
277 pprAbsC (CMacroStmt macro as) _
278 = hcat [text (show macro), lparen,
279 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
280 pprAbsC (CCallProfCtrMacro op as) _
281 = hcat [ptext op, lparen,
282 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
283 pprAbsC (CCallProfCCMacro op as) _
284 = hcat [ptext op, lparen,
285 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
286 pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
287 = hsep [ ptext SLIT("typedef")
290 , parens (hsep (punctuate comma ccall_decl_ty_args))
293 fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
297 Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
300 case non_void_results of
301 [] -> ptext SLIT("void")
302 [amode] -> text (showPrimRep (getAmodeRep amode))
303 _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
305 ccall_decl_ty_args = tail ccall_arg_tys
306 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
308 -- the first argument will be the "I/O world" token (a VoidRep)
309 -- all others should be non-void
312 in ASSERT (all non_void nvas) nvas
314 -- there will usually be two results: a (void) state which we
315 -- should ignore and a (possibly void) result.
317 let nvrs = grab_non_void_amodes results
318 in ASSERT (length nvrs <= 1) nvrs
320 pprAbsC (CCodeBlock label abs_C) _
321 = if not (maybeToBool(nonemptyAbsC abs_C)) then
322 pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
324 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
326 hcat [text (if (externallyVisibleCLabel label)
327 then "FN_(" -- abbreviations to save on output
329 pprCLabel label, text ") {"],
333 nest 8 (ptext SLIT("FB_")),
334 nest 8 (pprAbsC abs_C (costs abs_C)),
335 nest 8 (ptext SLIT("FE_")),
340 pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
341 = hcat [ ptext SLIT("SET_HDR_"), char '(',
342 ppr_amode (CAddr reg_rel), comma,
343 pprCLabelAddr info_lbl, comma,
344 if_profiling (pprAmode cost_centre),
347 info_lbl = infoTableLabelFromCI cl_info
349 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
350 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
354 ptext SLIT("SET_STATIC_HDR"), char '(',
355 pprCLabel closure_lbl, comma,
356 pprCLabel info_lbl, comma,
357 if_profiling (pprAmode cost_centre), comma,
358 ppLocalness closure_lbl, comma,
359 ppLocalnessMacro info_lbl,
362 nest 2 (ppr_payload (amodes ++ padding_wds)),
366 info_lbl = infoTableLabelFromCI cl_info
368 ppr_payload [] = empty
369 ppr_payload ls = comma <+>
370 braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
373 | rep == VoidRep = text "0" -- might not even need this...
374 | rep == FloatRep = ppr_amode (floatToWord item)
375 | rep == DoubleRep = hcat (punctuate (text ", (L_)")
376 (map ppr_amode (doubleToWords item)))
377 | otherwise = ppr_amode item
379 rep = getAmodeRep item
381 -- always at least one padding word: this is the static link field for
382 -- the garbage collector.
384 if not (closureUpdReqd cl_info) then
387 case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
388 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
390 pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
393 ptext SLIT("INFO_TABLE"),
394 ( if is_selector then
395 ptext SLIT("_SELECTOR")
396 else if is_constr then
397 ptext SLIT("_CONSTR")
398 else if needs_srt then
400 else empty ), char '(',
402 pprCLabel info_lbl, comma,
403 pprCLabel slow_lbl, comma,
404 pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
406 ppLocalness info_lbl, comma,
407 ppLocalnessMacro slow_lbl, comma,
409 if_profiling pp_descr, comma,
410 if_profiling pp_type,
416 Just fast -> let stuff = CCodeBlock fast_lbl fast in
417 pprAbsC stuff (costs stuff)
420 info_lbl = infoTableLabelFromCI cl_info
421 fast_lbl = fastLabelFromCI cl_info
424 = case (nonemptyAbsC slow) of
425 Nothing -> (mkErrorStdEntryLabel, empty)
426 Just xx -> (entryLabelFromCI cl_info,
427 let stuff = CCodeBlock slow_lbl xx in
428 pprAbsC stuff (costs stuff))
430 maybe_selector = maybeSelectorInfo cl_info
431 is_selector = maybeToBool maybe_selector
432 (Just select_word_i) = maybe_selector
434 maybe_tag = closureSemiTag cl_info
435 is_constr = maybeToBool maybe_tag
436 (Just tag) = maybe_tag
438 needs_srt = has_srt srt && needsSRT cl_info
440 size = closureNonHdrSize cl_info
442 ptrs = closurePtrsSize cl_info
445 pp_rest | is_selector = int select_word_i
450 hcat [ int tag, comma ]
451 else if needs_srt then
456 type_str = text (getSMRepStr (closureSMRep cl_info))
458 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
459 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
461 pprAbsC stmt@(CRetDirect uniq code srt liveness) _
464 ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
465 pprCLabel info_lbl, comma,
466 pprCLabel entry_lbl, comma,
467 pp_liveness liveness, comma, -- bitmap
468 pp_srt_info srt, -- SRT
469 ptext type_str, comma, -- closure type
470 ppLocalness info_lbl, comma, -- info table storage class
471 ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
478 info_lbl = mkReturnInfoLabel uniq
479 entry_lbl = mkReturnPtLabel uniq
481 pp_code = let stuff = CCodeBlock entry_lbl code in
482 pprAbsC stuff (costs stuff)
484 type_str = case liveness of
485 LvSmall _ -> SLIT("RET_SMALL")
486 LvLarge _ -> SLIT("RET_BIG")
488 pprAbsC stmt@(CRetVector label amodes srt liveness) _
492 ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
494 pp_liveness liveness, comma, -- bitmap liveness mask
495 pp_srt_info srt, -- SRT
496 ptext type_str, -- or big, depending on the size
497 -- of the liveness mask.
505 case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
508 hcat [ppLocalness label,
509 ptext SLIT(" vec_info_"), int size, space,
510 pprCLabel label, text "= { {"
512 nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
515 ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
518 type_str = case liveness of
519 LvSmall _ -> SLIT("RET_VEC_SMALL")
520 LvLarge _ -> SLIT("RET_VEC_BIG")
523 pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
524 pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
531 static = if (externallyVisibleCLabel label)
533 else ptext SLIT("static ")
534 const = if not (isReadOnly label)
536 else ptext SLIT("const")
538 -- Horrible macros for declaring the types and locality of labels (see
541 ppLocalnessMacro clabel =
543 char (if externallyVisibleCLabel clabel then 'E' else 'I'),
544 case labelType clabel of
545 InfoTblType -> ptext SLIT("I_")
546 ClosureType -> ptext SLIT("C_")
547 CodeType -> ptext SLIT("F_")
548 DataType -> ptext SLIT("D_") <>
550 then ptext SLIT("RO_")
558 grab_non_void_amodes amodes
559 = filter non_void amodes
562 = case (getAmodeRep amode) of
568 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
570 ppr_vol_regs [] = (empty, empty)
571 ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
573 = let pp_reg = case r of
574 VanillaReg pk n -> pprVanillaReg n
576 (more_saves, more_restores) = ppr_vol_regs rs
578 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
579 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
581 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
582 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
583 -- depending on the platform. (The "volatile regs" stuff handles all
584 -- other registers.) Just be *sure* BaseReg is OK before trying to do
585 -- anything else. The correct sequence of saves&restores are
586 -- encoded by the CALLER_*_SYSTEM macros.
589 [ ptext SLIT("CALLER_SAVE_Base")
590 , ptext SLIT("CALLER_SAVE_SYSTEM")
593 pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
597 has_srt (_, NoSRT) = False
606 (lbl, SRT off len) ->
607 hcat [ pprCLabel lbl, comma,
614 = if opt_SccProfilingOn
616 else char '0' -- leave it out!
617 -- ---------------------------------------------------------------------------
618 -- Changes for GrAnSim:
619 -- draw costs for computation in head of if into both branches;
620 -- as no abstractC data structure is given for the head, one is constructed
621 -- guessing unknown values and fed into the costs function
622 -- ---------------------------------------------------------------------------
624 do_if_stmt discrim tag alt_code deflt c
626 -- This special case happens when testing the result of a comparison.
627 -- We can just avoid some redundant clutter in the output.
628 MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
630 (addrModeCosts discrim Rhs) c
632 cond = hcat [ pprAmode discrim,
634 pprAmode (CLit tag) ]
638 (addrModeCosts discrim Rhs) c
640 ppr_if_stmt pp_pred then_part else_part discrim_costs c
642 hcat [text "if (", pp_pred, text ") {"],
643 nest 8 (pprAbsC then_part (c + discrim_costs +
644 (Cost (0, 2, 0, 0, 0)) +
646 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
647 nest 8 (pprAbsC else_part (c + discrim_costs +
648 (Cost (0, 1, 0, 0, 0)) +
651 {- Total costs = inherited costs (before if) + costs for accessing discrim
652 + costs for cond branch ( = (0, 1, 0, 0, 0) )
653 + costs for that alternative
657 Historical note: this used to be two separate cases -- one for `ccall'
658 and one for `casm'. To get round a potential limitation to only 10
659 arguments, the numbering of arguments in @process_casm@ was beefed up a
662 Some rough notes on generating code for @CCallOp@:
664 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
665 2) Save any essential registers (heap, stack, etc).
667 ToDo: If stable pointers are in use, these must be saved in a place
668 where the runtime system can get at them so that the Stg world can
669 be restarted during the call.
671 3) Save any temporary registers that are currently in use.
672 4) Do the call, putting result into a local variable
673 5) Restore essential registers
674 6) Restore temporaries
676 (This happens after restoration of essential registers because we
677 might need the @Base@ register to access all the others correctly.)
679 Otherwise, copy local variable into result register.
681 8) If ccall (not casm), declare the function being called as extern so
682 that C knows if it returns anything other than an int.
685 { ResultType _ccall_result;
688 _ccall_result = f( args );
692 return_reg = _ccall_result;
696 Amendment to the above: if we can GC, we have to:
698 * make sure we save all our registers away where the garbage collector
700 * be sure that there are no live registers or we're in trouble.
701 (This can cause problems if you try something foolish like passing
702 an array or a foreign obj to a _ccall_GC_ thing.)
703 * increment/decrement the @inCCallGC@ counter before/after the call so
704 that the runtime check that PerformGC is being used sensibly will work.
707 pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
710 declare_local_vars, -- local var for *result*
711 vcat local_arg_decls,
713 declare_fun_extern, -- declare expected function type.
714 process_casm local_vars pp_non_void_args casm_str,
720 (pp_saves, pp_restores) = ppr_vol_regs vol_regs
721 (pp_save_context, pp_restore_context)
722 | may_gc = ( text "do { SaveThreadState();"
723 , text "LoadThreadState();} while(0);"
725 | otherwise = ( pp_basic_saves $$ pp_saves,
726 pp_basic_restores $$ pp_restores)
730 in ASSERT (all non_void nvas) nvas
731 -- the first argument will be the "I/O world" token (a VoidRep)
732 -- all others should be non-void
735 let nvrs = grab_non_void_amodes results
736 in ASSERT (length nvrs <= 1) nvrs
737 -- there will usually be two results: a (void) state which we
738 -- should ignore and a (possibly void) result.
740 (local_arg_decls, pp_non_void_args)
741 = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
745 In the non-casm case, to ensure that we're entering the given external
746 entry point using the correct calling convention, we have to do the following:
748 - When entering via a function pointer (the `dynamic' case) using the specified
749 calling convention, we emit a typedefn declaration attributed with the
750 calling convention to use together with the result and parameter types we're
751 assuming. Coerce the function pointer to this type and go.
753 - to enter the function at a given code label, we emit an extern declaration
754 for the label here, stating the calling convention together with result and
755 argument types we're assuming.
757 The C compiler will hopefully use this extern declaration to good effect,
758 reporting any discrepancies between our extern decl and any other that
761 Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
762 the external function `foo' use the calling convention of the first `foo'
763 prototype it encounters (nor does it complain about conflicting attribute
764 declarations). The consequence of this is that you cannot override the
765 calling convention of `foo' using an extern declaration (you'd have to use
766 a typedef), but why you would want to do such a thing in the first place
767 is totally beyond me.
769 ToDo: petition the gcc folks to add code to warn about conflicting attribute
774 | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
776 hsep [ typedef_or_extern
779 , parens (hsep (punctuate comma ccall_decl_ty_args))
783 | is_dynamic = ptext SLIT("typedef")
784 | otherwise = ptext SLIT("extern")
787 | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
788 | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
790 -- leave out function pointer
792 | is_dynamic = tail ccall_arg_tys
793 | otherwise = ccall_arg_tys
795 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
798 case non_void_results of
799 [] -> ptext SLIT("void")
800 [amode] -> text (showPrimRep (getAmodeRep amode))
801 _ -> panic "pprCCall: ccall_res_ty"
804 ptext SLIT("_ccall_fun_ty") <>
809 (declare_local_vars, local_vars, assign_results)
810 = ppr_casm_results non_void_results
812 (Left asm_str) = op_str
818 casm_str = if is_asm then _UNPK_ asm_str else ccall_str
820 -- Remainder only used for ccall
823 | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
824 | otherwise = ptext asm_str
828 if null non_void_results
831 lparen, fun_name, lparen,
832 hcat (punctuate comma ccall_fun_args),
837 | is_dynamic = tail ccall_args
838 | otherwise = ccall_args
840 ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
844 If the argument is a heap object, we need to reach inside and pull out
845 the bit the C world wants to see. The only heap objects which can be
846 passed are @Array@s and @ByteArray@s.
849 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
850 -- (a) decl and assignment, (b) local var to be used later
852 ppr_casm_arg amode a_num
854 a_kind = getAmodeRep amode
855 pp_amode = pprAmode amode
856 pp_kind = pprPrimKind a_kind
858 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
860 (arg_type, pp_amode2)
863 -- for array arguments, pass a pointer to the body of the array
864 -- (PTRS_ARR_CTS skips over all the header nonsense)
865 ArrayRep -> (pp_kind,
866 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
867 ByteArrayRep -> (pp_kind,
868 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
870 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
871 ForeignObjRep -> (pp_kind,
872 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
873 char '(', pp_amode, char ')'])
875 other -> (pp_kind, pp_amode)
878 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
880 (declare_local_var, local_var)
883 For l-values, the critical questions are:
885 1) Are there any results at all?
887 We only allow zero or one results.
891 :: [CAddrMode] -- list of results (length <= 1)
893 ( SDoc, -- declaration of any local vars
894 [SDoc], -- list of result vars (same length as results)
895 SDoc ) -- assignment (if any) of results in local var to registers
898 = (empty, [], empty) -- no results
902 result_reg = ppr_amode r
903 r_kind = getAmodeRep r
905 local_var = ptext SLIT("_ccall_result")
907 (result_type, assign_result)
908 = (pprPrimKind r_kind,
909 hcat [ result_reg, equals, local_var, semi ])
911 declare_local_var = hcat [ result_type, space, local_var, semi ]
913 (declare_local_var, [local_var], assign_result)
916 = panic "ppr_casm_results: ccall/casm with many results"
920 Note the sneaky way _the_ result is represented by a list so that we
921 can complain if it's used twice.
923 ToDo: Any chance of giving line numbers when process-casm fails?
924 Or maybe we should do a check _much earlier_ in compiler. ADR
927 process_casm :: [SDoc] -- results (length <= 1)
928 -> [SDoc] -- arguments
929 -> String -- format string (with embedded %'s)
930 -> SDoc -- code being generated
932 process_casm results args string = process results args string
934 process [] _ "" = empty
935 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
937 "\"\n(Try changing result type to PrimIO ()\n")
939 process ress args ('%':cs)
942 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
945 char '%' <> process ress args css
949 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
950 [r] -> r <> (process [] args css)
951 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
955 read_int :: ReadS Int
958 case (read_int other) of
960 if 0 <= num && num < length args
961 then parens (args !! num) <> process ress args css
962 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
963 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
965 process ress args (other_c:cs)
966 = char other_c <> process ress args cs
969 %************************************************************************
971 \subsection[a2r-assignments]{Assignments}
973 %************************************************************************
975 Printing assignments is a little tricky because of type coercion.
977 First of all, the kind of the thing being assigned can be gotten from
978 the destination addressing mode. (It should be the same as the kind
979 of the source addressing mode.) If the kind of the assignment is of
980 @VoidRep@, then don't generate any code at all.
983 pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
985 pprAssign VoidRep dest src = empty
988 Special treatment for floats and doubles, to avoid unwanted conversions.
991 pprAssign FloatRep dest@(CVal reg_rel _) src
992 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
994 pprAssign DoubleRep dest@(CVal reg_rel _) src
995 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
997 pprAssign Int64Rep dest@(CVal reg_rel _) src
998 = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
999 pprAssign Word64Rep dest@(CVal reg_rel _) src
1000 = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
1003 Lastly, the question is: will the C compiler think the types of the
1004 two sides of the assignment match?
1006 We assume that the types will match
1007 if neither side is a @CVal@ addressing mode for any register
1008 which can point into the heap or B stack.
1010 Why? Because the heap and B stack are used to store miscellaneous things,
1011 whereas the A stack, temporaries, registers, etc., are only used for things
1015 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
1016 = hcat [ pprVanillaReg dest, equals,
1017 pprVanillaReg src, semi ]
1019 pprAssign kind dest src
1020 | mixedTypeLocn dest
1021 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
1022 = hcat [ ppr_amode dest, equals,
1023 text "(W_)(", -- Here is the cast
1024 ppr_amode src, pp_paren_semi ]
1026 pprAssign kind dest src
1027 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
1028 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
1029 = hcat [ ppr_amode dest, equals,
1030 text "(P_)(", -- Here is the cast
1031 ppr_amode src, pp_paren_semi ]
1033 pprAssign ByteArrayRep dest src
1035 -- Add in a cast iff the source is mixed
1036 = hcat [ ppr_amode dest, equals,
1037 text "(StgByteArray)(", -- Here is the cast
1038 ppr_amode src, pp_paren_semi ]
1040 pprAssign kind other_dest src
1041 = hcat [ ppr_amode other_dest, equals,
1042 pprAmode src, semi ]
1046 %************************************************************************
1048 \subsection[a2r-CAddrModes]{Addressing modes}
1050 %************************************************************************
1052 @pprAmode@ is used to print r-values (which may need casts), whereas
1053 @ppr_amode@ is used for l-values {\em and} as a help function for
1057 pprAmode, ppr_amode :: CAddrMode -> SDoc
1060 For reasons discussed above under assignments, @CVal@ modes need
1061 to be treated carefully. First come special cases for floats and doubles,
1062 similar to those in @pprAssign@:
1064 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
1068 pprAmode (CVal reg_rel FloatRep)
1069 = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
1070 pprAmode (CVal reg_rel DoubleRep)
1071 = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
1072 pprAmode (CVal reg_rel Int64Rep)
1073 = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
1074 pprAmode (CVal reg_rel Word64Rep)
1075 = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
1078 Next comes the case where there is some other cast need, and the
1083 | mixedTypeLocn amode
1084 = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
1086 | otherwise -- No cast needed
1090 Now the rest of the cases for ``workhorse'' @ppr_amode@:
1093 ppr_amode (CVal reg_rel _)
1094 = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1095 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
1096 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
1098 ppr_amode (CAddr reg_rel)
1099 = case (pprRegRelative True{-sign wanted-} reg_rel) of
1100 (pp_reg, Nothing) -> pp_reg
1101 (pp_reg, Just offset) -> (<>) pp_reg offset
1103 ppr_amode (CReg magic_id) = pprMagicId magic_id
1105 ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
1107 ppr_amode (CLbl label kind) = pprCLabelAddr label
1109 ppr_amode (CCharLike ch)
1110 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
1111 ppr_amode (CIntLike int)
1112 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
1114 ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
1115 -- ToDo: are these *used* for anything?
1117 ppr_amode (CLit lit) = pprBasicLit lit
1119 ppr_amode (CLitLit str _) = ptext str
1121 ppr_amode (CJoinPoint _)
1122 = panic "ppr_amode: CJoinPoint"
1124 ppr_amode (CTableEntry base index kind)
1125 = hcat [text "((", pprPrimKind kind, text " *)(",
1126 ppr_amode base, text "))[(I_)(", ppr_amode index,
1129 ppr_amode (CMacroExpr pk macro as)
1130 = parens (pprPrimKind pk) <+>
1131 parens (text (show macro) <>
1132 parens (hcat (punctuate comma (map pprAmode as))))
1135 %************************************************************************
1137 \subsection[ppr-liveness-masks]{Liveness Masks}
1139 %************************************************************************
1142 pp_liveness :: Liveness -> SDoc
1145 LvSmall mask -> int (intBS mask)
1146 LvLarge lbl -> char '&' <> pprCLabel lbl
1149 %************************************************************************
1151 \subsection[a2r-MagicIds]{Magic ids}
1153 %************************************************************************
1155 @pprRegRelative@ returns a pair of the @Doc@ for the register
1156 (some casting may be required), and a @Maybe Doc@ for the offset
1157 (zero offset gives a @Nothing@).
1160 addPlusSign :: Bool -> SDoc -> SDoc
1161 addPlusSign False p = p
1162 addPlusSign True p = (<>) (char '+') p
1164 pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0
1165 pprSignedInt sign_wanted n
1166 = if n == 0 then Nothing else
1167 if n > 0 then Just (addPlusSign sign_wanted (int n))
1170 pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve)
1172 -> (SDoc, Maybe SDoc)
1174 pprRegRelative sign_wanted (SpRel off)
1175 = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
1177 pprRegRelative sign_wanted r@(HpRel o)
1178 = let pp_Hp = pprMagicId Hp; off = I# o
1183 (pp_Hp, Just ((<>) (char '-') (int off)))
1185 pprRegRelative sign_wanted (NodeRel o)
1186 = let pp_Node = pprMagicId node; off = I# o
1191 (pp_Node, Just (addPlusSign sign_wanted (int off)))
1195 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1196 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1197 to select the union tag.
1200 pprMagicId :: MagicId -> SDoc
1202 pprMagicId BaseReg = ptext SLIT("BaseReg")
1203 pprMagicId (VanillaReg pk n)
1204 = hcat [ pprVanillaReg n, char '.',
1206 pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
1207 pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
1208 pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
1209 pprMagicId Sp = ptext SLIT("Sp")
1210 pprMagicId Su = ptext SLIT("Su")
1211 pprMagicId SpLim = ptext SLIT("SpLim")
1212 pprMagicId Hp = ptext SLIT("Hp")
1213 pprMagicId HpLim = ptext SLIT("HpLim")
1214 pprMagicId CurCostCentre = ptext SLIT("CCCS")
1215 pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
1217 pprVanillaReg :: FAST_INT -> SDoc
1218 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1220 pprUnionTag :: PrimRep -> SDoc
1222 pprUnionTag PtrRep = char 'p'
1223 pprUnionTag CodePtrRep = ptext SLIT("fp")
1224 pprUnionTag DataPtrRep = char 'd'
1225 pprUnionTag RetRep = char 'p'
1226 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1228 pprUnionTag CharRep = char 'c'
1229 pprUnionTag IntRep = char 'i'
1230 pprUnionTag WordRep = char 'w'
1231 pprUnionTag AddrRep = char 'a'
1232 pprUnionTag FloatRep = char 'f'
1233 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1235 pprUnionTag StablePtrRep = char 'i'
1236 pprUnionTag WeakPtrRep = char 'p'
1237 pprUnionTag ForeignObjRep = char 'p'
1239 pprUnionTag ThreadIdRep = char 't'
1241 pprUnionTag ArrayRep = char 'p'
1242 pprUnionTag ByteArrayRep = char 'b'
1244 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1248 Find and print local and external declarations for a list of
1249 Abstract~C statements.
1251 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1252 pprTempAndExternDecls AbsCNop = (empty, empty)
1254 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1255 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1256 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1257 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1258 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1259 returnTE (vcat real_temps, vcat real_exts) }}
1262 pprTempAndExternDecls other_stmt
1263 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1274 pprBasicLit :: Literal -> SDoc
1275 pprPrimKind :: PrimRep -> SDoc
1277 pprBasicLit lit = ppr lit
1278 pprPrimKind k = ppr k
1282 %************************************************************************
1284 \subsection[a2r-monad]{Monadery}
1286 %************************************************************************
1288 We need some monadery to keep track of temps and externs we have already
1289 printed. This info must be threaded right through the Abstract~C, so
1290 it's most convenient to hide it in this monad.
1292 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1293 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1296 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1297 emptyCLabelSet = emptyFM
1298 x `elementOfCLabelSet` labs
1299 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1301 addToCLabelSet set x = addToFM set x ()
1303 type TEenv = (UniqSet Unique, CLabelSet)
1305 type TeM result = TEenv -> (TEenv, result)
1307 initTE :: TeM a -> a
1309 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1312 {-# INLINE thenTE #-}
1313 {-# INLINE returnTE #-}
1315 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1317 = case a u of { (u_1, result_of_a) ->
1320 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1321 mapTE f [] = returnTE []
1323 = f x `thenTE` \ r ->
1324 mapTE f xs `thenTE` \ rs ->
1327 returnTE :: a -> TeM a
1328 returnTE result env = (env, result)
1330 -- these next two check whether the thing is already
1331 -- recorded, and THEN THEY RECORD IT
1332 -- (subsequent calls will return False for the same uniq/label)
1334 tempSeenTE :: Unique -> TeM Bool
1335 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1336 = if (uniq `elementOfUniqSet` seen_uniqs)
1338 else ((addOneToUniqSet seen_uniqs uniq,
1342 labelSeenTE :: CLabel -> TeM Bool
1343 labelSeenTE label env@(seen_uniqs, seen_labels)
1344 = if (label `elementOfCLabelSet` seen_labels)
1347 addToCLabelSet seen_labels label),
1352 pprTempDecl :: Unique -> PrimRep -> SDoc
1353 pprTempDecl uniq kind
1354 = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
1356 pprExternDecl :: CLabel -> PrimRep -> SDoc
1358 pprExternDecl clabel kind
1359 = if not (needsCDecl clabel) then
1360 empty -- do not print anything for "known external" things
1362 hcat [ ppLocalnessMacro clabel,
1363 lparen, pprCLabel clabel, pp_paren_semi ]
1367 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1369 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1371 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1372 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1373 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1374 returnTE (maybe_vcat [p1, p2])
1376 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1378 ppr_decls_AbsC (CAssign dest source)
1379 = ppr_decls_Amode dest `thenTE` \ p1 ->
1380 ppr_decls_Amode source `thenTE` \ p2 ->
1381 returnTE (maybe_vcat [p1, p2])
1383 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1385 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1387 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1389 ppr_decls_AbsC (CSwitch discrim alts deflt)
1390 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1391 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1392 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1393 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1395 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1397 ppr_decls_AbsC (CCodeBlock label absC)
1398 = ppr_decls_AbsC absC
1400 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
1401 -- ToDo: strictly speaking, should chk "cost_centre" amode
1402 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1407 Just (pprExternDecl info_lbl PtrRep))
1409 info_lbl = infoTableLabelFromCI cl_info
1411 ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
1412 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1414 ppr_decls_AbsC (CCheck _ amodes code) =
1415 ppr_decls_Amodes amodes `thenTE` \p1 ->
1416 ppr_decls_AbsC code `thenTE` \p2 ->
1417 returnTE (maybe_vcat [p1,p2])
1419 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1421 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1422 -- you get some nasty re-decls of stdio.h if you compile
1423 -- the prelude while looking inside those amodes;
1424 -- no real reason to, anyway.
1425 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1427 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1428 -- ToDo: strictly speaking, should chk "cost_centre" amode
1429 = ppr_decls_Amodes amodes
1431 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
1432 = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
1433 ppr_decls_AbsC slow `thenTE` \ p2 ->
1435 Nothing -> returnTE (Nothing, Nothing)
1436 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1437 returnTE (maybe_vcat [p1, p2, p3])
1439 entry_lbl = CLbl slow_lbl CodePtrRep
1440 slow_lbl = case (nonemptyAbsC slow) of
1441 Nothing -> mkErrorStdEntryLabel
1442 Just _ -> entryLabelFromCI cl_info
1444 ppr_decls_AbsC (CSRT lbl closure_lbls)
1445 = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
1447 if and seen then Nothing
1448 else Just (vcat [ pprExternDecl l PtrRep
1449 | (l,False) <- zip closure_lbls seen ]))
1451 ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
1452 ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
1456 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1457 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1458 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1459 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1460 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1461 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1462 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1464 -- CIntLike must be a literal -- no decls
1465 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1467 -- CCharLike may have be arbitrary value -- may have decls
1468 ppr_decls_Amode (CCharLike char)
1469 = ppr_decls_Amode char
1471 -- now, the only place where we actually print temps/externs...
1472 ppr_decls_Amode (CTemp uniq kind)
1474 VoidRep -> returnTE (Nothing, Nothing)
1476 tempSeenTE uniq `thenTE` \ temp_seen ->
1478 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1480 ppr_decls_Amode (CLbl label VoidRep)
1481 = returnTE (Nothing, Nothing)
1483 ppr_decls_Amode (CLbl label kind)
1484 = labelSeenTE label `thenTE` \ label_seen ->
1486 if label_seen then Nothing else Just (pprExternDecl label kind))
1488 ppr_decls_Amode (CTableEntry base index _)
1489 = ppr_decls_Amode base `thenTE` \ p1 ->
1490 ppr_decls_Amode index `thenTE` \ p2 ->
1491 returnTE (maybe_vcat [p1, p2])
1493 ppr_decls_Amode (CMacroExpr _ _ amodes)
1494 = ppr_decls_Amodes amodes
1496 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1499 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1501 = case (unzip ps) of { (ts, es) ->
1502 case (catMaybes ts) of { real_ts ->
1503 case (catMaybes es) of { real_es ->
1504 (if (null real_ts) then Nothing else Just (vcat real_ts),
1505 if (null real_es) then Nothing else Just (vcat real_es))
1510 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1511 ppr_decls_Amodes amodes
1512 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1513 returnTE ( maybe_vcat ps )
1516 Print out a C Label where you want the *address* of the label, not the
1517 object it refers to. The distinction is important when the label may
1518 refer to a C structure (info tables and closures, for instance).
1520 When just generating a declaration for the label, use pprCLabel.
1523 pprCLabelAddr :: CLabel -> SDoc
1524 pprCLabelAddr clabel =
1525 case labelType clabel of
1526 InfoTblType -> addr_of_label
1527 ClosureType -> addr_of_label
1528 VecTblType -> addr_of_label
1531 addr_of_label = ptext SLIT("(P_)&") <> pp_label
1532 pp_label = pprCLabel clabel
1535 -----------------------------------------------------------------------------
1536 Initialising static objects with floating-point numbers. We can't
1537 just emit the floating point number, because C will cast it to an int
1538 by rounding it. We want the actual bit-representation of the float.
1540 This is a hack to turn the floating point numbers into ints that we
1541 can safely initialise to static locations.
1544 big_doubles = (getPrimRepSize DoubleRep) /= 1
1546 -- floatss are always 1 word
1547 floatToWord :: CAddrMode -> CAddrMode
1548 floatToWord (CLit (MachFloat r))
1550 arr <- newFloatArray (0,0)
1551 writeFloatArray arr 0 (fromRational r)
1552 i <- readIntArray arr 0
1553 return (CLit (MachInt (toInteger i) True))
1556 doubleToWords :: CAddrMode -> [CAddrMode]
1557 doubleToWords (CLit (MachDouble r))
1558 | big_doubles -- doubles are 2 words
1560 arr <- newDoubleArray (0,1)
1561 writeDoubleArray arr 0 (fromRational r)
1562 i1 <- readIntArray arr 0
1563 i2 <- readIntArray arr 1
1564 return [ CLit (MachInt (toInteger i1) True)
1565 , CLit (MachInt (toInteger i2) True)
1568 | otherwise -- doubles are 1 word
1570 arr <- newDoubleArray (0,0)
1571 writeDoubleArray arr 0 (fromRational r)
1572 i <- readIntArray arr 0
1573 return [ CLit (MachInt (toInteger i) True) ]