\begin{code}
module PprAbsC (
writeRealC,
- dumpRealC
-#ifdef DEBUG
- , pprAmode -- otherwise, not exported
- , pprMagicId
-#endif
+ dumpRealC,
+ pprAmode,
+ pprMagicId
) where
#include "HsVersions.h"
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
-import SMRep ( getSMRepStr )
+import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
-import Util ( nOfThem, panic, assertPanic )
+import Util ( nOfThem )
import Addr ( Addr )
import ST
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))
-- 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 op@(CCallOp _ _ _) args vol_regs) _
- = pprCCall op args results vol_regs
--}
pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
= pprCCall op args results vol_regs
in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _
- = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+ = if not (maybeToBool(nonemptyAbsC abs_C)) then
+ pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+ else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [
hcat [text (if (externallyVisibleCLabel label)
else empty,
type_str ]
- type_str = text (getSMRepStr (closureSMRep cl_info))
+ type_str = pprSMRep (closureSMRep cl_info)
pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
deflt alt_code
(addrModeCosts discrim Rhs) c
other -> let
- cond = hcat [ pprAmode discrim,
- ptext SLIT(" == "),
- pprAmode (CLit tag) ]
+ 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 other of
+ MachInt _ signed | signed -> ptext SLIT("(I_)")
+ _ -> empty
in
ppr_if_stmt cond
alt_code deflt
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = char 'i'
+pprUnionTag StableNameRep = char 'p'
pprUnionTag WeakPtrRep = char 'p'
pprUnionTag ForeignObjRep = char 'p'
floatToWord :: CAddrMode -> CAddrMode
floatToWord (CLit (MachFloat r))
= runST (do
- arr <- newFloatArray (0,0)
+ arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 (fromRational r)
i <- readIntArray arr 0
return (CLit (MachInt (toInteger i) True))
doubleToWords (CLit (MachDouble r))
| big_doubles -- doubles are 2 words
= runST (do
- arr <- newDoubleArray (0,1)
+ arr <- newDoubleArray ((0::Int),1)
writeDoubleArray arr 0 (fromRational r)
i1 <- readIntArray arr 0
i2 <- readIntArray arr 1
)
| otherwise -- doubles are 1 word
= runST (do
- arr <- newDoubleArray (0,0)
+ arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
i <- readIntArray arr 0
return [ CLit (MachInt (toInteger i) True) ]