X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=7583e1cd271cbda5e9bd3f8913275d688358701e;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=c70a2373e687e3ced3641a94a013536e196bb2ea;hpb=e1ac738d00eb2a5db0d20c49315f3247f970b61f;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index c70a237..7583e1c 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,19 @@ 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, 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" @@ -64,41 +66,46 @@ rather than inheriting the calling convention of the thing which we're really 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 @@ -108,8 +115,9 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs 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} %************************************************************************ @@ -138,11 +146,6 @@ amodeToStix am@(CVal rr CharRep) 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))) @@ -182,35 +185,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) @@ -235,25 +248,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, @@ -265,20 +274,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,