\begin{code}
module PprAbsC (
writeRealC,
- dumpRealC
-#ifdef DEBUG
- , pprAmode -- otherwise, not exported
- , pprMagicId
-#endif
+ dumpRealC,
+ pprAmode,
+ pprMagicId
) where
#include "HsVersions.h"
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
isReadOnly, needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel,
- CLabel, CLabelType(..), labelType
+ CLabel, CLabelType(..), labelType, labelDynamic
)
import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
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
$$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
<> ptext SLIT("};")
}
- where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
+ where
+ pp_closure_lbl lbl
+ | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
+ | otherwise = char '&' <> pprCLabel lbl
pprAbsC stmt@(CBitmap lbl mask) c
= vcat [
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)
pprCLabel info_lbl, comma,
if_profiling (pprAmode cost_centre), comma,
ppLocalness closure_lbl, comma,
- ppLocalnessMacro info_lbl,
+ ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
nest 2 (ppr_payload (amodes ++ padding_wds)),
pprCLabel slow_lbl, comma,
pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
- ppLocalness info_lbl, comma,
- ppLocalnessMacro slow_lbl, comma,
+ ppLocalness info_lbl, comma,
+ ppLocalnessMacro True{-include dyn-} slow_lbl, comma,
if_profiling pp_descr, comma,
if_profiling pp_type,
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 '"']
pp_srt_info srt, -- SRT
ptext type_str, comma, -- closure type
ppLocalness info_lbl, comma, -- info table storage class
- ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
+ ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class
int 0, comma,
int 0, text ");"
],
-- Horrible macros for declaring the types and locality of labels (see
-- StgMacros.h).
-ppLocalnessMacro clabel =
+ppLocalnessMacro include_dyn_prefix clabel =
hcat [
- char (if externallyVisibleCLabel clabel then 'E' else 'I'),
- case labelType clabel of
- InfoTblType -> ptext SLIT("I_")
+ visiblity_prefix,
+ dyn_prefix,
+ case label_type of
ClosureType -> ptext SLIT("C_")
CodeType -> ptext SLIT("F_")
+ InfoTblType -> ptext SLIT("I_")
DataType -> ptext SLIT("D_") <>
if isReadOnly clabel
then ptext SLIT("RO_")
else empty
]
+ where
+ is_visible = externallyVisibleCLabel clabel
+ label_type = labelType clabel
+ is_dynamic = labelDynamic clabel
+
+ visiblity_prefix
+ | is_visible = char 'E'
+ | otherwise = char 'I'
+
+ dyn_prefix
+ | not include_dyn_prefix = empty
+ | is_dynamic = char 'D'
+ | otherwise = empty
+
\end{code}
\begin{code}
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
ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode (CLbl label kind) = pprCLabelAddr label
+ppr_amode (CLbl label kind) = pprCLabelAddr label
ppr_amode (CCharLike ch)
= hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = char 'i'
+pprUnionTag StableNameRep = char 'p'
pprUnionTag WeakPtrRep = char 'p'
pprUnionTag ForeignObjRep = char 'p'
pprTempDecl uniq kind
= hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
-pprExternDecl :: CLabel -> PrimRep -> SDoc
+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
-pprExternDecl clabel kind
- = if not (needsCDecl clabel) then
- empty -- do not print anything for "known external" things
- else
- hcat [ ppLocalnessMacro clabel,
- lparen, pprCLabel clabel, pp_paren_semi ]
\end{code}
\begin{code}
if label_seen then
Nothing
else
- Just (pprExternDecl info_lbl PtrRep))
+ Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
where
info_lbl = infoTableLabelFromCI cl_info
= mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
returnTE (Nothing,
if and seen then Nothing
- else Just (vcat [ pprExternDecl l PtrRep
+ 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_Amode (CLbl label kind)
= labelSeenTE label `thenTE` \ label_seen ->
returnTE (Nothing,
- if label_seen then Nothing else Just (pprExternDecl label kind))
+ if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} label))
ppr_decls_Amode (CTableEntry base index _)
= ppr_decls_Amode base `thenTE` \ p1 ->
where
addr_of_label = ptext SLIT("(P_)&") <> pp_label
pp_label = pprCLabel clabel
+
\end{code}
-----------------------------------------------------------------------------
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) ]
projects / ghc-hetmet.git / blobdiff