path: root/ghc/compiler/absCSyn/PprAbsC.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%*									*
\section[PprAbsC]{Pretty-printing Abstract~C}
%*									*
%************************************************************************

\begin{code}
module PprAbsC (
	writeRealC,
	dumpRealC,
	pprAmode,
	pprMagicId
    ) where

#include "HsVersions.h"

import IO	( Handle )

import PrimRep 
import AbsCSyn
import ClosureInfo
import AbsCUtils	( getAmodeRep, nonemptyAbsC,
			  mixedPtrLocn, mixedTypeLocn
			)

import ForeignCall	( CCallSpec(..), CCallTarget(..), playSafe,
			  playThreadSafe, ccallConvAttribute,
			  ForeignCall(..), DNCallSpec(..),
			  DNType(..), DNKind(..) )
import CLabel		( externallyVisibleCLabel,
			  needsCDecl, pprCLabel, mkClosureLabel,
			  mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
			  CLabel, CLabelType(..), labelType, labelDynamic
			)

import CmdLineOpts	( opt_SccProfilingOn, opt_GranMacros )
import CostCentre	( pprCostCentreDecl, pprCostCentreStackDecl )

import Costs		( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings		( pprCLabelString )
import FiniteMap	( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal		( Literal(..) )
import TyCon		( tyConDataCons )
import Name		( NamedThing(..) )
import Maybes		( catMaybes )
import PrimOp		( primOpNeedsWrapper )
import MachOp		( MachOp(..) )
import PrimRep		( isFloatingRep, PrimRep(..), getPrimRepSize )
import Unique		( pprUnique, Unique{-instance NamedThing-} )
import UniqSet		( emptyUniqSet, elementOfUniqSet,
			  addOneToUniqSet, UniqSet
			)
import StgSyn		( StgOp(..) )
import Outputable
import FastString
import Util		( lengthExceeds )

#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
#endif

#ifdef DEBUG
import Util		( listLengthCmp )
#endif

import Maybe		( isJust )
import GLAEXTS
import MONAD_ST

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}
{-
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 = 
-- _scc_ "writeRealC" 
-- printDoc LeftMode handle (pprAbsC absC (costs absC))

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"))

\end{code}

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

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

emitMacro _ | not opt_GranMacros = empty

emitMacro (Cost (i,b,l,s,f))
  = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                          int i, comma, int b, comma, int l, comma,
	                  int s, comma, int f, pp_paren_semi ]

pp_paren_semi = text ");"
\end{code}

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

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

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

pprAbsC (CJump target) c
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
	     (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])

pprAbsC (CFallThrough target) c
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CFallThrough */"-} ])
	     (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])

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

pprAbsC (CReturn am return_info)  c
  = ($$) (hcat [emitMacro c {-WDP:, text "/* <----  CReturn */"-} ])
	     (hcat [text jmp_lit, target, pp_paren_semi ])
  where
   target = case return_info of
    	DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
			      pprAmode am, rparen]
	DynamicVectoredReturn am' -> mk_vector (pprAmode am')
	StaticVectoredReturn n -> mk_vector (int n)	-- Always positive
   mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
		       x, rparen ]

pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")

-- 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
--                                                                       HWL
-- --------------------------------------------------------------------------

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

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

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

-- What problem is the re-ordering trying to solve ?
pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
			  (tag2@(MachInt i2), alt_code2)] deflt) c
  | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
  = if (i1 == 0) then
	do_if_stmt discrim tag1 alt_code1 alt_code2 c
    else
	do_if_stmt discrim tag2 alt_code2 alt_code1 c
  where
    empty_deflt = not (isJust (nonemptyAbsC deflt))

pprAbsC (CSwitch discrim alts deflt) c -- general case
  | isFloatingRep (getAmodeRep discrim)
    = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
  | otherwise
    = vcat [
	hcat [text "switch (", pp_discrim, text ") {"],
	nest 2 (vcat (map ppr_alt alts)),
	(case (nonemptyAbsC deflt) of
	   Nothing -> empty
	   Just dc ->
	    nest 2 (vcat [ptext SLIT("default:"),
				  pprAbsC dc (c + switch_head_cost
						    + costs dc),
				  ptext SLIT("break;")])),
	char '}' ]
  where
    pp_discrim
      = pprAmode discrim

    ppr_alt (lit, absC)
      = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
		   nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
				       (ptext SLIT("break;"))) ]

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

pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
  = pprFCall fcall uniq args results vol_regs

pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
  = let
	non_void_args = grab_non_void_amodes args
	non_void_results = grab_non_void_amodes results
	-- 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
    	case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
    	vcat [  pp_saves,
    	    	the_op,
    	    	pp_restores
    	     ]
	}
    else
    	the_op
  where
    ppr_op_call results args
      = hcat [ ppr op, lparen,
	hcat (punctuate comma (map ppr_op_result results)),
	if null results || null args then empty else comma,
	hcat (punctuate comma (map pprAmode args)),
	pp_paren_semi ]

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

-- NEW CASES FOR EXPANDED PRIMOPS

pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
  = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
    in
    case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
    saves $$
    hcat (
       [ppr_amode res, equals]
       ++ (if prefix_fn 
           then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
           else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
       ++ [semi]
    )
    $$ restores
    }

pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
  = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
    saves $$
    hcat [ppr_amode res, equals, 
          pprMachOp_for_C mop, parens (pprAmode arg1),
          semi]
    $$ restores
    }

pprAbsC stmt@(CSequential stuff) c
  = vcat (map (flip pprAbsC c) stuff)

-- end of NEW CASES FOR EXPANDED PRIMOPS

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 liveness@(Liveness lbl size mask)) c
  = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)

pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
  = pprWordArray desc_lbl (
	CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
	mkWordCLit (fromIntegral len) :
	bitmapAddrModes bitmap
     )

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

pprAbsC (CCheck macro as code) c
  = hcat [ptext (cCheckMacroText macro), lparen,
       hcat (punctuate comma (map ppr_amode as)), comma,
       pprAbsC code c, pp_paren_semi
    ]
