%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
\begin{code}
module PprAbsC (
writeRealC,
- dumpRealC
-#ifdef DEBUG
- , pprAmode -- otherwise, not exported
-#endif
+ dumpRealC,
+ pprAmode,
+ pprMagicId
) where
#include "HsVersions.h"
import IO ( Handle )
+import PrimRep
import AbsCSyn
import ClosureInfo
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import CallConv ( CallConv, callConvAttribute, cCallConv )
-import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
-import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
- isReadOnly, needsCDecl, pprCLabel,
- CLabel{-instance Ord-}
+
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute,
+ ForeignCall(..), Safety(..), DNCallSpec(..),
+ DNType(..), DNKind(..) )
+import CLabel ( externallyVisibleCLabel,
+ needsCDecl, pprCLabel, mkClosureLabel,
+ mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+ CLabel, CLabelType(..), labelType, labelDynamic
)
-import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
-import CostCentre ( uppCostCentre, uppCostCentreDecl )
+
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
+import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
+
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( stringToC )
+import CStrings ( pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
-import Literal ( showLiteral, Literal(..) )
-import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), showPrimRep )
-import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- isConstantRep, isSpecRep, isPhantomRep
- )
+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 Util ( nOfThem, panic, assertPanic )
+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}
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: Handle -> AbstractC -> SDoc -> IO ()
---writeRealC handle absC postlude =
+{-
+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 postlude =
- _scc_ "writeRealC"
- printForC handle (pprAbsC absC (costs absC) $$ postlude)
-
-dumpRealC :: AbstractC -> SDoc -> SDoc
-dumpRealC absC postlude
- | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC) $$ postlude)
- | otherwise = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude)
+
+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
\begin{code}
emitMacro :: CostRes -> SDoc
--- ToDo: Check a compile time flag to decide whether a macro should be emitted
+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,
pprAbsC AbsCNop _ = empty
pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
-pprAbsC (CClosureUpdInfo info) c
- = pprAbsC info 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 ])
(hcat [text jmp_lit, target, pp_paren_semi ])
where
target = case return_info of
- DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen]
+ 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 [parens (pprAmode am), brackets (text "RVREL" <> parens x)]
+ 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.
Just dc -> -- make it an "if"
do_if_stmt discrim tag alt_code dc c
-pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1),
- (tag2@(MachInt i2 _), alt_code2)] deflt) 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 (maybeToBool (nonemptyAbsC deflt))
+ empty_deflt = not (isJust (nonemptyAbsC deflt))
pprAbsC (CSwitch discrim alts deflt) c -- general case
| isFloatingRep (getAmodeRep discrim)
-- 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 liveness_mask vol_regs) _
- = pprCCall op args results liveness_mask vol_regs
+pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
+ = pprFCall fcall uniq args results vol_regs
-pprAbsC stmt@(COpStmt results op args liveness_mask 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
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
- case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
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 [ pprPrimOp op, lparen,
+ = 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)),
-- 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 stmt@(CMacroStmt macro as) _
- = hcat [text (show macro), lparen,
+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 stmt@(CCallProfCtrMacro op as) _
- = hcat [ptext op, lparen,
+pprAbsC (CCallProfCtrMacro op as) _
+ = hcat [ftext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallProfCCMacro op as) _
- = hcat [ptext op, lparen,
+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.
+
+ -}
-pprAbsC (CCodeBlock label abs_C) _
- = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+ 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 [
- hcat [text (if (externallyVisibleCLabel label)
+ empty,
+ pp_exts,
+ hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
- else "IFN_("),
- pprCLabel label, text ") {"],
+ else "IF_("),
+ 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 ' ' ]
}
-pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
- = hcat [ pp_init_hdr, text "_HDR(",
- ppr_amode (CAddr reg_rel), comma,
- pprCLabel info_lbl, comma,
+
+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,
- pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
+ if_profiling (int size),
+ pp_paren_semi ]
where
info_lbl = infoTableLabelFromCI cl_info
- sm_rep = closureSMRep cl_info
- size = closureSizeWithoutFixedHdr cl_info
- ptr_wds = closurePtrsSize cl_info
- pp_init_hdr = text (if inplace_upd then
- getSMUpdInplaceHdrStr sm_rep
- else
- getSMInitHdrStr sm_rep)
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,
+ ptext SLIT("SET_STATIC_HDR"), char '(',
+ pprCLabel closure_lbl, comma,
pprCLabel info_lbl, comma,
- if_profiling (pprAmode cost_centre), comma,
+ if_profiling (pprAmode cost_centre), comma,
ppLocalness closure_lbl, comma,
- ppLocalnessMacro False{-for data-} info_lbl,
+ ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
- nest 2 (hcat (map ppr_item amodes)),
- nest 2 (hcat (map ppr_item padding_wds)),
+ nest 2 (ppr_payload amodes),
ptext SLIT("};") ]
}
where
- info_lbl = infoTableLabelFromCI cl_info
-
- ppr_item item
- = if getAmodeRep item == VoidRep
- then text ", (W_) 0" -- might not even need this...
- else (<>) (text ", (W_)") (ppr_amode item)
-
- padding_wds =
- if not (closureUpdReqd cl_info) then
- []
- else
- case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
- nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
-
-{-
- STATIC_INIT_HDR(c,i,localness) blows into:
- localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
-
- then *NO VarHdr STUFF FOR STATIC*...
+ 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
- then the amodes are dropped in...
- ,a1 ,a2 ... ,aN
- then a close brace:
- };
--}
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
+ = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
- hcat [
- pp_info_rep,
- ptext SLIT("_ITBL"),char '(',
- pprCLabel info_lbl, comma,
-
- -- CONST_ITBL needs an extra label for
- -- the static version of the object.
- if isConstantRep sm_rep
- then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma
- else empty,
-
- pprCLabel slow_lbl, comma,
- pprAmode upd, comma,
- int liveness, comma,
-
- pp_tag, comma,
- pp_size, comma,
- pp_ptr_wds, comma,
-
- ppLocalness info_lbl, comma,
- ppLocalnessMacro True{-function-} slow_lbl, comma,
-
- if is_selector
- then (<>) (int select_word_i) comma
- else empty,
-
- if_profiling pp_kind, comma,
- if_profiling pp_descr, comma,
- if_profiling pp_type,
- text ");"
- ],
- pp_slow,
- case maybe_fast of
- Nothing -> empty
- Just fast -> let stuff = CCodeBlock fast_lbl fast in
- pprAbsC stuff (costs stuff)
+ 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]
]
- where
- info_lbl = infoTableLabelFromCI cl_info
- fast_lbl = fastLabelFromCI cl_info
- sm_rep = closureSMRep cl_info
-
- (slow_lbl, pp_slow)
- = case (nonemptyAbsC slow) of
- Nothing -> (mkErrorStdEntryLabel, empty)
- Just xx -> (entryLabelFromCI cl_info,
- let stuff = CCodeBlock slow_lbl xx in
- pprAbsC stuff (costs stuff))
-
- maybe_selector = maybeSelectorInfo cl_info
- is_selector = maybeToBool maybe_selector
- (Just (_, select_word_i)) = maybe_selector
- pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
- = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
-
- pp_tag = int (closureSemiTag cl_info)
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
+\end{code}
- is_phantom = isPhantomRep sm_rep
+Info tables... just arrays of words (the translation is done in
+ClosureInfo).
- pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
- int (closureNonHdrSize cl_info)
+\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}
- else if is_phantom then -- do not have sizes for these
- empty
- else
- pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
-
- pp_ptr_wds = if is_phantom then
- empty
- else
- int (closurePtrsSize cl_info)
-
- pp_kind = text (closureKind cl_info)
- pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
- pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
-
-pprAbsC (CRetVector lbl maybes deflt) c
- = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
- nest 8 (sep (map ppr_maybe_amode maybes)),
- text "} /*default=*/ {", pprAbsC deflt c,
- char '}']
+\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
- ppr_maybe_amode Nothing = ptext SLIT("/*default*/")
- ppr_maybe_amode (Just a) = pprAmode a
+ is_visible = externallyVisibleCLabel clabel
+ label_type = labelType clabel
-pprAbsC stmt@(CRetUnVector label amode) _
- = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
- pprAmode amode, rparen]
- where
- pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
-
-pprAbsC stmt@(CFlatRetVector label amodes) _
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [ppLocalness label, ptext SLIT(" W_ "),
- pprCLabel label, text "[] = {"],
- nest 2 (sep (punctuate comma (map ppr_item amodes))),
- text "};" ] }
- where
- ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
+ visiblity_prefix
+ | is_visible = char 'E'
+ | otherwise = char 'I'
-pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
-\end{code}
+ dyn_prefix
+ | include_dyn_prefix && labelDynamic clabel = char 'D'
+ | otherwise = empty
-\begin{code}
-ppLocalness label
- = (<>) static const
- where
- static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
- const = if not (isReadOnly label) then empty else ptext SLIT("const")
-
-ppLocalnessMacro for_fun{-vs data-} clabel
- = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
- if for_fun then
- ptext SLIT("F_")
- else
- (<>) (ptext SLIT("D_"))
- (if isReadOnly clabel then
- ptext SLIT("RO_")
- else
- empty)]
\end{code}
\begin{code}
\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)
(($$) ((<>) (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, 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.
-pp_basic_saves
- = vcat [
- ptext SLIT("CALLER_SAVE_Base"),
- ptext SLIT("CALLER_SAVE_SpA"),
- ptext SLIT("CALLER_SAVE_SuA"),
- ptext SLIT("CALLER_SAVE_SpB"),
- ptext SLIT("CALLER_SAVE_SuB"),
- ptext SLIT("CALLER_SAVE_Ret"),
--- ptext SLIT("CALLER_SAVE_Activity"),
- ptext SLIT("CALLER_SAVE_Hp"),
- ptext SLIT("CALLER_SAVE_HpLim") ]
-
-pp_basic_restores
- = vcat [
- ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
- ptext SLIT("CALLER_RESTORE_SpA"),
- ptext SLIT("CALLER_RESTORE_SuA"),
- ptext SLIT("CALLER_RESTORE_SpB"),
- ptext SLIT("CALLER_RESTORE_SuB"),
- ptext SLIT("CALLER_RESTORE_Ret"),
--- ptext SLIT("CALLER_RESTORE_Activity"),
- ptext SLIT("CALLER_RESTORE_Hp"),
- ptext SLIT("CALLER_RESTORE_HpLim"),
- ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
- ptext SLIT("CALLER_RESTORE_StkStub") ]
+-- 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}
-- ---------------------------------------------------------------------------
do_if_stmt discrim tag alt_code deflt c
- = 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)
- deflt alt_code
- (addrModeCosts discrim Rhs) c
- other -> let
- cond = hcat [ pprAmode discrim,
- ptext SLIT(" == "),
- pprAmode (CLit tag) ]
- in
- ppr_if_stmt cond
- alt_code deflt
- (addrModeCosts discrim Rhs) 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 [
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
-{- Doesn't apply anymore with ForeignObj, structure created via the primop.
- makeForeignObj (i.e., ForeignObj is not CReturnable)
-7) If returning Malloc Pointer, build a closure containing the
- appropriate value.
--}
Otherwise, copy local variable into result register.
8) If ccall (not casm), declare the function being called as extern so
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 foreign obj to a _ccall_GC_ thing.)
+ 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}
-pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask vol_regs
- = if (may_gc && liveness_mask /= noLiveRegsMask)
- then pprPanic "Live register in _casm_GC_ "
- (doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
- else
- vcat [
- char '{',
- declare_fun_extern, -- declare expected function type.
- declare_local_vars, -- local var for *result*
- vcat local_arg_decls,
- pp_save_context,
- process_casm local_vars pp_non_void_args casm_str,
- pp_restore_context,
- assign_results,
- char '}'
- ]
+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
-
- (pp_save_context, pp_restore_context)
- | may_gc =
- ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;"
- , text "inCCallGC--; RestoreAllStgRegs();} while(0);"
- )
- | 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)
+
+ 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 (length nvrs <= 1) nvrs
+ 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..] ]
- pp_liveness = pprAmode (mkIntCLit liveness_mask)
-
- {-
- 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.
-
- -}
- declare_fun_extern
- | is_asm || not opt_EmitCExternDecls = empty
- | otherwise =
- hsep [ typedef_or_extern
- , ccall_res_ty
- , fun_nm
- , parens (hsep (punctuate comma ccall_decl_ty_args))
- ] <> semi
- where
- typedef_or_extern
- | is_dynamic = ptext SLIT("typedef")
- | otherwise = ptext SLIT("extern")
-
- fun_nm
- | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
- | otherwise = text (callConvAttribute cconv) <+> ptext asm_str
-
- -- leave out function pointer
- ccall_decl_ty_args
- | is_dynamic = tail ccall_arg_tys
- | otherwise = ccall_arg_tys
-
- ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
-
- ccall_res_ty =
- case non_void_results of
- [] -> ptext SLIT("void")
- [amode] -> text (showPrimRep (getAmodeRep amode))
- _ -> panic "pprCCall: ccall_res_ty"
-
- ccall_fun_ty = ptext SLIT("_ccall_fun_ty")
-
(declare_local_vars, local_vars, assign_results)
- = ppr_casm_results non_void_results pp_liveness
+ = ppr_casm_results non_void_results forDotnet
- (Just asm_str) = op_str
- is_dynamic = not (maybeToBool op_str)
+ forDotnet
+ = case call of
+ DNCall{} -> True
+ _ -> False
- casm_str = if is_asm then _UNPK_ asm_str else ccall_str
-
- -- Remainder only used for ccall
+ 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)
- fun_name
- | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
- | otherwise = ptext asm_str
+ ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
+ dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
+
- ccall_str = showSDoc
+ -- Remainder only used for ccall
+ mk_ccall_str fun_name ccall_fun_args = showSDoc
(hcat [
if null non_void_results
then empty
text "));"
])
- ccall_fun_args
- | is_dynamic = tail ccall_args
- | otherwise = ccall_args
-
- ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
-
-\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
-passed are @Array@s, @ByteArray@s and @ForeignObj@s.
+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"
-\begin{code}
ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
-- (a) decl and assignment, (b) local var to be used later
local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
- (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)
- ArrayRep -> (pp_kind,
- hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
- ByteArrayRep -> (pp_kind,
- hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
-
- -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
- ForeignObjRep -> (ptext SLIT("StgForeignObj"),
- hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
- pp_amode, char ')'])
- other -> (pp_kind, pp_amode)
-
declare_local_var
- = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
+ = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]
in
(declare_local_var, local_var)
\end{code}
We only allow zero or one results.
-{- With the introduction of ForeignObj (MallocPtr++), no longer necess.
-2) Is the result is a foreign obj?
-
- The mallocptr must be encapsulated immediately in a heap object.
--}
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
- -> SDoc -- liveness mask
+ -> 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 [] liveness
+ppr_casm_results [] _
= (empty, [], empty) -- no results
-ppr_casm_results [r] liveness
- = let
+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")
+ local_var = ptext SLIT("_ccall_result") <> text suf
(result_type, assign_result)
- = case r_kind of
-{-
- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
- Instead, external references have to explicitly turned into ForeignObjs
- using the primop makeForeignObj#. Benefit: Multiple finalisation
- routines can be accommodated and the below special case is not needed.
- Price is, of course, that you have to explicitly wrap `foreign objects'
- with makeForeignObj#.
-
- ForeignObjRep ->
- (ptext SLIT("StgForeignObj"),
- hcat [ ptext SLIT("constructForeignObj"),char '(',
- liveness, comma,
- result_reg, comma,
- local_var,
- pp_paren_semi ])
--}
- _ ->
- (pprPrimKind r_kind,
- hcat [ result_reg, equals, local_var, semi ])
+ = (pprPrimKind r_kind,
+ hcat [ result_reg, equals, local_var, semi ])
declare_local_var = hcat [ result_type, space, local_var, semi ]
- in
- (declare_local_var, [local_var], assign_result)
-ppr_casm_results rs liveness
- = panic "ppr_casm_results: ccall/casm with many results"
\end{code}
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 PrimIO ()\n")
+ 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)
+ 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)
+ [r] -> r <> (process [] args css)
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
in
case (read_int other) of
[(num,css)] ->
- if 0 <= num && num < length args
- then (<>) (parens (args !! num))
- (process ress args css)
- else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
+ 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)
+ = char other_c <> process ress args cs
\end{code}
%************************************************************************
\begin{code}
pprAssign FloatRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = 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"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = 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"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = 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"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = 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 B stack.
+ 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 B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things
-of fixed type.
+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))
text "(P_)(", -- Here is the cast
ppr_amode src, pp_paren_semi ]
-pprAssign ByteArrayRep dest src
- | mixedPtrLocn src
- -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
- = hcat [ ppr_amode dest, equals,
- text "(B_)(", -- Here is the cast
- ppr_amode src, pp_paren_semi ]
-
pprAssign kind other_dest src
= hcat [ ppr_amode other_dest, equals,
pprAmode src, semi ]
\begin{code}
pprAmode (CVal reg_rel FloatRep)
- = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel DoubleRep)
- = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Int64Rep)
- = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Word64Rep)
- = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
+ = 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
= 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 (CAddr reg_rel)
= case (pprRegRelative True{-sign wanted-} reg_rel) of
(pp_reg, Nothing) -> pp_reg
- (pp_reg, Just offset) -> (<>) pp_reg offset
+ (pp_reg, Just offset) -> pp_reg <> offset
ppr_amode (CReg magic_id) = pprMagicId magic_id
-ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_'
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode (CLbl label kind) = pprCLabel label
-
-ppr_amode (CUnVecLbl direct vectored)
- = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma,
- pprCLabel vectored, rparen]
+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 (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
- -- ToDo: are these *used* for anything?
-
ppr_amode (CLit lit) = pprBasicLit lit
-ppr_amode (CLitLit str _) = ptext str
-
-ppr_amode (COffset off) = pprHeapOffset off
-
-ppr_amode (CCode abs_C)
- = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CLabelledCode label abs_C)
- = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")],
- nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CJoinPoint _ _)
+ppr_amode (CJoinPoint _)
= panic "ppr_amode: CJoinPoint"
-ppr_amode (CTableEntry base index kind)
- = hcat [text "((", pprPrimKind kind, text " *)(",
- ppr_amode base, text "))[(I_)(", ppr_amode index,
- ptext SLIT(")]")]
-
ppr_amode (CMacroExpr pk macro as)
- = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen,
- hcat (punctuate comma (map pprAmode as)), text "))"]
+ = 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 UPD_FRAME_UPDATEE = SLIT("UPD_FRAME_UPDATEE")
+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}
-ppr_amode (CCostCentre cc print_as_string)
- = uppCostCentre print_as_string cc
+%************************************************************************
+%* *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%* *
+%************************************************************************
+
+\begin{code}
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs
\end{code}
%************************************************************************
-> RegRelative
-> (SDoc, Maybe SDoc)
-pprRegRelative sign_wanted (SpARel spA off)
- = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off))
+pprRegRelative sign_wanted (SpRel off)
+ = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
-pprRegRelative sign_wanted (SpBRel spB off)
- = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
-
-pprRegRelative sign_wanted r@(HpRel hp off)
- = let to_print = hp `subOff` off
- pp_Hp = pprMagicId Hp
+pprRegRelative sign_wanted r@(HpRel o)
+ = let pp_Hp = pprMagicId Hp; off = I# o
in
- if isZeroOff to_print then
+ if off == 0 then
(pp_Hp, Nothing)
else
- (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print)))
- -- No parens needed because pprHeapOffset
- -- does them when necessary
+ (pp_Hp, Just ((<>) (char '-') (int off)))
-pprRegRelative sign_wanted (NodeRel off)
- = let pp_Node = pprMagicId node
+pprRegRelative sign_wanted (NodeRel o)
+ = let pp_Node = pprMagicId node; off = I# o
in
- if isZeroOff off then
+ if off == 0 then
(pp_Node, Nothing)
else
- (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off)))
+ (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
pprMagicId :: MagicId -> SDoc
pprMagicId BaseReg = ptext SLIT("BaseReg")
-pprMagicId StkOReg = ptext SLIT("StkOReg")
pprMagicId (VanillaReg pk n)
= hcat [ pprVanillaReg n, char '.',
pprUnionTag pk ]
-pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
-pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
-pprMagicId (LongReg _ n) = (<>) (ptext SLIT("LngReg")) (int IBOX(n))
-pprMagicId TagReg = ptext SLIT("TagReg")
-pprMagicId RetReg = ptext SLIT("RetReg")
-pprMagicId SpA = ptext SLIT("SpA")
-pprMagicId SuA = ptext SLIT("SuA")
-pprMagicId SpB = ptext SLIT("SpB")
-pprMagicId SuB = ptext SLIT("SuB")
-pprMagicId Hp = ptext SLIT("Hp")
+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 LivenessReg = ptext SLIT("LivenessReg")
-pprMagicId StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
-pprMagicId StkStubReg = ptext SLIT("StkStubReg")
-pprMagicId CurCostCentre = ptext SLIT("CCC")
+pprMagicId CurCostCentre = ptext SLIT("CCCS")
pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
-pprVanillaReg :: FAST_INT -> SDoc
-
-pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
+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 'r'
+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 AddrRep = char 'v'
+pprUnionTag Int32Rep = char 'i'
+pprUnionTag Word32Rep = char 'w'
+pprUnionTag AddrRep = char 'a'
pprUnionTag FloatRep = char 'f'
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
-pprUnionTag StablePtrRep = char 'i'
-pprUnionTag ForeignObjRep = char 'p'
-
-pprUnionTag ArrayRep = char 'p'
-pprUnionTag ByteArrayRep = char 'b'
+pprUnionTag StablePtrRep = char 'p'
pprUnionTag _ = panic "pprUnionTag:Odd kind"
\end{code}
False)
labelSeenTE :: CLabel -> TeM Bool
-labelSeenTE label env@(seen_uniqs, seen_labels)
- = if (label `elementOfCLabelSet` seen_labels)
+labelSeenTE lbl env@(seen_uniqs, seen_labels)
+ = if (lbl `elementOfCLabelSet` seen_labels)
then (env, True)
else ((seen_uniqs,
- addToCLabelSet seen_labels label),
+ addToCLabelSet seen_labels lbl),
False)
\end{code}
\begin{code}
pprTempDecl :: Unique -> PrimRep -> SDoc
pprTempDecl uniq kind
- = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
-
-pprExternDecl :: CLabel -> PrimRep -> SDoc
-
-pprExternDecl clabel kind
- = if not (needsCDecl clabel) then
- empty -- do not print anything for "known external" things (e.g., < PreludeCore)
- else
- case (
- case kind of
- CodePtrRep -> ppLocalnessMacro True{-function-} clabel
- _ -> ppLocalnessMacro False{-data-} clabel
- ) of { pp_macro_str ->
+ = 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
- hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
- }
\end{code}
\begin{code}
ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
returnTE (maybe_vcat [p1, p2])
-ppr_decls_AbsC (CClosureUpdInfo info)
- = ppr_decls_AbsC info
-
ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
ppr_decls_AbsC (CAssign dest source)
where
ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
-ppr_decls_AbsC (CCodeBlock label absC)
+ppr_decls_AbsC (CCodeBlock lbl absC)
= ppr_decls_AbsC absC
-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
+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 info_lbl PtrRep))
+ Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
where
info_lbl = infoTableLabelFromCI cl_info
-ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
-ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
+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
-- no real reason to, anyway.
ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre 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 slow maybe_fast upd_lbl _ _)
- = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
- ppr_decls_AbsC slow `thenTE` \ p2 ->
- (case maybe_fast of
- Nothing -> returnTE (Nothing, Nothing)
- Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
- returnTE (maybe_vcat [p1, p2, p3])
- where
- entry_lbl = CLbl slow_lbl CodePtrRep
- slow_lbl = case (nonemptyAbsC slow) of
- Nothing -> mkErrorStdEntryLabel
- Just _ -> entryLabelFromCI cl_info
-
-ppr_decls_AbsC (CRetVector label maybe_amodes absC)
- = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
- ppr_decls_AbsC absC `thenTE` \ p2 ->
+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 (CRetUnVector _ amode) = ppr_decls_Amode amode
-ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
+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 (CString _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
-- CIntLike must be a literal -- no decls
ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
--- CCharLike may have be arbitrary value -- may have decls
-ppr_decls_Amode (CCharLike char)
- = ppr_decls_Amode char
+-- 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)
returnTE
(if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
-ppr_decls_Amode (CLbl label VoidRep)
+ppr_decls_Amode (CLbl lbl VoidRep)
= returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLbl label kind)
- = labelSeenTE label `thenTE` \ label_seen ->
+ppr_decls_Amode (CLbl lbl kind)
+ = labelSeenTE lbl `thenTE` \ label_seen ->
returnTE (Nothing,
- if label_seen then Nothing else Just (pprExternDecl label kind))
-
-{- WRONG:
-ppr_decls_Amode (CUnVecLbl direct vectored)
- = labelSeenTE direct `thenTE` \ dlbl_seen ->
- labelSeenTE vectored `thenTE` \ vlbl_seen ->
- let
- ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
- vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
- in
- returnTE (Nothing,
- if (dlbl_seen || not (needsCDecl direct)) &&
- (vlbl_seen || not (needsCDecl vectored)) then Nothing
- else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
--}
-
-ppr_decls_Amode (CUnVecLbl direct vectored)
- = -- We don't mark either label as "seen", because
- -- we don't know which one will be used and which one tossed
- -- by the C macro...
- --labelSeenTE direct `thenTE` \ dlbl_seen ->
- --labelSeenTE vectored `thenTE` \ vlbl_seen ->
- let
- ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
- vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
- in
- returnTE (Nothing,
- if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
- ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
- else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
-
-ppr_decls_Amode (CTableEntry base index _)
- = ppr_decls_Amode base `thenTE` \ p1 ->
- ppr_decls_Amode index `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
+ if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))
ppr_decls_Amode (CMacroExpr _ _ amodes)
= 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}
projects / ghc-hetmet.git / blobdiff