PprAbsC.lhs 51.8 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7 8 9 10 11 12
%
%************************************************************************
%*									*
\section[PprAbsC]{Pretty-printing Abstract~C}
%*									*
%************************************************************************

\begin{code}
module PprAbsC (
	writeRealC,
13 14 15
	dumpRealC,
	pprAmode,
	pprMagicId
16 17
    ) where

18
#include "HsVersions.h"
sof's avatar
sof committed
19

20
import IO	( Handle )
sof's avatar
sof committed
21

22
import AbsCSyn
sof's avatar
sof committed
23
import ClosureInfo
24 25
import AbsCUtils	( getAmodeRep, nonemptyAbsC,
			  mixedPtrLocn, mixedTypeLocn
26
			)
27 28

import Constants	( mIN_UPD_SIZE )
29
import CallConv		( callConvAttribute )
rrt's avatar
rrt committed
30
import CLabel		( externallyVisibleCLabel,
31
			  needsCDecl, pprCLabel,
32
			  mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
rrt's avatar
rrt committed
33
			  mkClosureLabel, mkErrorStdEntryLabel,
sof's avatar
sof committed
34
			  CLabel, CLabelType(..), labelType, labelDynamic
35
			)
36

37
import CmdLineOpts	( opt_SccProfilingOn, opt_GranMacros )
38 39
import CostCentre	( pprCostCentreDecl, pprCostCentreStackDecl )

40
import Costs		( costs, addrModeCosts, CostRes(..), Side(..) )
41
import CStrings		( stringToC, pprCLabelString )
42
import FiniteMap	( addToFM, emptyFM, lookupFM, FiniteMap )
43
import Literal		( Literal(..) )
44 45
import TyCon		( tyConDataCons )
import Name		( NamedThing(..) )
46
import DataCon		( DataCon{-instance NamedThing-}, dataConWrapId )
47
import Maybes		( maybeToBool, catMaybes )
48
import PrimOp		( primOpNeedsWrapper, pprPrimOp, pprCCallOp, 
49
			  PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
50
import PrimRep		( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
51
import SMRep		( pprSMRep )
52 53
import Unique		( pprUnique, Unique{-instance NamedThing-} )
import UniqSet		( emptyUniqSet, elementOfUniqSet,
54
			  addOneToUniqSet, UniqSet
55
			)
56 57
import StgSyn		( SRT(..) )
import BitSet		( intBS )
58
import Outputable
59
import Util		( nOfThem )
60 61 62

import ST
import MutableArray
63 64 65 66 67 68 69 70 71 72

infixr 9 `thenTE`
\end{code}

For spitting out the costs of an abstract~C expression, @writeRealC@
now not only prints the C~code of the @absC@ arg but also adds a macro
call to a cost evaluation function @GRAN_EXEC@. For that,
@pprAbsC@ has a new ``costs'' argument.  %% HWL

\begin{code}
73 74 75 76 77 78 79 80 81 82 83 84 85 86
{-
writeRealC :: Handle -> AbstractC -> IO ()
writeRealC handle absC
     -- avoid holding on to the whole of absC in the !Gransim case.
     if opt_GranMacros
	then printForCFast fp (pprAbsC absC (costs absC))
	else printForCFast fp (pprAbsC absC (panic "costs"))
	     --printForC handle (pprAbsC absC (panic "costs"))
dumpRealC :: AbstractC -> SDoc
dumpRealC absC = pprAbsC absC (costs absC)
-}

writeRealC :: Handle -> AbstractC -> IO ()
--writeRealC handle absC = 
87 88
-- _scc_ "writeRealC" 
-- printDoc LeftMode handle (pprAbsC absC (costs absC))
89 90 91 92 93 94 95 96 97 98 99 100

writeRealC handle absC
 | opt_GranMacros = _scc_ "writeRealC" printForC handle $ 
				       pprCode CStyle (pprAbsC absC (costs absC))
 | otherwise	  = _scc_ "writeRealC" printForC handle $
				       pprCode CStyle (pprAbsC absC (panic "costs"))

dumpRealC :: AbstractC -> SDoc
dumpRealC absC
 | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
 | otherwise	  = pprCode CStyle (pprAbsC absC (panic "costs"))

101 102 103 104 105 106
\end{code}

This emits the macro,  which is used in GrAnSim  to compute the total costs
from a cost 5 tuple. %%  HWL

\begin{code}
107
emitMacro :: CostRes -> SDoc
108

109 110
emitMacro _ | not opt_GranMacros = empty

111
emitMacro (Cost (i,b,l,s,f))
sof's avatar
sof committed
112 113 114
  = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                          int i, comma, int b, comma, int l, comma,
	                  int s, comma, int f, pp_paren_semi ]
115

sof's avatar
sof committed
116
pp_paren_semi = text ");"
117
\end{code}
118

119 120 121
New type: Now pprAbsC also takes the costs for evaluating the Abstract C
code as an argument (that's needed when spitting out the GRAN_EXEC macro
which must be done before the return i.e. inside absC code)   HWL
122

123
\begin{code}
124 125 126
pprAbsC :: AbstractC -> CostRes -> SDoc
pprAbsC AbsCNop _ = empty
pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
127

128
pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
129

130
pprAbsC (CJump target) c
sof's avatar
sof committed
131
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
132
	     (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
133

134
pprAbsC (CFallThrough target) c
sof's avatar
sof committed
135
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
136
	     (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
137 138

-- --------------------------------------------------------------------------
139
-- Spit out GRAN_EXEC macro immediately before the return                 HWL
140

141
pprAbsC (CReturn am return_info)  c
sof's avatar
sof committed
142 143
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
	     (hcat [text jmp_lit, target, pp_paren_semi ])
144 145
  where
   target = case return_info of
146 147
    	DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
			      pprAmode am, rparen]
148
	DynamicVectoredReturn am' -> mk_vector (pprAmode am')
sof's avatar
sof committed
149
	StaticVectoredReturn n -> mk_vector (int n)	-- Always positive
150
   mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
151
		       x, rparen ]
