#include "HsVersions.h"
-import MachMisc
+-- import MachMisc
import Stix
import PprAbsC ( pprAmode )
import SMRep ( fixedHdrSize )
import Literal ( Literal(..), word2IntLit )
import MachOp ( MachOp(..) )
-import PrimRep ( PrimRep(..), getPrimRepArrayElemSize )
+import PrimRep ( PrimRep(..), getPrimRepSizeInBytes )
import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
import Constants ( wORD_SIZE,
mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
rESERVED_STACK_WORDS )
import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
- mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
+ mkMAP_FROZEN_infoLabel,
mkForeignLabel )
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
- CCallConv(..), playSafe )
+ CCallConv(..), playSafe, playThreadSafe )
import Outputable
+import Util ( notNull )
+import FastString
import FastTypes
#include "NCG.h"
calling.
\begin{code}
-foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
+foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
| not (playSafe safety)
= returnUs (\xs -> ccall : xs)
| otherwise
- = save_thread_state `thenUs` \ save ->
- load_thread_state `thenUs` \ load ->
- getUniqueUs `thenUs` \ uniq ->
+ = save_thread_state `thenUs` \ save ->
+ load_thread_state `thenUs` \ load ->
+ getUniqueUs `thenUs` \ uniq ->
let
id = StixTemp (StixVReg uniq IntRep)
+
+ is_threadSafe
+ | playThreadSafe safety = 1
+ | otherwise = 0
suspend = StAssignReg IntRep id
- (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
- IntRep [StReg stgBaseReg])
+ (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
+ IntRep [StReg stgBaseReg, StInt is_threadSafe ])
resume = StVoidable
- (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
- VoidRep [StReg id])
+ (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
+ VoidRep [StReg id, StInt is_threadSafe ])
in
returnUs (\xs -> save (suspend : ccall : resume : load xs))
where
- args = map amodeCodeForCCall rhs
- amodeCodeForCCall x =
- let base = amodeToStix' x
- in
- case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base arrPtrsHS
- ByteArrayRep -> StIndex IntRep base arrWordsHS
- ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
- _ -> base
+ (cargs, stix_target)
+ = case ctarget of
+ StaticTarget nm -> (rhs, Left nm)
+ DynamicTarget | notNull rhs -- an assertion
+ -> (tail rhs, Right (amodeToStix (head rhs)))
+ CasmTarget _
+ -> ncgPrimopMoan "Native code generator can't handle foreign call"
+ (ppr call)
+
+ stix_args = map amodeToStix' cargs
ccall = case lhs of
- [] -> StVoidable (StCall fn cconv VoidRep args)
- [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
+ [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
+ [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
where
lhs' = amodeToStix lhs
pk = case getAmodeRep lhs of
Word64Rep -> Word64Rep
other -> IntRep
-foreignCallCode lhs call rhs
- = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
+-- a bit late to catch this here..
+foreignCallCode _ DNCall{} _
+ = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
\end{code}
%************************************************************************
amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
-amodeToStix CBytesPerWord
- = StInt (toInteger wORD_SIZE)
-
-amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr)
-
amodeToStix (CAddr (SpRel off))
= StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
= case core of
MachChar c -> StInt (toInteger c)
MachStr s -> StString s
- MachAddr a -> StInt a
+ MachNullAddr -> StInt 0
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
MachLitLit s _ -> litLitErr
- MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
+ -- dreadful, but rare.
+ MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
+ MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
MachFloat d -> StFloat d
MachDouble d -> StDouble d
_ -> panic "amodeToStix:core literal"
amodeToStix (CMacroExpr _ macro [arg])
- = case macro of
- ENTRY_CODE -> amodeToStix arg
- ARG_TAG -> amodeToStix arg -- just an integer no. of words
+ = let
+ arg_amode = amodeToStix arg
+ in
+ case macro of
+ ENTRY_CODE -> arg_amode
+ ARG_TAG -> arg_amode -- just an integer no. of words
GET_TAG ->
#ifdef WORDS_BIGENDIAN
StMachOp MO_Nat_And
- [StInd WordRep (StIndex PtrRep (amodeToStix arg)
+ [StInd WordRep (StIndex PtrRep arg_amode
(StInt (toInteger (-1)))),
StInt 65535]
#else
StMachOp MO_Nat_Shr
- [StInd WordRep (StIndex PtrRep (amodeToStix arg)
+ [StInd WordRep (StIndex PtrRep arg_amode
(StInt (toInteger (-1)))),
StInt 16]
#endif
UPD_FRAME_UPDATEE
- -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
+ -> StInd PtrRep (StIndex PtrRep arg_amode
(StInt (toInteger uF_UPDATEE)))
+ BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
+ PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
+ ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
+
+
amodeToStix other
= pprPanic "StixPrim.amodeToStix" (pprAmode other)
mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
-- these are the sizes of charLike and intLike closures, in _bytes_.
-charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
-intLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
+charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
+intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
\end{code}
\begin{code}
save_thread_state
= getUniqueUs `thenUs` \ tso_uq ->
- let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
+ let tso = StixTemp (StixVReg tso_uq PtrRep) in
returnUs (\xs ->
- StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
+ StAssignReg PtrRep tso (StReg stgCurrentTSO)
: StAssignMem PtrRep
(StMachOp MO_Nat_Add
[StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
(StReg stgSp)
- : StAssignMem PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
- (StReg stgSu)
: StAssignMem PtrRep
(StMachOp MO_Nat_Add
[StReg stgCurrentNursery,
load_thread_state
= getUniqueUs `thenUs` \ tso_uq ->
- let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
+ let tso = StixTemp (StixVReg tso_uq PtrRep) in
returnUs (\xs ->
- StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
+ StAssignReg PtrRep tso (StReg stgCurrentTSO)
: StAssignReg PtrRep
stgSp
(StInd PtrRep
(StMachOp MO_Nat_Add
[StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
: StAssignReg PtrRep
- stgSu
- (StInd PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
- : StAssignReg PtrRep
stgSpLim
(StMachOp MO_Nat_Add
[StReg tso,
projects / ghc-hetmet.git / blobdiff