)
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
- playThreadSafe, ccallConvAttribute )
+ playThreadSafe, ccallConvAttribute,
+ ForeignCall(..), DNCallSpec(..),
+ DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
-import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
)
import StgSyn ( StgOp(..) )
-import BitSet ( BitSet, intBS )
import Outputable
import FastString
import Util ( lengthExceeds )
-import Constants ( wORD_SIZE )
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
}
pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
- = pp_liveness_switch liveness semi $
- hcat [ ptext SLIT("BITMAP"), lparen,
- pprCLabel lbl, comma,
- int size, comma,
- pp_bitmap mask, rparen ]
+ = 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("}}")]
rep = getAmodeRep item
pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
- = pprInfoTable info_lbl (mkInfoTable cl_info)
+ = pprWordArray info_lbl (mkInfoTable cl_info)
$$ let stuff = CCodeBlock entry_lbl entry in
pprAbsC stuff (costs stuff)
where
) $$ ptext SLIT("};")
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
- = pprInfoTable info_lbl (mkRetInfoTable entry_lbl srt liveness)
+ = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
$$ let stuff = CCodeBlock entry_lbl code in
pprAbsC stuff (costs stuff)
where
entry_lbl = mkReturnPtLabel uniq
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
- = pprInfoTable lbl (mkVecInfoTable amodes srt liveness)
+ = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
ClosureInfo).
\begin{code}
-pprInfoTable info_lbl amodes
+pprWordArray lbl amodes
= (case snd (initTE (ppr_decls_Amodes amodes)) of
Just pp -> pp
Nothing -> empty)
- $$ hcat [ ppLocalness info_lbl, ptext SLIT("StgWord "),
- pprCLabel info_lbl, ptext SLIT("[] = {") ]
+ $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "),
+ pprCLabel lbl, ptext SLIT("[] = {") ]
$$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
$$ ptext SLIT("};")
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
- = vcat [
- char '{',
- declare_local_vars, -- local var for *result*
- vcat local_arg_decls,
- pp_save_context,
- process_casm local_vars pp_non_void_args call_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
+ 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
-
- thread_macro_args = ppr_uniq_token <> comma <+>
- text "rts" <> ppr (playThreadSafe safety)
- ppr_uniq_token = text "tok_" <> ppr uniq
- (pp_save_context, pp_restore_context)
+
+ 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
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (listLengthCmp nvrs 1 /= GT) 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.
= 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
+ = ppr_casm_results non_void_results forDotnet
+
+ forDotnet
+ = case call of
+ DNCall{} -> True
+ _ -> False
- call_str = case target of
- CasmTarget str -> unpackFS str
- StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
- DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
+ call_str tgt
+ = case tgt of
+ 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")
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
\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 []
+ppr_casm_results [] _
= (empty, [], empty) -- no results
-ppr_casm_results [r]
- = 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)
= (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
- = panic "ppr_casm_results: ccall/casm with many results"
\end{code}
amode has kind2.
\begin{code}
-ppr_amode CBytesPerWord
- = text "(sizeof(void*))"
-
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
= case (pprRegRelative False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> panic "ppr_amode: CIndex"
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")
cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE")
\end{code}
-\begin{code}
-\end{code}
-
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
%************************************************************************
\begin{code}
-pp_bitmap_switch :: Int -> SDoc -> SDoc -> SDoc
-pp_bitmap_switch size small large
- | size <= mAX_SMALL_BITMAP_SIZE = small
- | otherwise = large
-
--- magic numbers, must agree with BITMAP_BITS_SHIFT in InfoTables.h
-mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27
- | otherwise = 58
-
-pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc
-pp_liveness_switch (Liveness _ size _) = pp_bitmap_switch size
-
-pp_bitset :: BitSet -> SDoc
-pp_bitset s
- | i < -1 = int (i + 1) <> text "-1"
- | otherwise = int i
- where i = intBS s
-
-pp_bitmap :: [BitSet] -> SDoc
-pp_bitmap [] = int 0
-pp_bitmap ss = hcat (punctuate (ptext SLIT(" COMMA ")) (bundle ss)) where
- bundle [] = []
- bundle [s] = [hcat bitmap32]
- where bitmap32 = [ptext SLIT("BITMAP32"), lparen,
- pp_bitset s, rparen]
- bundle (s1:s2:ss) = hcat bitmap64 : bundle ss
- where bitmap64 = [ptext SLIT("BITMAP64"), lparen,
- pp_bitset s1, comma, pp_bitset s2, rparen]
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs
\end{code}
%************************************************************************
pprMagicId Hp = ptext SLIT("Hp")
pprMagicId HpLim = ptext SLIT("HpLim")
pprMagicId CurCostCentre = ptext SLIT("CCCS")
-pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
+pprMagicId VoidReg = ptext SLIT("VoidReg")
pprVanillaReg :: Int# -> SDoc
pprVanillaReg n = char 'R' <> int (I# n)