152

153
pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")
154 155 156 157 158 159 160 161

-- we optimise various degenerate cases of CSwitches.

-- --------------------------------------------------------------------------
-- Assume: CSwitch is also end of basic block
--         costs function yields nullCosts for whole switch
--         ==> inherited costs c are those of basic block up to switch
--         ==> inherit c + costs for the corresponding branch
162
--                                                                       HWL
163 164
-- --------------------------------------------------------------------------

165 166
pprAbsC (CSwitch discrim [] deflt) c
  = pprAbsC deflt (c + costs deflt)
167 168
    -- Empty alternative list => no costs for discrim as nothing cond. here HWL

169
pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
170 171
  = case (nonemptyAbsC deflt) of
      Nothing ->		-- one alt and no default
172
		 pprAbsC alt_code (c + costs alt_code)
173 174 175
		 -- Nothing conditional in here either  HWL

      Just dc ->		-- make it an "if"
176
		 do_if_stmt discrim tag alt_code dc c
177

sof's avatar
sof committed
178
-- What problem is the re-ordering trying to solve ?
179 180
pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
			  (tag2@(MachInt i2), alt_code2)] deflt) c
181 182
  | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
  = if (i1 == 0) then
183
	do_if_stmt discrim tag1 alt_code1 alt_code2 c
184
    else
185
	do_if_stmt discrim tag2 alt_code2 alt_code1 c
186 187 188
  where
    empty_deflt = not (maybeToBool (nonemptyAbsC deflt))

189
pprAbsC (CSwitch discrim alts deflt) c -- general case
190
  | isFloatingRep (getAmodeRep discrim)
191
    = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
192
  | otherwise
sof's avatar
sof committed
193 194
    = vcat [
	hcat [text "switch (", pp_discrim, text ") {"],
195
	nest 2 (vcat (map ppr_alt alts)),
196
	(case (nonemptyAbsC deflt) of
sof's avatar
sof committed
197
	   Nothing -> empty
198
	   Just dc ->
sof's avatar
sof committed
199
	    nest 2 (vcat [ptext SLIT("default:"),
200
				  pprAbsC dc (c + switch_head_cost
201
						    + costs dc),
sof's avatar
sof committed
202 203
				  ptext SLIT("break;")])),
	char '}' ]
204 205
  where
    pp_discrim
206
      = pprAmode discrim
207

208 209 210
    ppr_alt (lit, absC)
      = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
		   nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
sof's avatar
sof committed
211
				       (ptext SLIT("break;"))) ]
212 213 214 215

    -- Costs for addressing header of switch and cond. branching        -- HWL
    switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))

216 217
pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
  = pprCCall ccall args results vol_regs
218

