X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=64932e3138c9da1e3ed9e48b4ba7e3f646c9b1fb;hb=e6834cad29914f123edb32c20d42b16e3308e667;hp=5bac1b56693e15532643962dbd46813ebf82d66f;hpb=70d68b088f9531ceb1ff6fa5cad1ee285f9c7187;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 5bac1b5..64932e3 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -8,7 +8,7 @@ where #include "HsVersions.h" -import MachMisc +-- import MachMisc import Stix import PprAbsC ( pprAmode ) @@ -17,17 +17,18 @@ import AbsCUtils ( getAmodeRep, mixedTypeLocn ) 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, +import Constants ( 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" @@ -70,18 +71,22 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs = 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 (Left SLIT("suspendThread")) {-no:cconv-} CCallConv - IntRep [StReg stgBaseReg]) + (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv + IntRep [StReg stgBaseReg, StInt is_threadSafe ]) resume = StVoidable - (StCall (Left 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)) @@ -89,21 +94,13 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs (cargs, stix_target) = case ctarget of StaticTarget nm -> (rhs, Left nm) - DynamicTarget | not (null rhs) -- an assertion + 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 amodeCodeForCCall cargs - 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) - other -> base + stix_args = map amodeToStix' cargs ccall = case lhs of [] -> StVoidable (StCall stix_target cconv VoidRep stix_args) @@ -116,6 +113,10 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs Int64Rep -> Int64Rep Word64Rep -> Word64Rep other -> IntRep + +-- a bit late to catch this here.. +foreignCallCode _ DNCall{} _ + = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C" \end{code} %************************************************************************ @@ -144,9 +145,6 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) -amodeToStix CBytesPerWord - = StInt (toInteger wORD_SIZE) - amodeToStix (CAddr (SpRel off)) = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off))) @@ -186,35 +184,45 @@ amodeToStix (CLit core) = 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) @@ -239,25 +247,21 @@ cHARLIKE_closure = StCLbl mkCharlikeClosureLabel 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, @@ -269,20 +273,15 @@ save_thread_state 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,