pprAbsC (CMacroStmt macro as) _
  = hcat [ptext (cStmtMacroText macro), lparen,
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
pprAbsC (CCallProfCtrMacro op as) _
  = hcat [ftext op, lparen,
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC (CCallProfCCMacro op as) _
  = hcat [ftext op, lparen,
	hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
  =  hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
	  , ccall_res_ty
	  , fun_nm
	  , parens (hsep (punctuate comma ccall_decl_ty_args))
	  ] <> semi
    where
    {-
      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 (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
       | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty

     ccall_fun_ty = 
        case op_str of
	  DynamicTarget  -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
	  StaticTarget x -> pprCLabelString x

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

     ccall_decl_ty_args 
       | is_tdef   = tail ccall_arg_tys
       | otherwise = ccall_arg_tys

     ccall_arg_tys      = map (ppr . 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 =
	let nvas = init args
	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 (listLengthCmp nvrs 1 /= GT) nvrs

pprAbsC (CCodeBlock lbl abs_C) _
  = if not (isJust(nonemptyAbsC abs_C)) then
	pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
    else
    case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
    vcat [
        empty,
	pp_exts, 
	hcat [text (if (externallyVisibleCLabel lbl)
			  then "FN_("	-- abbreviations to save on output
			  else "IF_("),
		   pprCLabel lbl, text ") {"],

	pp_temps,

	nest 8 (ptext SLIT("FB_")),
	nest 8 (pprAbsC abs_C (costs abs_C)),
	nest 8 (ptext SLIT("FE_")),
	char '}',
        char ' ' ]
    }


pprAbsC (CInitHdr cl_info amode cost_centre size) _
  = hcat [ ptext SLIT("SET_HDR_"), char '(',
		ppr_amode amode, comma,
		pprCLabelAddr info_lbl, comma,
		if_profiling (pprAmode cost_centre), comma,
		if_profiling (int size),
		pp_paren_semi ]
  where
    info_lbl	= infoTableLabelFromCI cl_info


pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
  = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
    vcat [
	pp_exts,
	hcat [
		ptext SLIT("SET_STATIC_HDR"), char '(',
		pprCLabel closure_lbl,			        comma,
		pprCLabel info_lbl,				comma,
		if_profiling (pprAmode cost_centre), 		comma,
		ppLocalness closure_lbl,			comma,
		ppLocalnessMacro True{-include dyn-} info_lbl,
		char ')'
		],
	nest 2 (ppr_payload amodes),
	ptext SLIT("};") ]
    }
  where
    info_lbl    = infoTableLabelFromCI cl_info

    ppr_payload [] = empty
    ppr_payload ls = 
	comma <+> 
	  (braces $ hsep $ punctuate comma $
	   map (text "(L_)" <>) (foldr ppr_item [] ls))

    ppr_item item rest
      | rep == VoidRep   = rest
      | rep == FloatRep  = ppr_amode (floatToWord item) : rest
      | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
      | otherwise  	 = ppr_amode item : rest
      where 
	rep  = getAmodeRep item

pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
  =  pprWordArray info_lbl (mkInfoTable cl_info)
  $$ let stuff = CCodeBlock entry_lbl entry in
     pprAbsC stuff (costs stuff)
  where
	entry_lbl = entryLabelFromCI cl_info
	info_lbl  = infoTableLabelFromCI cl_info

pprAbsC stmt@(CClosureTbl tycon) _
  = vcat (
	ptext SLIT("CLOSURE_TBL") <> 
	   lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
	punctuate comma (
	   map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
	)
   ) $$ ptext SLIT("};")

pprAbsC stmt@(CRetDirect uniq code srt liveness) _
  =  pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
  $$ let stuff = CCodeBlock entry_lbl code in
     pprAbsC stuff (costs stuff)
  where
     info_lbl  = mkReturnInfoLabel uniq
     entry_lbl = mkReturnPtLabel uniq

pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
  = pprWordArray lbl (mkVecInfoTable amodes srt liveness)

pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
  = vcat [
	ptext SLIT("START_MOD_INIT") <> 
	    parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
	case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
	pprAbsC code (costs code),
	hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
    ]

pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
pprAbsC (CCostCentreStackDecl ccs)    _ = pprCostCentreStackDecl ccs
\end{code}

Info tables... just arrays of words (the translation is done in
ClosureInfo).

\begin{code}
pprWordArray lbl amodes
  = (case snd (initTE (ppr_decls_Amodes amodes)) of
	Just pp -> pp
	Nothing -> empty)
  $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), 
	    pprCLabel lbl, ptext SLIT("[] = {") ]
  $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
  $$ ptext SLIT("};")

castToWord s = text "(W_)(" <> s <> char ')'
\end{code}

\begin{code}
-- Print a CMachOp in a way suitable for emitting via C.
pprMachOp_for_C MO_Nat_Add       = char '+'
pprMachOp_for_C MO_Nat_Sub       = char '-'
pprMachOp_for_C MO_Nat_Eq        = text "==" 
pprMachOp_for_C MO_Nat_Ne        = text "!="

pprMachOp_for_C MO_NatS_Ge       = text ">="
pprMachOp_for_C MO_NatS_Le       = text "<="
pprMachOp_for_C MO_NatS_Gt       = text ">"
pprMachOp_for_C MO_NatS_Lt       = text "<"

pprMachOp_for_C MO_NatU_Ge       = text ">="
pprMachOp_for_C MO_NatU_Le       = text "<="
pprMachOp_for_C MO_NatU_Gt       = text ">"
pprMachOp_for_C MO_NatU_Lt       = text "<"

pprMachOp_for_C MO_NatS_Mul      = char '*'
pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo"
pprMachOp_for_C MO_NatS_Quot     = char '/'
pprMachOp_for_C MO_NatS_Rem      = char '%'
pprMachOp_for_C MO_NatS_Neg      = char '-'

pprMachOp_for_C MO_NatU_Mul      = char '*'
pprMachOp_for_C MO_NatU_Quot     = char '/'
pprMachOp_for_C MO_NatU_Rem      = char '%'

pprMachOp_for_C MO_Nat_And       = text "&"
pprMachOp_for_C MO_Nat_Or        = text "|"
pprMachOp_for_C MO_Nat_Xor       = text "^"
pprMachOp_for_C MO_Nat_Not       = text "~"
pprMachOp_for_C MO_Nat_Shl       = text "<<"
pprMachOp_for_C MO_Nat_Shr       = text ">>"
pprMachOp_for_C MO_Nat_Sar       = text ">>"

pprMachOp_for_C MO_32U_Eq        = text "=="
pprMachOp_for_C MO_32U_Ne        = text "!="
pprMachOp_for_C MO_32U_Ge        = text ">="
pprMachOp_for_C MO_32U_Le        = text "<="
pprMachOp_for_C MO_32U_Gt        = text ">"
pprMachOp_for_C MO_32U_Lt        = text "<"

pprMachOp_for_C MO_Dbl_Eq        = text "=="
pprMachOp_for_C MO_Dbl_Ne        = text "!="
pprMachOp_for_C MO_Dbl_Ge        = text ">="
pprMachOp_for_C MO_Dbl_Le        = text "<="
pprMachOp_for_C MO_Dbl_Gt        = text ">"
pprMachOp_for_C MO_Dbl_Lt        = text "<"

pprMachOp_for_C MO_Dbl_Add       = text "+"
pprMachOp_for_C MO_Dbl_Sub       = text "-"
pprMachOp_for_C MO_Dbl_Mul       = text "*"
pprMachOp_for_C MO_Dbl_Div       = text "/"
pprMachOp_for_C MO_Dbl_Pwr       = text "pow"

pprMachOp_for_C MO_Dbl_Sin       = text "sin"
pprMachOp_for_C MO_Dbl_Cos       = text "cos"
pprMachOp_for_C MO_Dbl_Tan       = text "tan"
pprMachOp_for_C MO_Dbl_Sinh      = text "sinh"
pprMachOp_for_C MO_Dbl_Cosh      = text "cosh"
pprMachOp_for_C MO_Dbl_Tanh      = text "tanh"
pprMachOp_for_C MO_Dbl_Asin      = text "asin"
pprMachOp_for_C MO_Dbl_Acos      = text "acos"
pprMachOp_for_C MO_Dbl_Atan      = text "atan"
pprMachOp_for_C MO_Dbl_Log       = text "log"
pprMachOp_for_C MO_Dbl_Exp       = text "exp"
pprMachOp_for_C MO_Dbl_Sqrt      = text "sqrt"
pprMachOp_for_C MO_Dbl_Neg       = text "-"

pprMachOp_for_C MO_Flt_Add       = text "+"
pprMachOp_for_C MO_Flt_Sub       = text "-"
pprMachOp_for_C MO_Flt_Mul       = text "*"
pprMachOp_for_C MO_Flt_Div       = text "/"
pprMachOp_for_C MO_Flt_Pwr       = text "pow"

pprMachOp_for_C MO_Flt_Eq        = text "=="
pprMachOp_for_C MO_Flt_Ne        = text "!="
pprMachOp_for_C MO_Flt_Ge        = text ">="
pprMachOp_for_C MO_Flt_Le        = text "<="
pprMachOp_for_C MO_Flt_Gt        = text ">"
pprMachOp_for_C MO_Flt_Lt        = text "<"

pprMachOp_for_C MO_Flt_Sin       = text "sin"
pprMachOp_for_C MO_Flt_Cos       = text "cos"
pprMachOp_for_C MO_Flt_Tan       = text "tan"
pprMachOp_for_C MO_Flt_Sinh      = text "sinh"
pprMachOp_for_C MO_Flt_Cosh      = text "cosh"
pprMachOp_for_C MO_Flt_Tanh      = text "tanh"
pprMachOp_for_C MO_Flt_Asin      = text "asin"
pprMachOp_for_C MO_Flt_Acos      = text "acos"
pprMachOp_for_C MO_Flt_Atan      = text "atan"
pprMachOp_for_C MO_Flt_Log       = text "log"
pprMachOp_for_C MO_Flt_Exp       = text "exp"
pprMachOp_for_C MO_Flt_Sqrt      = text "sqrt"
pprMachOp_for_C MO_Flt_Neg       = text "-"

pprMachOp_for_C MO_32U_to_NatS   = text "(StgInt)"
pprMachOp_for_C MO_NatS_to_32U   = text "(StgWord32)"

pprMachOp_for_C MO_NatS_to_Dbl   = text "(StgDouble)"
pprMachOp_for_C MO_Dbl_to_NatS   = text "(StgInt)"

pprMachOp_for_C MO_NatS_to_Flt   = text "(StgFloat)"
pprMachOp_for_C MO_Flt_to_NatS   = text "(StgInt)"

pprMachOp_for_C MO_NatS_to_NatU  = text "(StgWord)"
pprMachOp_for_C MO_NatU_to_NatS  = text "(StgInt)"

pprMachOp_for_C MO_NatS_to_NatP  = text "(void*)"
pprMachOp_for_C MO_NatP_to_NatS  = text "(StgInt)"
pprMachOp_for_C MO_NatU_to_NatP  = text "(void*)"
pprMachOp_for_C MO_NatP_to_NatU  = text "(StgWord)"

pprMachOp_for_C MO_Dbl_to_Flt    = text "(StgFloat)"
pprMachOp_for_C MO_Flt_to_Dbl    = text "(StgDouble)"

pprMachOp_for_C MO_8S_to_NatS    = text "(StgInt8)(StgInt)"
pprMachOp_for_C MO_16S_to_NatS   = text "(StgInt16)(StgInt)"
pprMachOp_for_C MO_32S_to_NatS   = text "(StgInt32)(StgInt)"

pprMachOp_for_C MO_8U_to_NatU    = text "(StgWord8)(StgWord)"
pprMachOp_for_C MO_16U_to_NatU   = text "(StgWord16)(StgWord)"
pprMachOp_for_C MO_32U_to_NatU   = text "(StgWord32)(StgWord)"

pprMachOp_for_C MO_8U_to_32U     = text "(StgWord32)"
pprMachOp_for_C MO_32U_to_8U     = text "(StgWord8)"


ppLocalness lbl
  = if (externallyVisibleCLabel lbl) 
		then empty 
		else ptext SLIT("static ")

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

ppLocalnessMacro include_dyn_prefix clabel =
     hcat [
        visiblity_prefix,
	dyn_prefix,
        case label_type of
	  ClosureType        -> ptext SLIT("C_")
	  CodeType           -> ptext SLIT("F_")
	  InfoTblType        -> ptext SLIT("I_")
	  RetInfoTblType     -> ptext SLIT("RI_")
	  ClosureTblType     -> ptext SLIT("CP_")
	  DataType           -> ptext SLIT("D_")
     ]
  where
   is_visible = externallyVisibleCLabel clabel
   label_type = labelType clabel

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

   dyn_prefix
     | include_dyn_prefix && labelDynamic clabel = char 'D'
     | otherwise	      			 = empty

\end{code}

\begin{code}
jmp_lit = "JMP_("

grab_non_void_amodes amodes
  = filter non_void amodes

non_void amode
  = case (getAmodeRep amode) of
      VoidRep -> False
      k	-> True
\end{code}

\begin{code}
ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
ppr_maybe_vol_regs Nothing
   = (empty, empty)
ppr_maybe_vol_regs (Just vrs)
   = case ppr_vol_regs vrs of
        (saves, restores) 
           -> (pp_basic_saves $$ saves,
               pp_basic_restores $$ restores)

ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)