219
pprAbsC stmt@(COpStmt results op args vol_regs) _
220 221
  = let
	non_void_args = grab_non_void_amodes args
222
	non_void_results = grab_non_void_amodes results
223 224 225 226 227 228 229 230 231
	-- if just one result, we print in the obvious "assignment" style;
	-- if 0 or many results, we emit a macro call, w/ the results
	-- followed by the arguments.  The macro presumably knows which
	-- are which :-)

    	the_op = ppr_op_call non_void_results non_void_args
		-- liveness mask is *in* the non_void_args
    in
    if primOpNeedsWrapper op then
232
    	case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
sof's avatar
sof committed
233
    	vcat [  pp_saves,
234 235 236
    	    	the_op,
    	    	pp_restores
    	     ]
237
	}
238 239 240 241
    else
    	the_op
  where
    ppr_op_call results args
242
      = hcat [ pprPrimOp op, lparen,
sof's avatar
sof committed
243 244
	hcat (punctuate comma (map ppr_op_result results)),
	if null results || null args then empty else comma,
245
	hcat (punctuate comma (map pprAmode args)),
246 247
	pp_paren_semi ]

248
    ppr_op_result r = ppr_amode r
249 250 251
      -- primop macros do their own casting of result;
      -- hence we can toss the provided cast...

252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
pprAbsC stmt@(CSRT lbl closures) c
  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
         pp_exts
      $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
      $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
         <> ptext SLIT("};")
  }

pprAbsC stmt@(CBitmap lbl mask) c
  = vcat [
	hcat [ ptext SLIT("BITMAP"), lparen, 
			pprCLabel lbl, comma,
	       		int (length mask), 
	       rparen ],
        hcat (punctuate comma (map (int.intBS) mask)),
	ptext SLIT("}};")
    ]

270 271
pprAbsC (CSimultaneous abs_c) c
  = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
272

273
pprAbsC (CCheck macro as code) c
274
  = hcat [ptext (cCheckMacroText macro), lparen,
275 276 277 278
       hcat (punctuate comma (map ppr_amode as)), comma,
       pprAbsC code c, pp_paren_semi
    ]
