)
import Constants ( mIN_UPD_SIZE )
-import CallConv ( CallConv, callConvAttribute, cCallConv )
+import CallConv ( CallConv, callConvAttribute )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
- mkStaticClosureLabel,
+ mkClosureLabel,
CLabel, CLabelType(..), labelType, labelDynamic
)
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( stringToC )
+import CStrings ( stringToC, pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import Const ( Literal(..) )
+import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
-import DataCon ( DataCon{-instance NamedThing-} )
+import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
+ PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
x, rparen ]
-pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
+pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")
-- we optimise various degenerate cases of CSwitches.
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
+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
-- 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 (CCallOp ccall) args vol_regs) _
+ = pprCCall ccall args results vol_regs
pprAbsC stmt@(COpStmt results op args vol_regs) _
= let
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef is_tdef op@(CCallOp op_str is_asm may_gc cconv) results args) _
+pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
ccall_fun_ty =
case op_str of
- Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
- Left x -> ptext x
+ DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+ StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
-- the first argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
non_void_args =
- let nvas = tail args
+ let nvas = init args
in ASSERT (all non_void nvas) nvas
-- there will usually be two results: a (void) state which we
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 "IFN_("),
pprCLabel lbl, text ") {"],
- pp_exts, pp_temps,
+ pp_temps,
nest 8 (ptext SLIT("FB_")),
nest 8 (pprAbsC abs_C (costs abs_C)),
nest 8 (ptext SLIT("FE_")),
- char '}' ]
+ char '}',
+ char ' ' ]
}
ptext SLIT("CLOSURE_TBL") <>
lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
punctuate comma (
- map (pp_closure_lbl . mkStaticClosureLabel . getName) (tyConDataCons tycon)
+ map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
)
) $$ ptext SLIT("};")
LvLarge _ -> SLIT("RET_VEC_BIG")
+pprAbsC stmt@(CModuleInitBlock lbl code) _
+ = vcat [
+ ptext SLIT("START_MOD_INIT") <> parens (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}
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
+ | include_dyn_prefix && labelDynamic clabel = char 'D'
+ | otherwise = empty
\end{code}
(($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
--- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
+-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, 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
- = vcat
- [ ptext SLIT("CALLER_SAVE_Base")
- , ptext SLIT("CALLER_SAVE_SYSTEM")
- ]
-
+pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM")
pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
\end{code}
= case tag of
-- This special case happens when testing the result of a comparison.
-- We can just avoid some redundant clutter in the output.
- MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim)
+ MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
deflt alt_code
(addrModeCosts discrim Rhs) c
- other -> let
+ other -> let
cond = hcat [ pprAmode discrim
, ptext SLIT(" == ")
, tcast
-- 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
+ tcast = case other of
+ MachInt _ -> ptext SLIT("(I_)")
+ _ -> empty
in
ppr_if_stmt cond
alt_code deflt
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
+pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
- | may_gc = ( text "do { I_ id; SaveThreadState(); id = suspendThread(BaseReg);"
- , text "BaseReg = resumeThread(id); LoadThreadState();} while(0);"
+ | may_gc = ( text "{ I_ id; SUSPEND_THREAD(id);"
+ , text "RESUME_THREAD(id);}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
- non_void_args =
- let nvas = tail args
- in ASSERT (all non_void nvas) nvas
- -- the first argument will be the "I/O world" token (a VoidRep)
+ non_void_args =
+ let nvas = init args
+ in ASSERT2 ( all non_void nvas, pprCCallOp 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 =
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
- ccall_fun_ty =
- ptext SLIT("_ccall_fun_ty") <>
- case op_str of
- Right u -> ppr u
- _ -> empty
-
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
- (Left asm_str) = op_str
- is_dynamic =
- case op_str of
- Left _ -> False
- _ -> True
-
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
+ StaticTarget asm_str = op_str -- Must be static if it's a casm
-- Remainder only used for ccall
- fun_name
- | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
- | otherwise = ptext asm_str
+ fun_name = case op_str of
+ DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+ StaticTarget st -> pprCLabelString st
ccall_str = showSDoc
(hcat [
if null non_void_results
then empty
else text "%r = ",
- lparen, fun_name, lparen,
+ lparen, parens fun_name, lparen,
hcat (punctuate comma ccall_fun_args),
text "));"
])
- ccall_fun_args
- | is_dynamic = tail ccall_args
- | otherwise = ccall_args
+ ccall_fun_args | isDynamicTarget op_str = tail ccall_args
+ | otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
process [] _ "" = empty
process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
string ++
- "\"\n(Try changing result type to PrimIO ()\n")
+ "\"\n(Try changing result type to IO ()\n")
process ress args ('%':cs)
= case cs of
= 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}
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
+cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH")
cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
pp_liveness lv =
case lv of
LvLarge lbl -> char '&' <> pprCLabel lbl
- LvSmall mask
- | bitmap_int == (minBound :: Int) -> int (bitmap_int+1) <> text "-1"
- | otherwise -> int bitmap_int
+ LvSmall mask -- Avoid gcc bug when printing minInt
+ | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1"
+ | otherwise -> int bitmap_int
where
bitmap_int = intBS mask
\end{code}
pprUnionTag FloatRep = char 'f'
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
-pprUnionTag StablePtrRep = char 'i'
+pprUnionTag StablePtrRep = char 'p'
pprUnionTag StableNameRep = char 'p'
pprUnionTag WeakPtrRep = char 'p'
pprUnionTag ForeignObjRep = char 'p'
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}
arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 (fromRational r)
i <- readIntArray arr 0
- return (CLit (MachInt (toInteger i) True))
+ return (CLit (MachInt (toInteger i)))
)
doubleToWords :: CAddrMode -> [CAddrMode]
writeDoubleArray arr 0 (fromRational r)
i1 <- readIntArray arr 0
i2 <- readIntArray arr 1
- return [ CLit (MachInt (toInteger i1) True)
- , CLit (MachInt (toInteger i2) True)
+ return [ CLit (MachInt (toInteger i1))
+ , CLit (MachInt (toInteger i2))
]
)
| otherwise -- doubles are 1 word
arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
i <- readIntArray arr 0
- return [ CLit (MachInt (toInteger i) True) ]
+ return [ CLit (MachInt (toInteger i)) ]
)
\end{code}
projects / ghc-hetmet.git / blobdiff