ppr_vol_regs [] = (empty, empty)
ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
ppr_vol_regs (r:rs)
  = let pp_reg = case r of
    	    	    VanillaReg pk n -> pprVanillaReg n
    	    	    _ -> pprMagicId r
	(more_saves, more_restores) = ppr_vol_regs rs
    in
    (($$) ((<>) (ptext SLIT("CALLER_SAVE_"))    pp_reg) more_saves,
     ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)

-- pp_basic_{saves,restores}: The BaseReg, Sp, Hp and
-- 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
-- anything else. The correct sequence of saves&restores are
-- encoded by the CALLER_*_SYSTEM macros.
pp_basic_saves    = ptext SLIT("CALLER_SAVE_SYSTEM")
pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
\end{code}

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

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

do_if_stmt discrim tag alt_code deflt c
   = let
       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.)
	-- 
       tcast = case tag of
		   MachInt _  -> ptext SLIT("(I_)")
		   _ 	      -> empty
     in
     ppr_if_stmt cond
		 alt_code deflt
		 (addrModeCosts discrim Rhs) c

ppr_if_stmt pp_pred then_part else_part discrim_costs c
  = vcat [
      hcat [text "if (", pp_pred, text ") {"],
      nest 8 (pprAbsC then_part 	(c + discrim_costs +
				       	(Cost (0, 2, 0, 0, 0)) +
					costs then_part)),
      (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
      nest 8 (pprAbsC else_part  (c + discrim_costs +
					(Cost (0, 1, 0, 0, 0)) +
					costs else_part)),
      char '}' ]
    {- Total costs = inherited costs (before if) + costs for accessing discrim
		     + costs for cond branch ( = (0, 1, 0, 0, 0) )
		     + 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)
2) Save any essential registers (heap, stack, etc).

   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.
