mixedPtrLocn, mixedTypeLocn
)
-import Constants ( mIN_UPD_SIZE )
-import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute,
+ ForeignCall(..), DNCallSpec(..),
+ DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
- needsCDecl, pprCLabel,
+ needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
- mkClosureLabel, mkErrorStdEntryLabel,
CLabel, CLabelType(..), labelType, labelDynamic
)
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( pprStringInCStyle, pprCLabelString )
+import CStrings ( pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
-import DataCon ( dataConWrapId )
-import Maybes ( Maybe012(..), maybe012ToList, maybeToBool, catMaybes )
+import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
-import ForeignCall ( ForeignCall(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize )
-import SMRep ( pprSMRep )
+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 GlaExts
-import Util ( nOfThem, lengthExceeds, listLengthCmp )
-import Maybe ( isNothing )
+import FastString
+import Util ( lengthExceeds )
-import ST
+#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}
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)
-- NEW CASES FOR EXPANDED PRIMOPS
--- We have to deal with some of these specially
-pprAbsC (CMachOpStmt (Just1 res) (MO_ReadOSBI offw scaleRep)
- [baseAmode, indexAmode] maybe_vols)
- _
- | isNothing maybe_vols
- = hcat [ -- text " /* ReadOSBI */ ",
- ppr_amode res, equals,
- ppr_array_expression offw scaleRep baseAmode indexAmode,
- semi ]
- | otherwise
- = panic "pprAbsC:MO_ReadOSBI -- out-of-line array indexing ?!?!"
-
-pprAbsC (CMachOpStmt Just0 (MO_WriteOSBI offw scaleRep)
- [baseAmode, indexAmode, vAmode] maybe_vols)
- _
- | isNothing maybe_vols
- = hcat [ -- text " /* WriteOSBI */ ",
- ppr_array_expression offw scaleRep baseAmode indexAmode,
- equals, pprAmode vAmode,
- semi ]
- | otherwise
- = panic "pprAbsC:MO_WriteOSBI -- out-of-line array indexing ?!?!"
-
-pprAbsC (CMachOpStmt (Just2 res carry) mop [arg1,arg2] maybe_vols) _
- | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
- = hcat [ pprMachOp_for_C mop,
- lparen,
- ppr_amode res, comma, ppr_amode carry, comma,
- pprAmode arg1, comma, pprAmode arg2,
- rparen, semi ]
-
--- The rest generically.
-
-pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1,arg2] maybe_vols) _
- = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr]
+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 $$
$$ restores
}
-pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1] maybe_vols) _
+pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
= case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
saves $$
hcat [ppr_amode res, equals,
<> ptext SLIT("};")
}
-pprAbsC stmt@(CBitmap lbl mask) c
- = pp_bitmap_switch mask semi $
- hcat [ ptext SLIT("BITMAP"), lparen,
- pprCLabel lbl, comma,
- int (length mask), comma,
- pp_bitmap mask, rparen ]
+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("}}")]
= hcat [ptext (cStmtMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
pprAbsC (CCallProfCtrMacro op as) _
- = hcat [ptext op, lparen,
+ = hcat [ftext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC (CCallProfCCMacro op as) _
- = hcat [ptext op, lparen,
+ = 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"))
in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
pprAbsC (CCodeBlock lbl abs_C) _
- = if not (maybeToBool(nonemptyAbsC abs_C)) then
+ = 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) ->
pp_exts,
hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
- else "IFN_("),
+ else "IF_("),
pprCLabel lbl, text ") {"],
pp_temps,
pp_paren_semi ]
where
info_lbl = infoTableLabelFromCI cl_info
-
+
+
pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
- nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
+ nest 2 (ppr_payload amodes),
ptext SLIT("};") ]
}
where
- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
- ppr_payload ls = comma <+>
- braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
-
- ppr_item item
- | rep == VoidRep = text "0" -- might not even need this...
- | rep == FloatRep = ppr_amode (floatToWord item)
- | rep == DoubleRep = hcat (punctuate (text ", (L_)")
- (map ppr_amode (doubleToWords item)))
- | otherwise = ppr_amode item
+ 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
-
- upd_reqd = closureUpdReqd cl_info
+ rep = getAmodeRep item
- padding_wds
- | not upd_reqd = []
- | otherwise = case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->
- nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
-
- -- always have a static link field, it's used to save the closure's
- -- info pointer when we're reverting CAFs (see comment in Storage.c)
- static_link_field
- | upd_reqd || staticClosureNeedsLink cl_info = [mkIntCLit 0]
- | otherwise = []
-
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
- = vcat [
- hcat [
- ptext SLIT("INFO_TABLE"),
- ( if is_selector then
- ptext SLIT("_SELECTOR")
- else if is_constr then
- ptext SLIT("_CONSTR")
- else if needs_srt then
- ptext SLIT("_SRT")
- else empty ), char '(',
-
- pprCLabel info_lbl, comma,
- pprCLabel slow_lbl, comma,
- pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
-
- ppLocalness info_lbl, comma,
- ppLocalnessMacro True{-include dyn-} slow_lbl, 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)
- ]
+pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
+ = pprWordArray info_lbl (mkInfoTable cl_info)
+ $$ let stuff = CCodeBlock entry_lbl entry in
+ pprAbsC stuff (costs stuff)
where
- info_lbl = infoTableLabelFromCI cl_info
- fast_lbl = fastLabelFromCI 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
-
- maybe_tag = closureSemiTag cl_info
- is_constr = maybeToBool maybe_tag
- (Just tag) = maybe_tag
-
- srt = closureSRT cl_info
- needs_srt = case srt of
- NoC_SRT -> False
- other -> True
-
-
- size = closureNonHdrSize cl_info
-
- ptrs = closurePtrsSize cl_info
- nptrs = size - ptrs
-
- pp_rest | is_selector = int select_word_i
- | otherwise = hcat [
- int ptrs, comma,
- int nptrs, comma,
- if is_constr then
- hcat [ int tag, comma ]
- else if needs_srt then
- pp_srt_info srt
- else empty,
- type_str ]
-
- type_str = pprSMRep (closureSMRep cl_info)
-
- pp_descr = pprStringInCStyle cl_descr
- pp_type = pprStringInCStyle (closureTypeDescr cl_info)
+ 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 . dataConWrapId) (tyConDataCons tycon)
+ map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
)
) $$ ptext SLIT("};")
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
- = vcat [
- hcat [
- ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
- pprCLabel info_lbl, comma,
- pprCLabel entry_lbl, comma,
- pp_liveness liveness, comma, -- bitmap
- pp_srt_info srt, -- SRT
- closure_type, comma, -- closure type
- ppLocalness info_lbl, comma, -- info table storage class
- ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class
- int 0, comma,
- int 0, text ");"
- ],
- pp_code
- ]
+ = 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
-
- pp_code = let stuff = CCodeBlock entry_lbl code in
- pprAbsC stuff (costs stuff)
-
- closure_type = pp_liveness_switch liveness
- (ptext SLIT("RET_SMALL"))
- (ptext SLIT("RET_BIG"))
+ info_lbl = mkReturnInfoLabel uniq
+ entry_lbl = mkReturnPtLabel uniq
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [
- ptext SLIT("VEC_INFO_") <> int size,
- lparen,
- pprCLabel lbl, comma,
- pp_liveness liveness, comma, -- bitmap liveness mask
- pp_srt_info srt, -- SRT
- closure_type, comma,
- ppLocalness lbl, comma
- ],
- nest 2 (sep (punctuate comma (map ppr_item amodes))),
- text ");"
- ]
- }
-
- where
- ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
- size = length amodes
-
- closure_type = pp_liveness_switch liveness
- (ptext SLIT("RET_VEC_SMALL"))
- (ptext SLIT("RET_VEC_BIG"))
-
+ = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
-pprAbsC stmt@(CModuleInitBlock lbl code) _
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
- ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
+ 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]
pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
+Info tables... just arrays of words (the translation is done in
+ClosureInfo).
+
+\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}
+
\begin{code}
-- Print a CMachOp in a way suitable for emitting via C.
pprMachOp_for_C MO_Nat_Add = char '+'
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_Quot = char '/'
pprMachOp_for_C MO_NatU_Rem = char '%'
-pprMachOp_for_C MO_NatS_AddC = text "addIntCzh"
-pprMachOp_for_C MO_NatS_SubC = text "subIntCzh"
-pprMachOp_for_C MO_NatS_MulC = text "mulIntCzh"
-
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_16U_to_NatU = text "(StgWord16)(StgWord)"
pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)"
-pprMachOp_for_C (MO_ReadOSBI _ _) = panic "pprMachOp_for_C:MO_ReadOSBI"
-pprMachOp_for_C (MO_WriteOSBI _ _) = panic "pprMachOp_for_C:MO_WriteOSBI"
-
-
--- Helper for printing array expressions.
-ppr_array_expression offw scaleRep baseAmode indexAmode
- -- create:
- -- * (scaleRep*) (
- -- ((char*)baseAmode) + offw*bytes_per_word + indexAmode*bytes_per_scaleRep
- -- )
- = let offb = parens (int offw <> char '*' <> text "sizeof(void*)")
- indb = parens (parens (pprAmode indexAmode)
- <> char '*' <> int (getPrimRepArrayElemSize scaleRep))
- baseb = text "(char*)" <> parens (pprAmode baseAmode)
- addr = parens baseb <+> char '+' <+> offb <+> char '+' <+> indb
- in
- char '*' <> parens (ppr scaleRep <> char '*') <> parens addr
+pprMachOp_for_C MO_8U_to_32U = text "(StgWord32)"
+pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)"
ppLocalness lbl
visiblity_prefix,
dyn_prefix,
case label_type of
- ClosureType -> ptext SLIT("C_")
- CodeType -> ptext SLIT("F_")
- InfoTblType -> ptext SLIT("I_")
- ClosureTblType -> ptext SLIT("CP_")
- DataType -> ptext SLIT("D_")
+ 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
is_visible = externallyVisibleCLabel clabel
(($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
--- pp_basic_{saves,restores}: The BaseReg, Sp, Su, 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
\end{code}
\begin{code}
-pp_srt_info NoC_SRT = hcat [ int 0, comma,
- int 0, comma,
- int 0, comma ]
-pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma,
- int off, comma,
- int len, comma ]
-\end{code}
-
-\begin{code}
pp_closure_lbl lbl
| labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
| otherwise = char '&' <> pprCLabel lbl
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
+ 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)
- | playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);"
- , text "RESUME_THREAD(id);}"
+
+ 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 -> _UNPK_ 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
+ CasmTarget str -> unpackFS str
+ 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")
hcat (punctuate comma ccall_fun_args),
text "));"
])
-\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 and @ByteArray@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 -> (pp_kind,
- 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}
\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}
\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
text "(P_)(", -- Here is the cast
ppr_amode src, pp_paren_semi ]
-pprAssign ByteArrayRep dest src
- | mixedPtrLocn src
- -- Add in a cast iff the source is mixed
- = hcat [ ppr_amode dest, equals,
- text "(StgByteArray)(", -- 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
amode has kind2.
\begin{code}
-ppr_amode CBytesPerWord
- = text "(sizeof(void*))"
-
-ppr_amode (CMem rep addr)
- = let txt_rep = pprPrimKind rep
- in hcat [ char '*', parens (txt_rep <> char '*'), parens (ppr_amode addr) ]
-
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
= case (pprRegRelative False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> panic "ppr_amode: CIndex"
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
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 ARGS_CHK = SLIT("ARGS_CHK")
-cStmtMacroText ARGS_CHK_LOAD_NODE = SLIT("ARGS_CHK_LOAD_NODE")
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 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 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")
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_SEQ_NP = SLIT("HP_CHK_SEQ_NP")
-cCheckMacroText HP_CHK = SLIT("HP_CHK")
-cCheckMacroText STK_CHK = SLIT("STK_CHK")
-cCheckMacroText HP_STK_CHK = SLIT("HP_STK_CHK")
+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_UT_ALT = SLIT("HP_CHK_UT_ALT")
-cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN")
-\end{code}
-
-\begin{code}
+cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE")
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc
-pp_bitmap_switch ([ ]) small large = small
-pp_bitmap_switch ([_ ]) small large = small
-pp_bitmap_switch ([_,_]) small large = hcat
- [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen]
-pp_bitmap_switch (_ ) small large = large
-
-pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc
-pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask
-
-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 delayed_comma (bundle ss)) where
- delayed_comma = hcat [space, ptext SLIT("COMMA"), space]
- 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]
-
-pp_liveness :: Liveness -> SDoc
-pp_liveness (Liveness lbl mask)
- = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl)
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs
\end{code}
%************************************************************************
pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n)
pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n)
pprMagicId Sp = ptext SLIT("Sp")
-pprMagicId Su = ptext SLIT("Su")
pprMagicId SpLim = ptext SLIT("SpLim")
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)
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = char 'p'
-pprUnionTag StableNameRep = char 'p'
-pprUnionTag WeakPtrRep = char 'p'
-pprUnionTag ForeignObjRep = char 'p'
-pprUnionTag PrimPtrRep = char 'p'
-
-pprUnionTag ThreadIdRep = char 't'
-
-pprUnionTag ArrayRep = char 'p'
-pprUnionTag ByteArrayRep = char 'b'
-pprUnionTag BCORep = char 'p'
pprUnionTag _ = panic "pprUnionTag:Odd kind"
\end{code}
where
info_lbl = infoTableLabelFromCI cl_info
-ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybe012ToList res ++ args)
+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
-- 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 _)
+ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
= ppr_decls_Amodes [entry_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])
+ ppr_decls_AbsC entry `thenTE` \ p2 ->
+ returnTE (maybe_vcat [p1, p2])
where
- entry_lbl = CLbl slow_lbl CodePtrRep
- slow_lbl = case (nonemptyAbsC slow) of
- Nothing -> mkErrorStdEntryLabel
- Just _ -> entryLabelFromCI cl_info
+ entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
ppr_decls_AbsC (CSRT _ closure_lbls)
= mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
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 (CModuleInitBlock _ _ code) = ppr_decls_AbsC code
ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code}
pprCLabelAddr :: CLabel -> SDoc
pprCLabelAddr clabel =
case labelType clabel of
- InfoTblType -> addr_of_label
- ClosureType -> addr_of_label
- VecTblType -> addr_of_label
- _ -> pp_label
+ 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}
-----------------------------------------------------------------------------
\begin{code}
big_doubles = (getPrimRepSize DoubleRep) /= 1
--- floatss are always 1 word
+#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)
- i <- readIntArray arr 0
+ arr' <- castFloatToIntArray arr
+ i <- readIntArray arr' 0
return (CLit (MachInt (toInteger i)))
)
= runST (do
arr <- newDoubleArray ((0::Int),1)
writeDoubleArray arr 0 (fromRational r)
- i1 <- readIntArray arr 0
- i2 <- readIntArray arr 1
+ arr' <- castDoubleToIntArray arr
+ i1 <- readIntArray arr' 0
+ i2 <- readIntArray arr' 1
return [ CLit (MachInt (toInteger i1))
, CLit (MachInt (toInteger i2))
]
= runST (do
arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
- i <- readIntArray arr 0
+ arr' <- castDoubleToIntArray arr
+ i <- readIntArray arr' 0
return [ CLit (MachInt (toInteger i)) ]
)
\end{code}
projects / ghc-hetmet.git / blobdiff