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 ( pprSMRep )
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 -- What problem is the re-ordering trying to solve ?
174 pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
175 (tag2@(MachInt i2 _), alt_code2)] deflt) c
176 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
178 do_if_stmt discrim tag1 alt_code1 alt_code2 c
180 do_if_stmt discrim tag2 alt_code2 alt_code1 c
182 empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
184 pprAbsC (CSwitch discrim alts deflt) c -- general case
185 | isFloatingRep (getAmodeRep discrim)
186 = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
189 hcat [text "switch (", pp_discrim, text ") {"],
190 nest 2 (vcat (map ppr_alt alts)),
191 (case (nonemptyAbsC deflt) of
194 nest 2 (vcat [ptext SLIT("default:"),
195 pprAbsC dc (c + switch_head_cost
197 ptext SLIT("break;")])),
204 = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
205 nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
206 (ptext SLIT("break;"))) ]
208 -- Costs for addressing header of switch and cond. branching -- HWL
209 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 args vol_regs) _
216 non_void_args = grab_non_void_amodes args
217 non_void_results = grab_non_void_amodes results
218 -- if just one result, we print in the obvious "assignment" style;
219 -- if 0 or many results, we emit a macro call, w/ the results
220 -- followed by the arguments. The macro presumably knows which
223 the_op = ppr_op_call non_void_results non_void_args
224 -- liveness mask is *in* the non_void_args
226 case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
227 if primOpNeedsWrapper op then
236 ppr_op_call results args
237 = hcat [ pprPrimOp op, lparen,
238 hcat (punctuate comma (map ppr_op_result results)),
239 if null results || null args then empty else comma,
240 hcat (punctuate comma (map pprAmode args)),
243 ppr_op_result r = ppr_amode r
244 -- primop macros do their own casting of result;
245 -- hence we can toss the provided cast...
247 pprAbsC stmt@(CSRT lbl closures) c
248 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
250 $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
251 $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
254 where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
256 pprAbsC stmt@(CBitmap lbl mask) c
258 hcat [ ptext SLIT("BITMAP"), lparen,
259 pprCLabel lbl, comma,
262 hcat (punctuate comma (map (int.intBS) mask)),
266 pprAbsC (CSimultaneous abs_c) c
267 = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
269 pprAbsC (CCheck macro as code) c
270 = hcat [text (show macro), lparen,
271 hcat (punctuate comma (map ppr_amode as)), comma,
272 pprAbsC code c, pp_paren_semi
274 pprAbsC (CMacroStmt macro as) _
275 = hcat [text (show macro), lparen,
276 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
277 pprAbsC (CCallProfCtrMacro op as) _
278 = hcat [ptext op, lparen,
279 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
280 pprAbsC (CCallProfCCMacro op as) _
281 = hcat [ptext op, lparen,
282 hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
283 pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
284 = hsep [ ptext SLIT("typedef")
287 , parens (hsep (punctuate comma ccall_decl_ty_args))
290 fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
294 Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
297 case non_void_results of
298 [] -> ptext SLIT("void")
299 [amode] -> text (showPrimRep (getAmodeRep amode))
300 _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
302 ccall_decl_ty_args = tail ccall_arg_tys
303 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
305 -- the first argument will be the "I/O world" token (a VoidRep)
306 -- all others should be non-void
309 in ASSERT (all non_void nvas) nvas
311 -- there will usually be two results: a (void) state which we
312 -- should ignore and a (possibly void) result.
314 let nvrs = grab_non_void_amodes results
315 in ASSERT (length nvrs <= 1) nvrs
317 pprAbsC (CCodeBlock label abs_C) _
318 = if not (maybeToBool(nonemptyAbsC abs_C)) then
319 pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
321 case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
323 hcat [text (if (externallyVisibleCLabel label)
324 then "FN_(" -- abbreviations to save on output
326 pprCLabel label, text ") {"],
330 nest 8 (ptext SLIT("FB_")),
331 nest 8 (pprAbsC abs_C (costs abs_C)),
332 nest 8 (ptext SLIT("FE_")),
337 pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
338 = hcat [ ptext SLIT("SET_HDR_"), char '(',
339 ppr_amode (CAddr reg_rel), comma,
340 pprCLabelAddr info_lbl, comma,
341 if_profiling (pprAmode cost_centre),
344 info_lbl = infoTableLabelFromCI cl_info
346 pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
347 = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
351 ptext SLIT("SET_STATIC_HDR"), char '(',
352 pprCLabel closure_lbl, comma,
353 pprCLabel info_lbl, comma,
354 if_profiling (pprAmode cost_centre), comma,
355 ppLocalness closure_lbl, comma,
356 ppLocalnessMacro info_lbl,
359 nest 2 (ppr_payload (amodes ++ padding_wds)),
363 info_lbl = infoTableLabelFromCI cl_info
365 ppr_payload [] = empty
366 ppr_payload ls = comma <+>
367 braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
370 | rep == VoidRep = text "0" -- might not even need this...
371 | rep == FloatRep = ppr_amode (floatToWord item)
372 | rep == DoubleRep = hcat (punctuate (text ", (L_)")
373 (map ppr_amode (doubleToWords item)))
374 | otherwise = ppr_amode item
376 rep = getAmodeRep item
378 -- always at least one padding word: this is the static link field for
379 -- the garbage collector.
381 if not (closureUpdReqd cl_info) then
384 case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
385 nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
387 pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
390 ptext SLIT("INFO_TABLE"),
391 ( if is_selector then
392 ptext SLIT("_SELECTOR")
393 else if is_constr then
394 ptext SLIT("_CONSTR")
395 else if needs_srt then
397 else empty ), char '(',
399 pprCLabel info_lbl, comma,
400 pprCLabel slow_lbl, comma,
401 pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
403 ppLocalness info_lbl, comma,
404 ppLocalnessMacro slow_lbl, comma,
406 if_profiling pp_descr, comma,
407 if_profiling pp_type,
413 Just fast -> let stuff = CCodeBlock fast_lbl fast in
414 pprAbsC stuff (costs stuff)
417 info_lbl = infoTableLabelFromCI cl_info
418 fast_lbl = fastLabelFromCI cl_info
421 = case (nonemptyAbsC slow) of
422 Nothing -> (mkErrorStdEntryLabel, empty)
423 Just xx -> (entryLabelFromCI cl_info,
424 let stuff = CCodeBlock slow_lbl xx in
425 pprAbsC stuff (costs stuff))
427 maybe_selector = maybeSelectorInfo cl_info
428 is_selector = maybeToBool maybe_selector
429 (Just select_word_i) = maybe_selector
431 maybe_tag = closureSemiTag cl_info
432 is_constr = maybeToBool maybe_tag
433 (Just tag) = maybe_tag
435 needs_srt = has_srt srt && needsSRT cl_info
437 size = closureNonHdrSize cl_info
439 ptrs = closurePtrsSize cl_info
442 pp_rest | is_selector = int select_word_i
447 hcat [ int tag, comma ]
448 else if needs_srt then
453 type_str = pprSMRep (closureSMRep cl_info)
455 pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
456 pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
458 pprAbsC stmt@(CRetDirect uniq code srt liveness) _
461 ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
462 pprCLabel info_lbl, comma,
463 pprCLabel entry_lbl, comma,
464 pp_liveness liveness, comma, -- bitmap
465 pp_srt_info srt, -- SRT
466 ptext type_str, comma, -- closure type
467 ppLocalness info_lbl, comma, -- info table storage class
468 ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
475 info_lbl = mkReturnInfoLabel uniq
476 entry_lbl = mkReturnPtLabel uniq
478 pp_code = let stuff = CCodeBlock entry_lbl code in
479 pprAbsC stuff (costs stuff)
481 type_str = case liveness of
482 LvSmall _ -> SLIT("RET_SMALL")
483 LvLarge _ -> SLIT("RET_BIG")
485 pprAbsC stmt@(CRetVector label amodes srt liveness) _
489 ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
491 pp_liveness liveness, comma, -- bitmap liveness mask
492 pp_srt_info srt, -- SRT
493 ptext type_str, -- or big, depending on the size
494 -- of the liveness mask.
502 case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
505 hcat [ppLocalness label,
506 ptext SLIT(" vec_info_"), int size, space,
507 pprCLabel label, text "= { {"
509 nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
512 ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
515 type_str = case liveness of
516 LvSmall _ -> SLIT("RET_VEC_SMALL")
517 LvLarge _ -> SLIT("RET_VEC_BIG")
520 pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
521 pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
528 static = if (externallyVisibleCLabel label)
530 else ptext SLIT("static ")
531 const = if not (isReadOnly label)
533 else ptext SLIT("const")
535 -- Horrible macros for declaring the types and locality of labels (see
538 ppLocalnessMacro clabel =
540 char (if externallyVisibleCLabel clabel then 'E' else 'I'),
541 case labelType clabel of
542 InfoTblType -> ptext SLIT("I_")
543 ClosureType -> ptext SLIT("C_")
544 CodeType -> ptext SLIT("F_")
545 DataType -> ptext SLIT("D_") <>
547 then ptext SLIT("RO_")
555 grab_non_void_amodes amodes
556 = filter non_void amodes
559 = case (getAmodeRep amode) of
565 ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
567 ppr_vol_regs [] = (empty, empty)
568 ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
570 = let pp_reg = case r of
571 VanillaReg pk n -> pprVanillaReg n
573 (more_saves, more_restores) = ppr_vol_regs rs
575 (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
576 ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
578 -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
579 -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
580 -- depending on the platform. (The "volatile regs" stuff handles all
581 -- other registers.) Just be *sure* BaseReg is OK before trying to do
582 -- anything else. The correct sequence of saves&restores are
583 -- encoded by the CALLER_*_SYSTEM macros.
586 [ ptext SLIT("CALLER_SAVE_Base")
587 , ptext SLIT("CALLER_SAVE_SYSTEM")
590 pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
594 has_srt (_, NoSRT) = False
603 (lbl, SRT off len) ->
604 hcat [ pprCLabel lbl, comma,
611 = if opt_SccProfilingOn
613 else char '0' -- leave it out!
614 -- ---------------------------------------------------------------------------
615 -- Changes for GrAnSim:
616 -- draw costs for computation in head of if into both branches;
617 -- as no abstractC data structure is given for the head, one is constructed
618 -- guessing unknown values and fed into the costs function
619 -- ---------------------------------------------------------------------------
621 do_if_stmt discrim tag alt_code deflt c
623 -- This special case happens when testing the result of a comparison.
624 -- We can just avoid some redundant clutter in the output.
625 MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
627 (addrModeCosts discrim Rhs) c
629 cond = hcat [ pprAmode discrim
632 , pprAmode (CLit tag)
634 -- to be absolutely sure that none of the
635 -- conversion rules hit, e.g.,
637 -- minInt is different to (int)minInt
639 -- in C (when minInt is a number not a constant
640 -- expression which evaluates to it.)
644 MachInt _ signed | signed -> ptext SLIT("(I_)")
649 (addrModeCosts discrim Rhs) c
651 ppr_if_stmt pp_pred then_part else_part discrim_costs c
653 hcat [text "if (", pp_pred, text ") {"],
654 nest 8 (pprAbsC then_part (c + discrim_costs +
655 (Cost (0, 2, 0, 0, 0)) +
657 (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
658 nest 8 (pprAbsC else_part (c + discrim_costs +
659 (Cost (0, 1, 0, 0, 0)) +
662 {- Total costs = inherited costs (before if) + costs for accessing discrim
663 + costs for cond branch ( = (0, 1, 0, 0, 0) )
664 + costs for that alternative
668 Historical note: this used to be two separate cases -- one for `ccall'
669 and one for `casm'. To get round a potential limitation to only 10
670 arguments, the numbering of arguments in @process_casm@ was beefed up a
673 Some rough notes on generating code for @CCallOp@:
675 1) Evaluate all arguments and stuff them into registers. (done elsewhere)
676 2) Save any essential registers (heap, stack, etc).
678 ToDo: If stable pointers are in use, these must be saved in a place
679 where the runtime system can get at them so that the Stg world can
680 be restarted during the call.
682 3) Save any temporary registers that are currently in use.
683 4) Do the call, putting result into a local variable
684 5) Restore essential registers
685 6) Restore temporaries
687 (This happens after restoration of essential registers because we
688 might need the @Base@ register to access all the others correctly.)
690 Otherwise, copy local variable into result register.
692 8) If ccall (not casm), declare the function being called as extern so
693 that C knows if it returns anything other than an int.
696 { ResultType _ccall_result;
699 _ccall_result = f( args );
703 return_reg = _ccall_result;
707 Amendment to the above: if we can GC, we have to:
709 * make sure we save all our registers away where the garbage collector
711 * be sure that there are no live registers or we're in trouble.
712 (This can cause problems if you try something foolish like passing
713 an array or a foreign obj to a _ccall_GC_ thing.)
714 * increment/decrement the @inCCallGC@ counter before/after the call so
715 that the runtime check that PerformGC is being used sensibly will work.
718 pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
721 declare_local_vars, -- local var for *result*
722 vcat local_arg_decls,
724 declare_fun_extern, -- declare expected function type.
725 process_casm local_vars pp_non_void_args casm_str,
731 (pp_saves, pp_restores) = ppr_vol_regs vol_regs
732 (pp_save_context, pp_restore_context)
733 | may_gc = ( text "do { SaveThreadState();"
734 , text "LoadThreadState();} while(0);"
736 | otherwise = ( pp_basic_saves $$ pp_saves,
737 pp_basic_restores $$ pp_restores)
741 in ASSERT (all non_void nvas) nvas
742 -- the first argument will be the "I/O world" token (a VoidRep)
743 -- all others should be non-void
746 let nvrs = grab_non_void_amodes results
747 in ASSERT (length nvrs <= 1) nvrs
748 -- there will usually be two results: a (void) state which we
749 -- should ignore and a (possibly void) result.
751 (local_arg_decls, pp_non_void_args)
752 = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
756 In the non-casm case, to ensure that we're entering the given external
757 entry point using the correct calling convention, we have to do the following:
759 - When entering via a function pointer (the `dynamic' case) using the specified
760 calling convention, we emit a typedefn declaration attributed with the
761 calling convention to use together with the result and parameter types we're
762 assuming. Coerce the function pointer to this type and go.
764 - to enter the function at a given code label, we emit an extern declaration
765 for the label here, stating the calling convention together with result and
766 argument types we're assuming.
768 The C compiler will hopefully use this extern declaration to good effect,
769 reporting any discrepancies between our extern decl and any other that
772 Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
773 the external function `foo' use the calling convention of the first `foo'
774 prototype it encounters (nor does it complain about conflicting attribute
775 declarations). The consequence of this is that you cannot override the
776 calling convention of `foo' using an extern declaration (you'd have to use
777 a typedef), but why you would want to do such a thing in the first place
778 is totally beyond me.
780 ToDo: petition the gcc folks to add code to warn about conflicting attribute
785 | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
787 hsep [ typedef_or_extern
790 , parens (hsep (punctuate comma ccall_decl_ty_args))
794 | is_dynamic = ptext SLIT("typedef")
795 | otherwise = ptext SLIT("extern")
798 | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
799 | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
801 -- leave out function pointer
803 | is_dynamic = tail ccall_arg_tys
804 | otherwise = ccall_arg_tys
806 ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
809 case non_void_results of
810 [] -> ptext SLIT("void")
811 [amode] -> text (showPrimRep (getAmodeRep amode))
812 _ -> panic "pprCCall: ccall_res_ty"
815 ptext SLIT("_ccall_fun_ty") <>
820 (declare_local_vars, local_vars, assign_results)
821 = ppr_casm_results non_void_results
823 (Left asm_str) = op_str
829 casm_str = if is_asm then _UNPK_ asm_str else ccall_str
831 -- Remainder only used for ccall
834 | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
835 | otherwise = ptext asm_str
839 if null non_void_results
842 lparen, fun_name, lparen,
843 hcat (punctuate comma ccall_fun_args),
848 | is_dynamic = tail ccall_args
849 | otherwise = ccall_args
851 ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
855 If the argument is a heap object, we need to reach inside and pull out
856 the bit the C world wants to see. The only heap objects which can be
857 passed are @Array@s and @ByteArray@s.
860 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
861 -- (a) decl and assignment, (b) local var to be used later
863 ppr_casm_arg amode a_num
865 a_kind = getAmodeRep amode
866 pp_amode = pprAmode amode
867 pp_kind = pprPrimKind a_kind
869 local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
871 (arg_type, pp_amode2)
874 -- for array arguments, pass a pointer to the body of the array
875 -- (PTRS_ARR_CTS skips over all the header nonsense)
876 ArrayRep -> (pp_kind,
877 hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
878 ByteArrayRep -> (pp_kind,
879 hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
881 -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
882 ForeignObjRep -> (pp_kind,
883 hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
884 char '(', pp_amode, char ')'])
886 other -> (pp_kind, pp_amode)
889 = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
891 (declare_local_var, local_var)
894 For l-values, the critical questions are:
896 1) Are there any results at all?
898 We only allow zero or one results.
902 :: [CAddrMode] -- list of results (length <= 1)
904 ( SDoc, -- declaration of any local vars
905 [SDoc], -- list of result vars (same length as results)
906 SDoc ) -- assignment (if any) of results in local var to registers
909 = (empty, [], empty) -- no results
913 result_reg = ppr_amode r
914 r_kind = getAmodeRep r
916 local_var = ptext SLIT("_ccall_result")
918 (result_type, assign_result)
919 = (pprPrimKind r_kind,
920 hcat [ result_reg, equals, local_var, semi ])
922 declare_local_var = hcat [ result_type, space, local_var, semi ]
924 (declare_local_var, [local_var], assign_result)
927 = panic "ppr_casm_results: ccall/casm with many results"
931 Note the sneaky way _the_ result is represented by a list so that we
932 can complain if it's used twice.
934 ToDo: Any chance of giving line numbers when process-casm fails?
935 Or maybe we should do a check _much earlier_ in compiler. ADR
938 process_casm :: [SDoc] -- results (length <= 1)
939 -> [SDoc] -- arguments
940 -> String -- format string (with embedded %'s)
941 -> SDoc -- code being generated
943 process_casm results args string = process results args string
945 process [] _ "" = empty
946 process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
948 "\"\n(Try changing result type to PrimIO ()\n")
950 process ress args ('%':cs)
953 error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
956 char '%' <> process ress args css
960 [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
961 [r] -> r <> (process [] args css)
962 _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
966 read_int :: ReadS Int
969 case (read_int other) of
971 if 0 <= num && num < length args
972 then parens (args !! num) <> process ress args css
973 else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
974 _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
976 process ress args (other_c:cs)
977 = char other_c <> process ress args cs
980 %************************************************************************
982 \subsection[a2r-assignments]{Assignments}
984 %************************************************************************
986 Printing assignments is a little tricky because of type coercion.
988 First of all, the kind of the thing being assigned can be gotten from
989 the destination addressing mode. (It should be the same as the kind
990 of the source addressing mode.) If the kind of the assignment is of
991 @VoidRep@, then don't generate any code at all.
994 pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
996 pprAssign VoidRep dest src = empty
999 Special treatment for floats and doubles, to avoid unwanted conversions.
1002 pprAssign FloatRep dest@(CVal reg_rel _) src
1003 = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
1005 pprAssign DoubleRep dest@(CVal reg_rel _) src
1006 = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
1008 pprAssign Int64Rep dest@(CVal reg_rel _) src
1009 = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
1010 pprAssign Word64Rep dest@(CVal reg_rel _) src
1011 = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
1014 Lastly, the question is: will the C compiler think the types of the
1015 two sides of the assignment match?
1017 We assume that the types will match
1018 if neither side is a @CVal@ addressing mode for any register
1019 which can point into the heap or B stack.
1021 Why? Because the heap and B stack are used to store miscellaneous things,
1022 whereas the A stack, temporaries, registers, etc., are only used for things
1026 pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
1027 = hcat [ pprVanillaReg dest, equals,
1028 pprVanillaReg src, semi ]
1030 pprAssign kind dest src
1031 | mixedTypeLocn dest
1032 -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
1033 = hcat [ ppr_amode dest, equals,
1034 text "(W_)(", -- Here is the cast
1035 ppr_amode src, pp_paren_semi ]
1037 pprAssign kind dest src
1038 | mixedPtrLocn dest && getAmodeRep src /= PtrRep
1039 -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
1040 = hcat [ ppr_amode dest, equals,
1041 text "(P_)(", -- Here is the cast
1042 ppr_amode src, pp_paren_semi ]
1044 pprAssign ByteArrayRep dest src
1046 -- Add in a cast iff the source is mixed
1047 = hcat [ ppr_amode dest, equals,
1048 text "(StgByteArray)(", -- Here is the cast
1049 ppr_amode src, pp_paren_semi ]
1051 pprAssign kind other_dest src
1052 = hcat [ ppr_amode other_dest, equals,
1053 pprAmode src, semi ]
1057 %************************************************************************
1059 \subsection[a2r-CAddrModes]{Addressing modes}
1061 %************************************************************************
1063 @pprAmode@ is used to print r-values (which may need casts), whereas
1064 @ppr_amode@ is used for l-values {\em and} as a help function for
1068 pprAmode, ppr_amode :: CAddrMode -> SDoc
1071 For reasons discussed above under assignments, @CVal@ modes need
1072 to be treated carefully. First come special cases for floats and doubles,
1073 similar to those in @pprAssign@:
1075 (NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
1079 pprAmode (CVal reg_rel FloatRep)
1080 = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
1081 pprAmode (CVal reg_rel DoubleRep)
1082 = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
1083 pprAmode (CVal reg_rel Int64Rep)
1084 = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
1085 pprAmode (CVal reg_rel Word64Rep)
1086 = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
1089 Next comes the case where there is some other cast need, and the
1094 | mixedTypeLocn amode
1095 = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
1097 | otherwise -- No cast needed
1101 Now the rest of the cases for ``workhorse'' @ppr_amode@:
1104 ppr_amode (CVal reg_rel _)
1105 = case (pprRegRelative False{-no sign wanted-} reg_rel) of
1106 (pp_reg, Nothing) -> (<>) (char '*') pp_reg
1107 (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
1109 ppr_amode (CAddr reg_rel)
1110 = case (pprRegRelative True{-sign wanted-} reg_rel) of
1111 (pp_reg, Nothing) -> pp_reg
1112 (pp_reg, Just offset) -> (<>) pp_reg offset
1114 ppr_amode (CReg magic_id) = pprMagicId magic_id
1116 ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
1118 ppr_amode (CLbl label kind) = pprCLabelAddr label
1120 ppr_amode (CCharLike ch)
1121 = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
1122 ppr_amode (CIntLike int)
1123 = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
1125 ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
1126 -- ToDo: are these *used* for anything?
1128 ppr_amode (CLit lit) = pprBasicLit lit
1130 ppr_amode (CLitLit str _) = ptext str
1132 ppr_amode (CJoinPoint _)
1133 = panic "ppr_amode: CJoinPoint"
1135 ppr_amode (CTableEntry base index kind)
1136 = hcat [text "((", pprPrimKind kind, text " *)(",
1137 ppr_amode base, text "))[(I_)(", ppr_amode index,
1140 ppr_amode (CMacroExpr pk macro as)
1141 = parens (pprPrimKind pk) <+>
1142 parens (text (show macro) <>
1143 parens (hcat (punctuate comma (map pprAmode as))))
1146 %************************************************************************
1148 \subsection[ppr-liveness-masks]{Liveness Masks}
1150 %************************************************************************
1153 pp_liveness :: Liveness -> SDoc
1156 LvSmall mask -> int (intBS mask)
1157 LvLarge lbl -> char '&' <> pprCLabel lbl
1160 %************************************************************************
1162 \subsection[a2r-MagicIds]{Magic ids}
1164 %************************************************************************
1166 @pprRegRelative@ returns a pair of the @Doc@ for the register
1167 (some casting may be required), and a @Maybe Doc@ for the offset
1168 (zero offset gives a @Nothing@).
1171 addPlusSign :: Bool -> SDoc -> SDoc
1172 addPlusSign False p = p
1173 addPlusSign True p = (<>) (char '+') p
1175 pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0
1176 pprSignedInt sign_wanted n
1177 = if n == 0 then Nothing else
1178 if n > 0 then Just (addPlusSign sign_wanted (int n))
1181 pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve)
1183 -> (SDoc, Maybe SDoc)
1185 pprRegRelative sign_wanted (SpRel off)
1186 = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
1188 pprRegRelative sign_wanted r@(HpRel o)
1189 = let pp_Hp = pprMagicId Hp; off = I# o
1194 (pp_Hp, Just ((<>) (char '-') (int off)))
1196 pprRegRelative sign_wanted (NodeRel o)
1197 = let pp_Node = pprMagicId node; off = I# o
1202 (pp_Node, Just (addPlusSign sign_wanted (int off)))
1206 @pprMagicId@ just prints the register name. @VanillaReg@ registers are
1207 represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
1208 to select the union tag.
1211 pprMagicId :: MagicId -> SDoc
1213 pprMagicId BaseReg = ptext SLIT("BaseReg")
1214 pprMagicId (VanillaReg pk n)
1215 = hcat [ pprVanillaReg n, char '.',
1217 pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
1218 pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
1219 pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
1220 pprMagicId Sp = ptext SLIT("Sp")
1221 pprMagicId Su = ptext SLIT("Su")
1222 pprMagicId SpLim = ptext SLIT("SpLim")
1223 pprMagicId Hp = ptext SLIT("Hp")
1224 pprMagicId HpLim = ptext SLIT("HpLim")
1225 pprMagicId CurCostCentre = ptext SLIT("CCCS")
1226 pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
1228 pprVanillaReg :: FAST_INT -> SDoc
1229 pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
1231 pprUnionTag :: PrimRep -> SDoc
1233 pprUnionTag PtrRep = char 'p'
1234 pprUnionTag CodePtrRep = ptext SLIT("fp")
1235 pprUnionTag DataPtrRep = char 'd'
1236 pprUnionTag RetRep = char 'p'
1237 pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
1239 pprUnionTag CharRep = char 'c'
1240 pprUnionTag IntRep = char 'i'
1241 pprUnionTag WordRep = char 'w'
1242 pprUnionTag AddrRep = char 'a'
1243 pprUnionTag FloatRep = char 'f'
1244 pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
1246 pprUnionTag StablePtrRep = char 'i'
1247 pprUnionTag StableNameRep = char 'p'
1248 pprUnionTag WeakPtrRep = char 'p'
1249 pprUnionTag ForeignObjRep = char 'p'
1251 pprUnionTag ThreadIdRep = char 't'
1253 pprUnionTag ArrayRep = char 'p'
1254 pprUnionTag ByteArrayRep = char 'b'
1256 pprUnionTag _ = panic "pprUnionTag:Odd kind"
1260 Find and print local and external declarations for a list of
1261 Abstract~C statements.
1263 pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
1264 pprTempAndExternDecls AbsCNop = (empty, empty)
1266 pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
1267 = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
1268 ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
1269 case (catMaybes [t_p1, t_p2]) of { real_temps ->
1270 case (catMaybes [e_p1, e_p2]) of { real_exts ->
1271 returnTE (vcat real_temps, vcat real_exts) }}
1274 pprTempAndExternDecls other_stmt
1275 = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
1286 pprBasicLit :: Literal -> SDoc
1287 pprPrimKind :: PrimRep -> SDoc
1289 pprBasicLit lit = ppr lit
1290 pprPrimKind k = ppr k
1294 %************************************************************************
1296 \subsection[a2r-monad]{Monadery}
1298 %************************************************************************
1300 We need some monadery to keep track of temps and externs we have already
1301 printed. This info must be threaded right through the Abstract~C, so
1302 it's most convenient to hide it in this monad.
1304 WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
1305 \tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
1308 type CLabelSet = FiniteMap CLabel (){-any type will do-}
1309 emptyCLabelSet = emptyFM
1310 x `elementOfCLabelSet` labs
1311 = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
1313 addToCLabelSet set x = addToFM set x ()
1315 type TEenv = (UniqSet Unique, CLabelSet)
1317 type TeM result = TEenv -> (TEenv, result)
1319 initTE :: TeM a -> a
1321 = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
1324 {-# INLINE thenTE #-}
1325 {-# INLINE returnTE #-}
1327 thenTE :: TeM a -> (a -> TeM b) -> TeM b
1329 = case a u of { (u_1, result_of_a) ->
1332 mapTE :: (a -> TeM b) -> [a] -> TeM [b]
1333 mapTE f [] = returnTE []
1335 = f x `thenTE` \ r ->
1336 mapTE f xs `thenTE` \ rs ->
1339 returnTE :: a -> TeM a
1340 returnTE result env = (env, result)
1342 -- these next two check whether the thing is already
1343 -- recorded, and THEN THEY RECORD IT
1344 -- (subsequent calls will return False for the same uniq/label)
1346 tempSeenTE :: Unique -> TeM Bool
1347 tempSeenTE uniq env@(seen_uniqs, seen_labels)
1348 = if (uniq `elementOfUniqSet` seen_uniqs)
1350 else ((addOneToUniqSet seen_uniqs uniq,
1354 labelSeenTE :: CLabel -> TeM Bool
1355 labelSeenTE label env@(seen_uniqs, seen_labels)
1356 = if (label `elementOfCLabelSet` seen_labels)
1359 addToCLabelSet seen_labels label),
1364 pprTempDecl :: Unique -> PrimRep -> SDoc
1365 pprTempDecl uniq kind
1366 = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
1368 pprExternDecl :: CLabel -> PrimRep -> SDoc
1370 pprExternDecl clabel kind
1371 = if not (needsCDecl clabel) then
1372 empty -- do not print anything for "known external" things
1374 hcat [ ppLocalnessMacro clabel,
1375 lparen, pprCLabel clabel, pp_paren_semi ]
1379 ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
1381 ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
1383 ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
1384 = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
1385 ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
1386 returnTE (maybe_vcat [p1, p2])
1388 ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
1390 ppr_decls_AbsC (CAssign dest source)
1391 = ppr_decls_Amode dest `thenTE` \ p1 ->
1392 ppr_decls_Amode source `thenTE` \ p2 ->
1393 returnTE (maybe_vcat [p1, p2])
1395 ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
1397 ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
1399 ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
1401 ppr_decls_AbsC (CSwitch discrim alts deflt)
1402 = ppr_decls_Amode discrim `thenTE` \ pdisc ->
1403 mapTE ppr_alt_stuff alts `thenTE` \ palts ->
1404 ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
1405 returnTE (maybe_vcat (pdisc:pdeflt:palts))
1407 ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
1409 ppr_decls_AbsC (CCodeBlock label absC)
1410 = ppr_decls_AbsC absC
1412 ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
1413 -- ToDo: strictly speaking, should chk "cost_centre" amode
1414 = labelSeenTE info_lbl `thenTE` \ label_seen ->
1419 Just (pprExternDecl info_lbl PtrRep))
1421 info_lbl = infoTableLabelFromCI cl_info
1423 ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
1424 ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
1426 ppr_decls_AbsC (CCheck _ amodes code) =
1427 ppr_decls_Amodes amodes `thenTE` \p1 ->
1428 ppr_decls_AbsC code `thenTE` \p2 ->
1429 returnTE (maybe_vcat [p1,p2])
1431 ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
1433 ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
1434 -- you get some nasty re-decls of stdio.h if you compile
1435 -- the prelude while looking inside those amodes;
1436 -- no real reason to, anyway.
1437 ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
1439 ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
1440 -- ToDo: strictly speaking, should chk "cost_centre" amode
1441 = ppr_decls_Amodes amodes
1443 ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
1444 = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
1445 ppr_decls_AbsC slow `thenTE` \ p2 ->
1447 Nothing -> returnTE (Nothing, Nothing)
1448 Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
1449 returnTE (maybe_vcat [p1, p2, p3])
1451 entry_lbl = CLbl slow_lbl CodePtrRep
1452 slow_lbl = case (nonemptyAbsC slow) of
1453 Nothing -> mkErrorStdEntryLabel
1454 Just _ -> entryLabelFromCI cl_info
1456 ppr_decls_AbsC (CSRT lbl closure_lbls)
1457 = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
1459 if and seen then Nothing
1460 else Just (vcat [ pprExternDecl l PtrRep
1461 | (l,False) <- zip closure_lbls seen ]))
1463 ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
1464 ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
1468 ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
1469 ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
1470 ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
1471 ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
1472 ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
1473 ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
1474 ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
1476 -- CIntLike must be a literal -- no decls
1477 ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
1479 -- CCharLike may have be arbitrary value -- may have decls
1480 ppr_decls_Amode (CCharLike char)
1481 = ppr_decls_Amode char
1483 -- now, the only place where we actually print temps/externs...
1484 ppr_decls_Amode (CTemp uniq kind)
1486 VoidRep -> returnTE (Nothing, Nothing)
1488 tempSeenTE uniq `thenTE` \ temp_seen ->
1490 (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
1492 ppr_decls_Amode (CLbl label VoidRep)
1493 = returnTE (Nothing, Nothing)
1495 ppr_decls_Amode (CLbl label kind)
1496 = labelSeenTE label `thenTE` \ label_seen ->
1498 if label_seen then Nothing else Just (pprExternDecl label kind))
1500 ppr_decls_Amode (CTableEntry base index _)
1501 = ppr_decls_Amode base `thenTE` \ p1 ->
1502 ppr_decls_Amode index `thenTE` \ p2 ->
1503 returnTE (maybe_vcat [p1, p2])
1505 ppr_decls_Amode (CMacroExpr _ _ amodes)
1506 = ppr_decls_Amodes amodes
1508 ppr_decls_Amode other = returnTE (Nothing, Nothing)
1511 maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
1513 = case (unzip ps) of { (ts, es) ->
1514 case (catMaybes ts) of { real_ts ->
1515 case (catMaybes es) of { real_es ->
1516 (if (null real_ts) then Nothing else Just (vcat real_ts),
1517 if (null real_es) then Nothing else Just (vcat real_es))
1522 ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
1523 ppr_decls_Amodes amodes
1524 = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
1525 returnTE ( maybe_vcat ps )
1528 Print out a C Label where you want the *address* of the label, not the
1529 object it refers to. The distinction is important when the label may
1530 refer to a C structure (info tables and closures, for instance).
1532 When just generating a declaration for the label, use pprCLabel.
1535 pprCLabelAddr :: CLabel -> SDoc
1536 pprCLabelAddr clabel =
1537 case labelType clabel of
1538 InfoTblType -> addr_of_label
1539 ClosureType -> addr_of_label
1540 VecTblType -> addr_of_label
1543 addr_of_label = ptext SLIT("(P_)&") <> pp_label
1544 pp_label = pprCLabel clabel
1547 -----------------------------------------------------------------------------
1548 Initialising static objects with floating-point numbers. We can't
1549 just emit the floating point number, because C will cast it to an int
1550 by rounding it. We want the actual bit-representation of the float.
1552 This is a hack to turn the floating point numbers into ints that we
1553 can safely initialise to static locations.
1556 big_doubles = (getPrimRepSize DoubleRep) /= 1
1558 -- floatss are always 1 word
1559 floatToWord :: CAddrMode -> CAddrMode
1560 floatToWord (CLit (MachFloat r))
1562 arr <- newFloatArray (0,0)
1563 writeFloatArray arr 0 (fromRational r)
1564 i <- readIntArray arr 0
1565 return (CLit (MachInt (toInteger i) True))
1568 doubleToWords :: CAddrMode -> [CAddrMode]
1569 doubleToWords (CLit (MachDouble r))
1570 | big_doubles -- doubles are 2 words
1572 arr <- newDoubleArray (0,1)
1573 writeDoubleArray arr 0 (fromRational r)
1574 i1 <- readIntArray arr 0
1575 i2 <- readIntArray arr 1
1576 return [ CLit (MachInt (toInteger i1) True)
1577 , CLit (MachInt (toInteger i2) True)
1580 | otherwise -- doubles are 1 word
1582 arr <- newDoubleArray (0,0)
1583 writeDoubleArray arr 0 (fromRational r)
1584 i <- readIntArray arr 0
1585 return [ CLit (MachInt (toInteger i) True) ]