4) Do the call, putting result into a local variable
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;

  return_reg = _ccall_result;
}
\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.
  (This can cause problems if you try something foolish like passing
   an array or a foreign obj to a _ccall_GC_ thing.)
* increment/decrement the @inCCallGC@ counter before/after the call so
  that the runtime check that PerformGC is being used sensibly will work.

\begin{code}
pprFCall call uniq args results vol_regs
  = case call of
      CCall (CCallSpec target _cconv safety) ->
        vcat [ char '{',
	        declare_local_vars,   -- local var for *result*
	        vcat local_arg_decls,
		makeCall target safety 
			 (process_casm local_vars pp_non_void_args (call_str target)),
	        assign_results,
	      char '}'
	     ]
      DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
         let
	  target    = StaticTarget (mkFastString nm)
	  resultVar = "_ccall_result"
	  
	  hasAssemArg = isStatic || kind == DNConstructor
	  invokeOp  = 
	    case kind of
	      DNMethod 
	        | isStatic  -> "DN_invokeStatic"
		| otherwise -> "DN_invokeMethod"
	      DNField
	        | isStatic ->
		   if resTy == DNUnit 
		    then "DN_setStatic"
		    else "DN_getStatic"
                | otherwise ->
		   if resTy == DNUnit 
		    then "DN_setField"
		    else "DN_getField"
	      DNConstructor -> "DN_createObject"

	  (methArrDecl, methArrInit, methArrName, methArrLen) 
	    | null argTys = (empty, empty, text "NULL", text "0")
	    | otherwise   = 
	      ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
	      , vcat (zipWith3 (\ idx arg argTy -> 
	      			 text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
				 text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
			       [0..]
			       non_void_args
			       argTys)
	      , text "__meth_args"
	      , int (length non_void_args)
	      )
	 in
         vcat [ char '{',
	 	  declare_local_vars,
		  vcat local_arg_decls,
		  vcat [ methArrDecl
		       , methArrInit
		       , text "_ccall_result1 =" <+> text invokeOp <> parens (
		    	  hcat (punctuate comma $
				     (if hasAssemArg then
				     	((if null assem then 
					    text "NULL" 
			  	         else 
				            doubleQuotes (text assem)):)
				      else
				      	 id) $
				     [ doubleQuotes $ text nm
				     , methArrName
				     , methArrLen
				     , text (toDotnetTy resTy)
				     , text "(void*)&" <> text resultVar 
				     ])) <> semi
			],
	          assign_results,
	        char '}'
	       ]
  where
    (pp_saves, pp_restores) = ppr_vol_regs vol_regs
    
    makeCall target safety theCall = 
        vcat [ pp_save_context,	theCall, pp_restore_context ]
     where
      (pp_save_context, pp_restore_context)
	| playSafe safety = ( text "{ I_" <+> ppr_uniq_token <> 
				text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
			    , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
			    )
	| otherwise = (	pp_basic_saves $$ pp_saves,
			pp_basic_restores $$ pp_restores)
	   where
	    thread_macro_args = ppr_uniq_token <> comma <+> 
    		        	text "rts" <> ppr (playThreadSafe safety)
	    ppr_uniq_token = text "tok_" <> ppr uniq


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

    non_void_results =
	let nvrs = grab_non_void_amodes results
	in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) 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)
      = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]

    (declare_local_vars, local_vars, assign_results)
      = ppr_casm_results non_void_results forDotnet

    forDotnet
      = case call of
          DNCall{} -> True
	  _ -> False

    call_str tgt 
      = case tgt of
	  CasmTarget str  -> unpackFS str
  	  StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
	  DynamicTarget   -> mk_ccall_str dyn_fun	       (tail ccall_args)

    ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
    dyn_fun    = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
						 

    -- Remainder only used for ccall
    mk_ccall_str fun_name ccall_fun_args = showSDoc
	(hcat [
		if null non_void_results
		  then empty
		  else text "%r = ",
		lparen, fun_name, lparen,
		  hcat (punctuate comma ccall_fun_args),
		text "));"
	])

toDotnetTy :: DNType -> String
toDotnetTy x = 
  case x of 
    DNByte -> "Dotnet_Byte"
    DNBool -> "Dotnet_Bool"
    DNChar -> "Dotnet_Char"
    DNDouble -> "Dotnet_Double"
    DNFloat  -> "Dotnet_Float"
    DNInt    -> "Dotnet_Int"
    DNInt8   -> "Dotnet_Int8"
    DNInt16  -> "Dotnet_Int16"
    DNInt32  -> "Dotnet_Int32"
    DNInt64  -> "Dotnet_Int64"
    DNWord8  -> "Dotnet_Word8"
    DNWord16 -> "Dotnet_Word16"
    DNWord32 -> "Dotnet_Word32"
    DNWord64 -> "Dotnet_Word64"
    DNPtr    -> "Dotnet_Ptr"
    DNUnit   -> "Dotnet_Unit"
    DNObject -> "Dotnet_Object"
    DNString -> "Dotnet_String"