pprAbsC (CMacroStmt macro as) _
279
  = hcat [ptext (cStmtMacroText macro), lparen,
280
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
281
pprAbsC (CCallProfCtrMacro op as) _
sof's avatar
sof committed
282
  = hcat [ptext op, lparen,
283
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
284
pprAbsC (CCallProfCCMacro op as) _
sof's avatar
sof committed
285
  = hcat [ptext op, lparen,
286
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
287
pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
sof's avatar
sof committed
288
  =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
sof's avatar
sof committed
289 290 291 292 293
	  , ccall_res_ty
	  , fun_nm
	  , parens (hsep (punctuate comma ccall_decl_ty_args))
	  ] <> semi
    where
sof's avatar
sof committed
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326
    {-
      In the non-casm case, to ensure that we're entering the given external
      entry point using the correct calling convention, we have to do the following:

	- When entering via a function pointer (the `dynamic' case) using the specified
	  calling convention, we emit a typedefn declaration attributed with the
	  calling convention to use together with the result and parameter types we're
	  assuming. Coerce the function pointer to this type and go.

        - to enter the function at a given code label, we emit an extern declaration
	  for the label here, stating the calling convention together with result and
          argument types we're assuming. 

          The C compiler will hopefully use this extern declaration to good effect,
          reporting any discrepancies between our extern decl and any other that
	  may be in scope.
    
	  Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
  	  the external function `foo' use the calling convention of the first `foo'
	  prototype it encounters (nor does it complain about conflicting attribute
	  declarations). The consequence of this is that you cannot override the
	  calling convention of `foo' using an extern declaration (you'd have to use
	  a typedef), but why you would want to do such a thing in the first place
	  is totally beyond me.
	  
	  ToDo: petition the gcc folks to add code to warn about conflicting attribute
	  declarations.

    -}

     fun_nm
       | is_tdef   = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
       | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty
sof's avatar
sof committed
327 328 329

     ccall_fun_ty = 
        case op_str of
330
	  DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
331
	  StaticTarget x  -> pprCLabelString x
sof's avatar
sof committed
332 333 334 335 336 337 338

     ccall_res_ty = 
       case non_void_results of
          []       -> ptext SLIT("void")
	  [amode]  -> text (showPrimRep (getAmodeRep amode))
	  _	   -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"

sof's avatar
sof committed
339 340 341 342
     ccall_decl_ty_args 
       | is_tdef   = tail ccall_arg_tys
       | otherwise = ccall_arg_tys

sof's avatar
sof committed
343 344 345 346 347
     ccall_arg_tys      = map (text.showPrimRep.getAmodeRep) non_void_args

      -- the first argument will be the "I/O world" token (a VoidRep)
      -- all others should be non-void
     non_void_args =
348
	let nvas = init args
sof's avatar
sof committed
349 350 351 352 353 354 355
	in ASSERT (all non_void nvas) nvas

      -- there will usually be two results: a (void) state which we
      -- should ignore and a (possibly void) result.
     non_void_results =
	let nvrs = grab_non_void_amodes results
	in ASSERT (length nvrs <= 1) nvrs
356

357
pprAbsC (CCodeBlock lbl abs_C) _
358
  = if not (maybeToBool(nonemptyAbsC abs_C)) then
359
	pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
360
    else
361
    case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
sof's avatar
sof committed
362
    vcat [
363 364
        empty,
	pp_exts, 
365
	hcat [text (if (externallyVisibleCLabel lbl)
366 367
			  then "FN_("	-- abbreviations to save on output
			  else "IFN_("),
368
		   pprCLabel lbl, text ") {"],
369

370
	pp_temps,
371

sof's avatar
sof committed
372
	nest 8 (ptext SLIT("FB_")),
373
	nest 8 (pprAbsC abs_C (costs abs_C)),
sof's avatar
sof committed
374
	nest 8 (ptext SLIT("FE_")),
375 376
	char '}',
        char ' ' ]
377
    }
378

379

380
pprAbsC (CInitHdr cl_info amode cost_centre) _
381
  = hcat [ ptext SLIT("SET_HDR_"), char '(',
382
		ppr_amode amode, comma,
383 384 385
		pprCLabelAddr info_lbl, comma,
		if_profiling (pprAmode cost_centre),
		pp_paren_semi ]
386 387 388
  where
    info_lbl	= infoTableLabelFromCI cl_info

389
pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
390
  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
sof's avatar
sof committed
391
    vcat [
392
	pp_exts,
sof's avatar
sof committed
393
	hcat [
394 395
		ptext SLIT("SET_STATIC_HDR"), char '(',
		pprCLabel closure_lbl,			        comma,
396
		pprCLabel info_lbl,				comma,
397
		if_profiling (pprAmode cost_centre), 		comma,
sof's avatar
sof committed
398
		ppLocalness closure_lbl,			comma,
sof's avatar
sof committed
399
		ppLocalnessMacro True{-include dyn-} info_lbl,
sof's avatar
sof committed
400
		char ')'
401
		],
402
	nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
sof's avatar
sof committed
403
	ptext SLIT("};") ]
404
    }
405 406 407
  where
    info_lbl = infoTableLabelFromCI cl_info

408 409 410
    ppr_payload [] = empty
    ppr_payload ls = comma <+> 
		     braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
411

412 413 414 415 416 417 418 419 420
    ppr_item item
      | rep == VoidRep   = text "0" -- might not even need this...
      | rep == FloatRep  = ppr_amode (floatToWord item)
      | rep == DoubleRep = hcat (punctuate (text ", (L_)")
			 	 (map ppr_amode (doubleToWords item)))
      | otherwise  	 = ppr_amode item
      where 
	rep = getAmodeRep item

421 422
    padding_wds =
	if not (closureUpdReqd cl_info) then
423
	    []
424
    	else
425
	    case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->
426
	    nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
427

428 429 430 431 432
    static_link_field
	| staticClosureNeedsLink cl_info = [mkIntCLit 0]
	| otherwise 			 = []

pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
sof's avatar
sof committed
433 434
  = vcat [
	hcat [
435 436 437 438 439 440 441 442 443 444 445 446 447
	     ptext SLIT("INFO_TABLE"),
	     ( if is_selector then
	         ptext SLIT("_SELECTOR")
	       else if is_constr then
		 ptext SLIT("_CONSTR")
	       else if needs_srt then
	         ptext SLIT("_SRT")
               else empty ), char '(',

	    pprCLabel info_lbl,			        comma,
	    pprCLabel slow_lbl,				comma,
	    pp_rest, {- ptrs,nptrs,[srt,]type,-}	comma,

sof's avatar
sof committed
448 449
	    ppLocalness info_lbl,			   comma,
	    ppLocalnessMacro True{-include dyn-} slow_lbl, comma,
450

451 452
	    if_profiling pp_descr, comma,
	    if_profiling pp_type,
sof's avatar
sof committed
453
	    text ");"
454
	     ],
455
	pp_slow,
456
	case maybe_fast of
sof's avatar
sof committed
457
	    Nothing -> empty
458
	    Just fast -> let stuff = CCodeBlock fast_lbl fast in
459
			 pprAbsC stuff (costs stuff)
460 461 462 463 464 465 466
    ]
  where
    info_lbl	= infoTableLabelFromCI cl_info
    fast_lbl    = fastLabelFromCI cl_info

    (slow_lbl, pp_slow)
      = case (nonemptyAbsC slow) of
sof's avatar
sof committed
467
	  Nothing -> (mkErrorStdEntryLabel, empty)
468 469
	  Just xx -> (entryLabelFromCI cl_info,
		       let stuff = CCodeBlock slow_lbl xx in
470
		       pprAbsC stuff (costs stuff))
471 472 473

    maybe_selector = maybeSelectorInfo cl_info
    is_selector = maybeToBool maybe_selector
474
    (Just select_word_i) = maybe_selector
475

476 477 478
    maybe_tag = closureSemiTag cl_info
    is_constr = maybeToBool maybe_tag
    (Just tag) = maybe_tag
479

480 481
    needs_srt = infoTblNeedsSRT cl_info
    srt = getSRTInfo cl_info
482

483
    size = closureNonHdrSize cl_info
484

485 486
    ptrs        = closurePtrsSize cl_info
    nptrs	= size - ptrs
487

488 489 490 491 492 493 494 495 496 497
    pp_rest | is_selector      = int select_word_i
            | otherwise        = hcat [
	          int ptrs,		comma,
		  int nptrs,		comma,
		  if is_constr then
			hcat [ int tag, comma ]
                  else if needs_srt then
			pp_srt_info srt
		  else empty,
		  type_str ]
498

499
    type_str = pprSMRep (closureSMRep cl_info)
500

sof's avatar
sof committed
501 502
    pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
    pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
503

504 505 506 507 508
pprAbsC stmt@(CClosureTbl tycon) _
  = vcat (
	ptext SLIT("CLOSURE_TBL") <> 
	   lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
	punctuate comma (
509
	   map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
510 511 512
	)
   ) $$ ptext SLIT("};")

513 514 515 516 517 518 519 520 521 522
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
  = vcat [
      hcat [
	  ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen, 
	  pprCLabel info_lbl, 		comma,
	  pprCLabel entry_lbl, 		comma,
          pp_liveness liveness,		comma,	  -- bitmap
	  pp_srt_info srt,			  -- SRT
	  ptext type_str,		comma,	  -- closure type
	  ppLocalness info_lbl, 	comma,	  -- info table storage class
sof's avatar
sof committed
523
	  ppLocalnessMacro True{-include dyn-} entry_lbl, 	comma,    -- entry pt storage class
524 525 526 527 528
	  int 0, comma,
	  int 0, text ");"
      ],
      pp_code
    ]
529
  where
530 531
     info_lbl  = mkReturnInfoLabel uniq
     entry_lbl = mkReturnPtLabel uniq
532

533 534 535 536 537 538 539
     pp_code   = let stuff = CCodeBlock entry_lbl code in
	         pprAbsC stuff (costs stuff)

     type_str = case liveness of
		   LvSmall _ -> SLIT("RET_SMALL")
		   LvLarge _ -> SLIT("RET_BIG")

540
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
541 542 543
  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
    vcat [
	pp_exts,
544
	hcat [
545 546
	  ptext SLIT("VEC_INFO_") <> int size,
	  lparen, 
547
	  pprCLabel lbl, comma,
548 549 550
	  pp_liveness liveness, comma,	-- bitmap liveness mask
	  pp_srt_info srt,		-- SRT
	  ptext type_str, comma,
551
	  ppLocalness lbl, comma
552 553 554
	],
	nest 2 (sep (punctuate comma (map ppr_item amodes))),
	text ");"
555
    ]
556
    }
557 558

  where
559 560
    ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
    size = length amodes
561

562 563 564 565 566
    type_str = case liveness of
		   LvSmall _ -> SLIT("RET_VEC_SMALL")
		   LvLarge _ -> SLIT("RET_VEC_BIG")


567
pprAbsC stmt@(CModuleInitBlock lbl code) _
568
  = vcat [
569
	ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
570 571 572 573 574
	case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
	pprAbsC code (costs code),
	hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
    ]

575 576
pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs
577 578 579
\end{code}

\begin{code}
580 581
ppLocalness lbl
  = if (externallyVisibleCLabel lbl) 
582 583 584 585 586 587
		then empty 
		else ptext SLIT("static ")

-- Horrible macros for declaring the types and locality of labels (see
-- StgMacros.h).

sof's avatar
sof committed
588
ppLocalnessMacro include_dyn_prefix clabel =
589
     hcat [
sof's avatar
sof committed
590 591 592
        visiblity_prefix,
	dyn_prefix,
        case label_type of
593 594 595 596
	  ClosureType    -> ptext SLIT("C_")
	  CodeType       -> ptext SLIT("F_")
	  InfoTblType    -> ptext SLIT("I_")
	  ClosureTblType -> ptext SLIT("CP_")
597
	  DataType       -> ptext SLIT("D_")
598
     ]
sof's avatar
sof committed
599 600 601 602 603 604 605 606 607
  where
   is_visible = externallyVisibleCLabel clabel
   label_type = labelType clabel

   visiblity_prefix
     | is_visible = char 'E'
     | otherwise  = char 'I'

   dyn_prefix
608 609
     | include_dyn_prefix && labelDynamic clabel = char 'D'
     | otherwise	      			 = empty
sof's avatar
sof committed
610

611 612 613
\end{code}

\begin{code}
614 615
jmp_lit = "JMP_("

616 617 618 619
grab_non_void_amodes amodes
  = filter non_void amodes

non_void amode
620 621
  = case (getAmodeRep amode) of
      VoidRep -> False
622 623 624 625
      k	-> True
\end{code}

\begin{code}
626
ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
627

628 629 630
ppr_vol_regs [] = (empty, empty)
ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
ppr_vol_regs (r:rs)
631 632
  = let pp_reg = case r of
    	    	    VanillaReg pk n -> pprVanillaReg n
633 634
    	    	    _ -> pprMagicId r
	(more_saves, more_restores) = ppr_vol_regs rs
635
    in
sof's avatar
sof committed
636 637
    (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
     ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
638

639
-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and
640 641 642
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- depending on the platform.  (The "volatile regs" stuff handles all
-- other registers.)  Just be *sure* BaseReg is OK before trying to do
643 644
-- anything else. The correct sequence of saves&restores are
-- encoded by the CALLER_*_SYSTEM macros.
645
pp_basic_saves    = ptext SLIT("CALLER_SAVE_SYSTEM")
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
\end{code}

\begin{code}
has_srt (_, NoSRT) = False
has_srt _ = True

pp_srt_info srt = 
    case srt of
	(lbl, NoSRT) -> 
		hcat [  int 0, comma, 
			int 0, comma, 
			int 0, comma ]
	(lbl, SRT off len) -> 
		hcat [ 	pprCLabel lbl, comma,
		       	int off, comma,
		       	int len, comma ]
663 664
\end{code}

665 666 667 668 669 670
\begin{code}
pp_closure_lbl lbl
      | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
      | otherwise	 = char '&' <> pprCLabel lbl
\end{code}

671
\begin{code}
672 673 674 675
if_profiling pretty
  = if  opt_SccProfilingOn
    then pretty
    else char '0' -- leave it out!
676 677 678
-- ---------------------------------------------------------------------------
-- Changes for GrAnSim:
--  draw costs for computation in head of if into both branches;
679 680
--  as no abstractC data structure is given for the head, one is constructed
--  guessing unknown values and fed into the costs function
681 682
-- ---------------------------------------------------------------------------

683
do_if_stmt discrim tag alt_code deflt c
684 685 686
  = case tag of
      -- This special case happens when testing the result of a comparison.
      -- We can just avoid some redundant clutter in the output.
687
      MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
688
				      deflt alt_code
689
				      (addrModeCosts discrim Rhs) c
690
      other            -> let
sof's avatar
sof committed
691 692 693 694 695 696 697 698 699 700 701 702 703
			       cond = hcat [ pprAmode discrim
					   , ptext SLIT(" == ")
					   , tcast
					   , pprAmode (CLit tag)
					   ]
				-- to be absolutely sure that none of the 
				-- conversion rules hit, e.g.,
				--
				--     minInt is different to (int)minInt
			        --
				-- in C (when minInt is a number not a constant
				--  expression which evaluates to it.)
				-- 
704 705 706
			       tcast = case other of
					   MachInt _  -> ptext SLIT("(I_)")
					   _ 	      -> empty
707
			    in
708
			    ppr_if_stmt cond
709 710 711
					 alt_code deflt
					 (addrModeCosts discrim Rhs) c

712
ppr_if_stmt pp_pred then_part else_part discrim_costs c
sof's avatar
sof committed
713 714
  = vcat [
      hcat [text "if (", pp_pred, text ") {"],
715
      nest 8 (pprAbsC then_part 	(c + discrim_costs +
716
				       	(Cost (0, 2, 0, 0, 0)) +
717
					costs then_part)),
sof's avatar
sof committed
718
      (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
719
      nest 8 (pprAbsC else_part  (c + discrim_costs +
720
					(Cost (0, 1, 0, 0, 0)) +
721
					costs else_part)),
sof's avatar
sof committed
722
      char '}' ]
723
    {- Total costs = inherited costs (before if) + costs for accessing discrim
724
		     + costs for cond branch ( = (0, 1, 0, 0, 0) )
725 726 727 728 729 730 731 732 733 734 735 736
		     + costs for that alternative
    -}
\end{code}

Historical note: this used to be two separate cases -- one for `ccall'
and one for `casm'.  To get round a potential limitation to only 10
arguments, the numbering of arguments in @process_casm@ was beefed up a
bit. ADR

Some rough notes on generating code for @CCallOp@:

1) Evaluate all arguments and stuff them into registers. (done elsewhere)
737
2) Save any essential registers (heap, stack, etc).
738 739 740 741 742 743

   ToDo: If stable pointers are in use, these must be saved in a place
   where the runtime system can get at them so that the Stg world can
   be restarted during the call.

3) Save any temporary registers that are currently in use.
sof's avatar
sof committed
744
4) Do the call, putting result into a local variable
745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
5) Restore essential registers
6) Restore temporaries

   (This happens after restoration of essential registers because we
   might need the @Base@ register to access all the others correctly.)

   Otherwise, copy local variable into result register.

8) If ccall (not casm), declare the function being called as extern so
   that C knows if it returns anything other than an int.

\begin{pseudocode}
{ ResultType _ccall_result;
  basic_saves;
  saves;
  _ccall_result = f( args );
  basic_restores;
  restores;

764
  return_reg = _ccall_result;
765 766 767 768 769 770 771 772
}
\end{pseudocode}

Amendment to the above: if we can GC, we have to:

* make sure we save all our registers away where the garbage collector
  can get at them.
* be sure that there are no live registers or we're in trouble.
773
  (This can cause problems if you try something foolish like passing
774
   an array or a foreign obj to a _ccall_GC_ thing.)
775 776 777 778
* increment/decrement the @inCCallGC@ counter before/after the call so
  that the runtime check that PerformGC is being used sensibly will work.

\begin{code}
779
pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
780
  = vcat [
sof's avatar
sof committed
781
      char '{',
782
      declare_local_vars,   -- local var for *result*
sof's avatar
sof committed
783
      vcat local_arg_decls,
784
      pp_save_context,
sof's avatar
sof committed
785
        process_casm local_vars pp_non_void_args casm_str,
786 787
      pp_restore_context,
      assign_results,
sof's avatar
sof committed
788
      char '}'
789 790
    ]
  where
791
    (pp_saves, pp_restores) = ppr_vol_regs vol_regs
sof's avatar
sof committed
792
    (pp_save_context, pp_restore_context)
793 794
	| may_gc  = ( text "{ I_ id; SUSPEND_THREAD(id);"
		    , text "RESUME_THREAD(id);}"
795 796 797
		    )
	| otherwise = (	pp_basic_saves $$ pp_saves,
			pp_basic_restores $$ pp_restores)
798

799 800 801 802
    non_void_args = 
	let nvas = init args
	in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
	nvas
803
    -- the last argument will be the "I/O world" token (a VoidRep)
804 805
    -- all others should be non-void

806 807
    non_void_results =
	let nvrs = grab_non_void_amodes results
808 809 810 811 812
	in ASSERT (length nvrs <= 1) nvrs
    -- there will usually be two results: a (void) state which we
    -- should ignore and a (possibly void) result.

    (local_arg_decls, pp_non_void_args)
813
      = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
814 815

    (declare_local_vars, local_vars, assign_results)
816
      = ppr_casm_results non_void_results
817

sof's avatar
sof committed
818
    casm_str = if is_asm then _UNPK_ asm_str else ccall_str
819
    StaticTarget asm_str = op_str	-- Must be static if it's a casm
820 821 822

    -- Remainder only used for ccall

823 824 825
    fun_name = case op_str of
		 DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
		 StaticTarget st -> pprCLabelString st
sof's avatar
sof committed
826

827
    ccall_str = showSDoc
sof's avatar
sof committed
828
	(hcat [
829
		if null non_void_results
sof's avatar
sof committed
830 831
		  then empty
		  else text "%r = ",
832
		lparen, fun_name, lparen,
sof's avatar
sof committed
833
		  hcat (punctuate comma ccall_fun_args),
sof's avatar
sof committed
834
		text "));"
835
	])
sof's avatar
sof committed
836

837 838
    ccall_fun_args | isDynamicTarget op_str = tail ccall_args
		   | otherwise 		    = ccall_args
sof's avatar
sof committed
839 840 841

    ccall_args    = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]

842 843 844 845
\end{code}

If the argument is a heap object, we need to reach inside and pull out
the bit the C world wants to see.  The only heap objects which can be
846
passed are @Array@s and @ByteArray@s.
847 848

\begin{code}
849
ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
850 851
    -- (a) decl and assignment, (b) local var to be used later

852
ppr_casm_arg amode a_num
853
  = let
854
	a_kind	 = getAmodeRep amode
855 856
	pp_amode = pprAmode amode
	pp_kind  = pprPrimKind a_kind
857

sof's avatar
sof committed
858
	local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
859 860 861 862 863 864

	(arg_type, pp_amode2)
	  = case a_kind of

	      -- for array arguments, pass a pointer to the body of the array
	      -- (PTRS_ARR_CTS skips over all the header nonsense)
865
	      ArrayRep	    -> (pp_kind,
sof's avatar
sof committed
866
				hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
867
	      ByteArrayRep -> (pp_kind,
sof's avatar
sof committed
868
				hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
869

870
	      -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
871 872 873 874
	      ForeignObjRep -> (pp_kind,
				hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
				      char '(', pp_amode, char ')'])

875 876 877
	      other	    -> (pp_kind, pp_amode)

	declare_local_var
sof's avatar
sof committed
878
	  = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
879 880 881 882 883 884 885 886 887 888 889
    in
    (declare_local_var, local_var)
\end{code}

For l-values, the critical questions are:

1) Are there any results at all?

   We only allow zero or one results.

\begin{code}
890 891
ppr_casm_results
	:: [CAddrMode]	-- list of results (length <= 1)
892
	->
893 894 895
	( SDoc,		-- declaration of any local vars
	  [SDoc],	-- list of result vars (same length as results)
	  SDoc )	-- assignment (if any) of results in local var to registers
896

897
ppr_casm_results []
sof's avatar
sof committed
898
  = (empty, [], empty) 	-- no results
899

900
ppr_casm_results [r]
901
  = let
902
	result_reg = ppr_amode r
903
	r_kind	   = getAmodeRep r
904

sof's avatar
sof committed
905
	local_var  = ptext SLIT("_ccall_result")
906 907

	(result_type, assign_result)
908 909
	  = (pprPrimKind r_kind,
	     hcat [ result_reg, equals, local_var, semi ])
910

sof's avatar
sof committed
911
	declare_local_var = hcat [ result_type, space, local_var, semi ]
912
    in
913 914
    (declare_local_var, [local_var], assign_result)

915
ppr_casm_results rs
916 917 918 919 920 921 922
  = panic "ppr_casm_results: ccall/casm with many results"
\end{code}


Note the sneaky way _the_ result is represented by a list so that we
can complain if it's used twice.

923
ToDo: Any chance of giving line numbers when process-casm fails?
924 925 926
      Or maybe we should do a check _much earlier_ in compiler. ADR

\begin{code}
sof's avatar
sof committed
927 928 929 930
process_casm :: [SDoc]		-- results (length <= 1)
	     -> [SDoc]		-- arguments
	     -> String		-- format string (with embedded %'s)
	     ->	SDoc		-- code being generated
931 932 933

process_casm results args string = process results args string
 where
sof's avatar
sof committed
934