toDotnetArgField :: DNType -> String
toDotnetArgField x = 
  case x of 
    DNByte -> "arg_byte"
    DNBool -> "arg_bool"
    DNChar -> "arg_char"
    DNDouble -> "arg_double"
    DNFloat  -> "arg_float"
    DNInt    -> "arg_int"
    DNInt8   -> "arg_int8"
    DNInt16  -> "arg_int16"
    DNInt32  -> "arg_int32"
    DNInt64  -> "arg_int64"
    DNWord8  -> "arg_word8"
    DNWord16 -> "arg_word16"
    DNWord32 -> "arg_word32"
    DNWord64 -> "arg_word64"
    DNPtr    -> "arg_ptr"
    DNUnit   -> "arg_ptr" -- can't happen
    DNObject -> "arg_obj"
    DNString -> "arg_str"

ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
    -- (a) decl and assignment, (b) local var to be used later

ppr_casm_arg amode a_num
  = let
	a_kind	 = getAmodeRep amode
	pp_amode = pprAmode amode
	pp_kind  = pprPrimKind a_kind

	local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)

	declare_local_var
	  = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]
    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}
ppr_casm_results
	:: [CAddrMode]	-- list of results (length <= 1)
	-> Bool         -- True => multiple results OK.
	->
	( 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

ppr_casm_results [] _
  = (empty, [], empty) 	-- no results

ppr_casm_results (r:rs) multiResultsOK
  | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
  | otherwise
  = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
  	  (empty,[],empty)
	  (zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
    where
      pprRes r suf = (declare_local_var, [local_var], assign_result)
       where
	result_reg = ppr_amode r
	r_kind	   = getAmodeRep r

	local_var  = ptext SLIT("_ccall_result") <> text suf

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

	declare_local_var = hcat [ result_type, space, local_var, semi ]

\end{code}


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

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

\begin{code}
process_casm :: [SDoc]		-- results (length <= 1)
	     -> [SDoc]		-- arguments
	     -> String		-- format string (with embedded %'s)
	     ->	SDoc		-- code being generated

process_casm results args string = process results args string
 where
  process []    _ "" = empty
  process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ 
			      string ++ 
			      "\"\n(Try changing result type to IO ()\n")

  process ress args ('%':cs)
    = case cs of
	[] ->
	    error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")

	('%':css) ->
	    char '%' <> process ress args css

	('r':css)  ->
	  case ress of
	    []  -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
	    [r] -> r <> (process [] args css)
	    _   -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")

	other ->
	  let
		read_int :: ReadS Int
		read_int = reads
	  in
	  case (read_int other) of
	    [(num,css)] ->
		  if num >= 0 && args `lengthExceeds` num
		  then parens (args !! num) <> process ress args css
		  else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
	    _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")

  process ress args (other_c:cs)
    = char other_c <> process ress args cs
\end{code}

%************************************************************************
%*									*
\subsection[a2r-assignments]{Assignments}
%*									*
%************************************************************************

Printing assignments is a little tricky because of type coercion.

First of all, the kind of the thing being assigned can be gotten from
the destination addressing mode.  (It should be the same as the kind
of the source addressing mode.)  If the kind of the assignment is of
@VoidRep@, then don't generate any code at all.

\begin{code}
pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc

pprAssign VoidRep dest src = empty
\end{code}

Special treatment for floats and doubles, to avoid unwanted conversions.

\begin{code}
pprAssign FloatRep dest@(CVal reg_rel _) src
  = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]

pprAssign DoubleRep dest@(CVal reg_rel _) src
  = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]

pprAssign Int64Rep dest@(CVal reg_rel _) src
  = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign Word64Rep dest@(CVal reg_rel _) src
  = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
\end{code}

Lastly, the question is: will the C compiler think the types of the
two sides of the assignment match?

	We assume that the types will match if neither side is a
	@CVal@ addressing mode for any register which can point into
	the heap or stack.

Why?  Because the heap and stack are used to store miscellaneous
things, whereas the temporaries, registers, etc., are only used for
things of fixed type.

\begin{code}
pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
  = hcat [ pprVanillaReg dest, equals,
		pprVanillaReg src, semi ]

pprAssign kind dest src
  | mixedTypeLocn dest
    -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
  = hcat [ ppr_amode dest, equals,
		text "(W_)(",	-- Here is the cast
		ppr_amode src, pp_paren_semi ]

pprAssign kind dest src
  | mixedPtrLocn dest && getAmodeRep src /= PtrRep
    -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
  = hcat [ ppr_amode dest, equals,
		text "(P_)(",	-- Here is the cast
		ppr_amode src, pp_paren_semi ]

pprAssign kind other_dest src
  = hcat [ ppr_amode other_dest, equals,
		pprAmode  src, semi ]
\end{code}


%************************************************************************
%*									*
\subsection[a2r-CAddrModes]{Addressing modes}
%*									*
%************************************************************************

@pprAmode@ is used to print r-values (which may need casts), whereas
@ppr_amode@ is used for l-values {\em and} as a help function for
@pprAmode@.

\begin{code}
pprAmode, ppr_amode :: CAddrMode -> SDoc
\end{code}

For reasons discussed above under assignments, @CVal@ modes need
to be treated carefully.  First come special cases for floats and doubles,
similar to those in @pprAssign@:

(NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
question.)

\begin{code}
pprAmode (CVal reg_rel FloatRep)
  = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel DoubleRep)
  = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Int64Rep)
  = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Word64Rep)
  = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
\end{code}

Next comes the case where there is some other cast need, and the
no-cast case:

\begin{code}
pprAmode amode
  | mixedTypeLocn amode
  = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
		ppr_amode amode ])
  | otherwise	-- No cast needed
  = ppr_amode amode
\end{code}

When we have an indirection through a CIndex, we have to be careful to
get the type casts right.  

this amode:

	CVal (CIndex kind1 base offset) kind2

means (in C speak): 
	
	*(kind2 *)((kind1 *)base + offset)

That is, the indexing is done in units of kind1, but the resulting
amode has kind2.

\begin{code}
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
	(pp_reg, Nothing)     -> panic "ppr_amode: CIndex"
	(pp_reg, Just offset) -> 
	   hcat [ char '*', parens (pprPrimKind kind <> char '*'),
		  parens (pp_reg <> char '+' <> offset) ]
\end{code}

Now the rest of the cases for ``workhorse'' @ppr_amode@:

\begin{code}
ppr_amode (CVal reg_rel _)
  = case (pprRegRelative False{-no sign wanted-} reg_rel) of
	(pp_reg, Nothing)     -> (<>)  (char '*') pp_reg
	(pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]

ppr_amode (CAddr reg_rel)
  = case (pprRegRelative True{-sign wanted-} reg_rel) of
	(pp_reg, Nothing)     -> pp_reg
	(pp_reg, Just offset) -> pp_reg <> offset

ppr_amode (CReg magic_id) = pprMagicId magic_id

ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'

ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl 

ppr_amode (CCharLike ch)
  = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
ppr_amode (CIntLike int)
  = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]

ppr_amode (CLit lit) = pprBasicLit lit

ppr_amode (CJoinPoint _)
  = panic "ppr_amode: CJoinPoint"

ppr_amode (CMacroExpr pk macro as)
  = parens (ptext (cExprMacroText macro) <> 
	    parens (hcat (punctuate comma (map pprAmode as))))
\end{code}

\begin{code}
cExprMacroText ENTRY_CODE 		= SLIT("ENTRY_CODE")
cExprMacroText ARG_TAG    		= SLIT("ARG_TAG")
cExprMacroText GET_TAG    		= SLIT("GET_TAG")
cExprMacroText CCS_HDR		 	= SLIT("CCS_HDR")
cExprMacroText BYTE_ARR_CTS	 	= SLIT("BYTE_ARR_CTS")
cExprMacroText PTRS_ARR_CTS	 	= SLIT("PTRS_ARR_CTS")
cExprMacroText ForeignObj_CLOSURE_DATA  = SLIT("ForeignObj_CLOSURE_DATA")

cStmtMacroText UPD_CAF			= SLIT("UPD_CAF")
cStmtMacroText UPD_BH_UPDATABLE		= SLIT("UPD_BH_UPDATABLE")
cStmtMacroText UPD_BH_SINGLE_ENTRY	= SLIT("UPD_BH_SINGLE_ENTRY")
cStmtMacroText PUSH_UPD_FRAME		= SLIT("PUSH_UPD_FRAME")
cStmtMacroText SET_TAG			= SLIT("SET_TAG")
cStmtMacroText DATA_TO_TAGZH            = SLIT("dataToTagzh")
cStmtMacroText REGISTER_FOREIGN_EXPORT	= SLIT("REGISTER_FOREIGN_EXPORT")
cStmtMacroText REGISTER_IMPORT		= SLIT("REGISTER_IMPORT")
cStmtMacroText REGISTER_DIMPORT		= SLIT("REGISTER_DIMPORT")
cStmtMacroText GRAN_FETCH	    	= SLIT("GRAN_FETCH")
cStmtMacroText GRAN_RESCHEDULE   	= SLIT("GRAN_RESCHEDULE")
cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
cStmtMacroText THREAD_CONTEXT_SWITCH   	= SLIT("THREAD_CONTEXT_SWITCH")
cStmtMacroText GRAN_YIELD   		= SLIT("GRAN_YIELD")

cCheckMacroText	HP_CHK_NP		= SLIT("HP_CHK_NP")
cCheckMacroText	STK_CHK_NP		= SLIT("STK_CHK_NP")
cCheckMacroText	HP_STK_CHK_NP		= SLIT("HP_STK_CHK_NP")
cCheckMacroText	HP_CHK_FUN		= SLIT("HP_CHK_FUN")
cCheckMacroText	STK_CHK_FUN		= SLIT("STK_CHK_FUN")
cCheckMacroText	HP_STK_CHK_FUN		= SLIT("HP_STK_CHK_FUN")
cCheckMacroText	HP_CHK_NOREGS		= SLIT("HP_CHK_NOREGS")
cCheckMacroText	HP_CHK_UNPT_R1		= SLIT("HP_CHK_UNPT_R1")
cCheckMacroText	HP_CHK_UNBX_R1		= SLIT("HP_CHK_UNBX_R1")
cCheckMacroText	HP_CHK_F1		= SLIT("HP_CHK_F1")
cCheckMacroText	HP_CHK_D1		= SLIT("HP_CHK_D1")
cCheckMacroText	HP_CHK_L1		= SLIT("HP_CHK_L1")
cCheckMacroText	HP_CHK_UNBX_TUPLE	= SLIT("HP_CHK_UNBX_TUPLE")
\end{code}

%************************************************************************
%*									*
\subsection[ppr-liveness-masks]{Liveness Masks}
%*									*
%************************************************************************

\begin{code}
bitmapAddrModes [] = [mkWordCLit 0]
bitmapAddrModes xs = map mkWordCLit xs
\end{code}

%************************************************************************
%*									*
\subsection[a2r-MagicIds]{Magic ids}
%*									*
%************************************************************************

@pprRegRelative@ returns a pair of the @Doc@ for the register
(some casting may be required), and a @Maybe Doc@ for the offset
(zero offset gives a @Nothing@).

\begin{code}
addPlusSign :: Bool -> SDoc -> SDoc
addPlusSign False p = p
addPlusSign True  p = (<>) (char '+') p

pprSignedInt :: Bool -> Int -> Maybe SDoc	-- Nothing => 0
pprSignedInt sign_wanted n
 = if n == 0 then Nothing else
   if n > 0  then Just (addPlusSign sign_wanted (int n))
   else 	  Just (int n)

pprRegRelative :: Bool		-- True <=> Print leading plus sign (if +ve)
	       -> RegRelative
	       -> (SDoc, Maybe SDoc)

pprRegRelative sign_wanted (SpRel off)
  = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))

pprRegRelative sign_wanted r@(HpRel o)
  = let pp_Hp	 = pprMagicId Hp; off = I# o
    in
    if off == 0 then
	(pp_Hp, Nothing)
    else
	(pp_Hp, Just ((<>) (char '-') (int off)))

pprRegRelative sign_wanted (NodeRel o)
  = let pp_Node = pprMagicId node; off = I# o
    in
    if off == 0 then
	(pp_Node, Nothing)
    else
	(pp_Node, Just (addPlusSign sign_wanted (int off)))

pprRegRelative sign_wanted (CIndex base offset kind)
  = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
    , Just (hcat [if sign_wanted then char '+' else empty,
	    text "(I_)(", ppr_amode offset, ptext SLIT(")")])
    )
\end{code}

@pprMagicId@ just prints the register name.  @VanillaReg@ registers are
represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
to select the union tag.

\begin{code}
pprMagicId :: MagicId -> SDoc

pprMagicId BaseReg	    	    = ptext SLIT("BaseReg")
pprMagicId (VanillaReg pk n)
				    = hcat [ pprVanillaReg n, char '.',
						  pprUnionTag pk ]
pprMagicId (FloatReg  n)            = ptext SLIT("F") <> int (I# n)
pprMagicId (DoubleReg n)	    = ptext SLIT("D") <> int (I# n)
pprMagicId (LongReg _ n)	    = ptext SLIT("L") <> int (I# n)
pprMagicId Sp			    = ptext SLIT("Sp")
pprMagicId SpLim		    = ptext SLIT("SpLim")
pprMagicId Hp			    = ptext SLIT("Hp")
pprMagicId HpLim		    = ptext SLIT("HpLim")
pprMagicId CurCostCentre	    = ptext SLIT("CCCS")
pprMagicId VoidReg		    = ptext SLIT("VoidReg")

pprVanillaReg :: Int# -> SDoc
pprVanillaReg n = char 'R' <> int (I# n)

pprUnionTag :: PrimRep -> SDoc

pprUnionTag PtrRep		= char 'p'
pprUnionTag CodePtrRep	    	= ptext SLIT("fp")
pprUnionTag DataPtrRep	    	= char 'd'
pprUnionTag RetRep 	    	= char 'p'
pprUnionTag CostCentreRep	= panic "pprUnionTag:CostCentre?"

pprUnionTag CharRep		= char 'c'
pprUnionTag Int8Rep		= ptext SLIT("i8")
pprUnionTag IntRep		= char 'i'
pprUnionTag WordRep		= char 'w'
pprUnionTag Int32Rep		= char 'i'
pprUnionTag Word32Rep		= char 'w'
pprUnionTag AddrRep		= char 'a'
pprUnionTag FloatRep		= char 'f'
pprUnionTag DoubleRep		= panic "pprUnionTag:Double?"

pprUnionTag StablePtrRep	= char 'p'

pprUnionTag _                   = panic "pprUnionTag:Odd kind"
\end{code}


Find and print local and external declarations for a list of
Abstract~C statements.
\begin{code}
pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls AbsCNop = (empty, empty)

pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
  = initTE (ppr_decls_AbsC stmt1	`thenTE` \ (t_p1, e_p1) ->
	    ppr_decls_AbsC stmt2	`thenTE` \ (t_p2, e_p2) ->
	    case (catMaybes [t_p1, t_p2])	 of { real_temps ->
	    case (catMaybes [e_p1, e_p2])	 of { real_exts ->
	    returnTE (vcat real_temps, vcat real_exts) }}
	   )

pprTempAndExternDecls other_stmt
  = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
	    returnTE (
		case maybe_t of
		  Nothing -> empty
		  Just pp -> pp,

		case maybe_e of
		  Nothing -> empty
		  Just pp -> pp )
	   )

pprBasicLit :: Literal -> SDoc
pprPrimKind :: PrimRep -> SDoc

pprBasicLit  lit = ppr lit
pprPrimKind  k   = ppr k
\end{code}


%************************************************************************
%*									*
\subsection[a2r-monad]{Monadery}
%*									*
%************************************************************************

We need some monadery to keep track of temps and externs we have already
printed.  This info must be threaded right through the Abstract~C, so
it's most convenient to hide it in this monad.

WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
\tr{(UniqSet, CLabelSet)}.  Allegedly for efficiency.

\begin{code}
type CLabelSet = FiniteMap CLabel (){-any type will do-}
emptyCLabelSet = emptyFM
x `elementOfCLabelSet` labs
  = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }

addToCLabelSet set x = addToFM set x ()

type TEenv = (UniqSet Unique, CLabelSet)

type TeM result =  TEenv -> (TEenv, result)

initTE :: TeM a -> a
initTE sa
  = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
    result }

{-# INLINE thenTE #-}
{-# INLINE returnTE #-}

thenTE :: TeM a -> (a -> TeM b) -> TeM b
thenTE a b u
  = case a u	    of { (u_1, result_of_a) ->
    b result_of_a u_1 }

mapTE :: (a -> TeM b) -> [a] -> TeM [b]
mapTE f []     = returnTE []
mapTE f (x:xs)
  = f x		`thenTE` \ r  ->
    mapTE f xs	`thenTE` \ rs ->
    returnTE (r : rs)

returnTE :: a -> TeM a
returnTE result env = (env, result)

-- these next two check whether the thing is already
-- recorded, and THEN THEY RECORD IT
-- (subsequent calls will return False for the same uniq/label)

tempSeenTE :: Unique -> TeM Bool
tempSeenTE uniq env@(seen_uniqs, seen_labels)
  = if (uniq `elementOfUniqSet` seen_uniqs)
    then (env, True)
    else ((addOneToUniqSet seen_uniqs uniq,
	  seen_labels),
	  False)

labelSeenTE :: CLabel -> TeM Bool
labelSeenTE lbl env@(seen_uniqs, seen_labels)
  = if (lbl `elementOfCLabelSet` seen_labels)
    then (env, True)
    else ((seen_uniqs,
	  addToCLabelSet seen_labels lbl),
	  False)
\end{code}

\begin{code}
pprTempDecl :: Unique -> PrimRep -> SDoc
pprTempDecl uniq kind
  = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]

pprExternDecl :: Bool -> CLabel -> SDoc
pprExternDecl in_srt clabel
  | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
  | otherwise		    = 
	hcat [ ppLocalnessMacro (not in_srt) clabel, 
	       lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
 where
  dyn_wrapper d
    | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
    | otherwise			    = d

\end{code}

\begin{code}
ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})

ppr_decls_AbsC AbsCNop		= returnTE (Nothing, Nothing)

ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
  = ppr_decls_AbsC stmts_1  `thenTE` \ p1 ->
    ppr_decls_AbsC stmts_2  `thenTE` \ p2 ->
    returnTE (maybe_vcat [p1, p2])

ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)

ppr_decls_AbsC (CAssign dest source)
  = ppr_decls_Amode dest    `thenTE` \ p1 ->
    ppr_decls_Amode source  `thenTE` \ p2 ->
    returnTE (maybe_vcat [p1, p2])

ppr_decls_AbsC (CJump target) = ppr_decls_Amode target

ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target

ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target

ppr_decls_AbsC (CSwitch discrim alts deflt)
  = ppr_decls_Amode discrim	`thenTE` \ pdisc ->
    mapTE ppr_alt_stuff alts	`thenTE` \ palts  ->
    ppr_decls_AbsC deflt	`thenTE` \ pdeflt ->
    returnTE (maybe_vcat (pdisc:pdeflt:palts))
  where
    ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC

ppr_decls_AbsC (CCodeBlock lbl absC)
  = ppr_decls_AbsC absC

ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _)
	-- ToDo: strictly speaking, should chk "cost_centre" amode
  = labelSeenTE info_lbl     `thenTE` \  label_seen ->
    returnTE (Nothing,
	      if label_seen then
		  Nothing
	      else
		  Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
  where
    info_lbl = infoTableLabelFromCI cl_info

ppr_decls_AbsC (CMachOpStmt res	_ args _) = ppr_decls_Amodes (res : args)
ppr_decls_AbsC (COpStmt	results	_ args _) = ppr_decls_Amodes (results ++ args)

ppr_decls_AbsC (CSimultaneous abc)  	  = ppr_decls_AbsC abc

ppr_decls_AbsC (CSequential abcs) 
  = mapTE ppr_decls_AbsC abcs	`thenTE` \ t_and_e_s ->
    returnTE (maybe_vcat t_and_e_s)

ppr_decls_AbsC (CCheck  	    _ amodes code) = 
     ppr_decls_Amodes amodes `thenTE` \p1 ->
     ppr_decls_AbsC code     `thenTE` \p2 ->
     returnTE (maybe_vcat [p1,p2])

ppr_decls_AbsC (CMacroStmt	    _ amodes)	= ppr_decls_Amodes amodes

ppr_decls_AbsC (CCallProfCtrMacro   _ amodes)	= ppr_decls_Amodes [] -- *****!!!
  -- you get some nasty re-decls of stdio.h if you compile
  -- the prelude while looking inside those amodes;
  -- no real reason to, anyway.
ppr_decls_AbsC (CCallProfCCMacro    _ amodes)	= ppr_decls_Amodes amodes

ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes)
	-- ToDo: strictly speaking, should chk "cost_centre" amode
  = ppr_decls_Amodes amodes

ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
  = ppr_decls_Amodes [entry_lbl]	    	`thenTE` \ p1 ->
    ppr_decls_AbsC entry			`thenTE` \ p2 ->
    returnTE (maybe_vcat [p1, p2])
  where
    entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep

ppr_decls_AbsC (CSRT _ closure_lbls)
  = mapTE labelSeenTE closure_lbls		`thenTE` \ seen ->
    returnTE (Nothing, 
	      if and seen then Nothing
		else Just (vcat [ pprExternDecl True{-in SRT decl-} l
				| (l,False) <- zip closure_lbls seen ]))

ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
ppr_decls_AbsC (CModuleInitBlock _ _ code)   = ppr_decls_AbsC code

ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code}

\begin{code}
ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
ppr_decls_Amode (CVal  (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
ppr_decls_Amode (CAddr (CIndex base offset _))   = ppr_decls_Amodes [base,offset]
ppr_decls_Amode (CVal _ _)	= returnTE (Nothing, Nothing)
ppr_decls_Amode (CAddr _)	= returnTE (Nothing, Nothing)
ppr_decls_Amode (CReg _)	= returnTE (Nothing, Nothing)
ppr_decls_Amode (CLit _)	= returnTE (Nothing, Nothing)

-- CIntLike must be a literal -- no decls
ppr_decls_Amode (CIntLike int)	= returnTE (Nothing, Nothing)

-- CCharLike too
ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)

-- now, the only place where we actually print temps/externs...
ppr_decls_Amode (CTemp uniq kind)
  = case kind of
      VoidRep -> returnTE (Nothing, Nothing)
      other ->
	tempSeenTE uniq `thenTE` \ temp_seen ->
	returnTE
	  (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)

ppr_decls_Amode (CLbl lbl VoidRep)
  = returnTE (Nothing, Nothing)

ppr_decls_Amode (CLbl lbl kind)
  = labelSeenTE lbl `thenTE` \ label_seen ->
    returnTE (Nothing,
	      if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))

ppr_decls_Amode (CMacroExpr _ _ amodes)
  = ppr_decls_Amodes amodes

ppr_decls_Amode other = returnTE (Nothing, Nothing)


maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
maybe_vcat ps
  = case (unzip ps)	of { (ts, es) ->
    case (catMaybes ts)	of { real_ts  ->
    case (catMaybes es)	of { real_es  ->
    (if (null real_ts) then Nothing else Just (vcat real_ts),
     if (null real_es) then Nothing else Just (vcat real_es))
    } } }
\end{code}

\begin{code}
ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
ppr_decls_Amodes amodes
  = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
    returnTE ( maybe_vcat ps )
\end{code}

Print out a C Label where you want the *address* of the label, not the
object it refers to.  The distinction is important when the label may
refer to a C structure (info tables and closures, for instance).

When just generating a declaration for the label, use pprCLabel.

\begin{code}
pprCLabelAddr :: CLabel -> SDoc
pprCLabelAddr clabel =
  case labelType clabel of
     InfoTblType    -> addr_of_label
     RetInfoTblType -> addr_of_label
     ClosureType    -> addr_of_label
     VecTblType     -> addr_of_label
     DataType	    -> addr_of_label

     _              -> pp_label
  where
    addr_of_label = ptext SLIT("(P_)&") <> pp_label
    pp_label = pprCLabel clabel
\end{code}

-----------------------------------------------------------------------------
Initialising static objects with floating-point numbers.  We can't
just emit the floating point number, because C will cast it to an int
by rounding it.  We want the actual bit-representation of the float.

This is a hack to turn the floating point numbers into ints that we
can safely initialise to static locations.

\begin{code}
big_doubles = (getPrimRepSize DoubleRep) /= 1

#if __GLASGOW_HASKELL__ >= 504
newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
newFloatArray = newArray_

newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
newDoubleArray = newArray_

castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
castFloatToIntArray = castSTUArray

castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
castDoubleToIntArray = castSTUArray

writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
writeFloatArray = writeArray

writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
writeDoubleArray = writeArray

readIntArray :: STUArray s Int Int -> Int -> ST s Int
readIntArray = readArray

#else

castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
castFloatToIntArray = return

castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
castDoubleToIntArray = return

#endif

-- floats are always 1 word
floatToWord :: CAddrMode -> CAddrMode
floatToWord (CLit (MachFloat r))
  = runST (do
	arr <- newFloatArray ((0::Int),0)
	writeFloatArray arr 0 (fromRational r)
	arr' <- castFloatToIntArray arr
	i <- readIntArray arr' 0
	return (CLit (MachInt (toInteger i)))
    )

doubleToWords :: CAddrMode -> [CAddrMode]
doubleToWords (CLit (MachDouble r))
  | big_doubles				-- doubles are 2 words
  = runST (do
	arr <- newDoubleArray ((0::Int),1)
	writeDoubleArray arr 0 (fromRational r)
	arr' <- castDoubleToIntArray arr
	i1 <- readIntArray arr' 0
	i2 <- readIntArray arr' 1
	return [ CLit (MachInt (toInteger i1))
	       , CLit (MachInt (toInteger i2))
	       ]
    )
  | otherwise				-- doubles are 1 word
  = runST (do
	arr <- newDoubleArray ((0::Int),0)
	writeDoubleArray arr 0 (fromRational r)
	arr' <- castDoubleToIntArray arr
	i <- readIntArray arr' 0
	return [ CLit (MachInt (toInteger i)) ]
    )
\end{code}