X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=8df78124b2c5c0ab947ec0addf95f3404a0295e9;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=e186c398c1de38b584666be1c5b32307d131e3c9;hpb=995c2dc3387f079a3ea4785c4e1b4be21604d749;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index e186c39..8df7812 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -17,18 +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, +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE, rESERVED_STACK_WORDS ) import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, - mkMAP_FROZEN_infoLabel, mkForeignLabel ) import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), CCallConv(..), playSafe, playThreadSafe ) import Outputable +import Util ( notNull ) +import FastString import FastTypes +import Char #include "NCG.h" \end{code} @@ -49,14 +50,11 @@ foreignCallCode %* * %************************************************************************ -First, the dreaded @ccall@. We can't handle @casm@s. +First, the dreaded @ccall@. Usually, this compiles to an assignment, but when the left-hand side is empty, we just perform the call and ignore the result. -btw Why not let programmer use casm to provide assembly code instead -of C code? ADR - ToDo: saving/restoring of volatile regs around ccalls. JRS, 001113: always do the call of suspendThread and resumeThread as a ccall @@ -81,10 +79,10 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs | otherwise = 0 suspend = StAssignReg IntRep id - (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv + (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv IntRep [StReg stgBaseReg, StInt is_threadSafe ]) resume = StVoidable - (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv + (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv VoidRep [StReg id, StInt is_threadSafe ]) in returnUs (\xs -> save (suspend : ccall : resume : load xs)) @@ -93,21 +91,10 @@ 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) @@ -120,6 +107,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} %************************************************************************ @@ -148,9 +139,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))) @@ -173,7 +161,7 @@ amodeToStix (CLbl lbl _) = StCLbl lbl amodeToStix (CCharLike (CLit (MachChar c))) = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * (c - mIN_CHARLIKE) + off = charLikeSize * (ord c - mIN_CHARLIKE) amodeToStix (CCharLike x) = panic "amodeToStix.CCharLike" @@ -188,42 +176,44 @@ amodeToStix (CIntLike x) amodeToStix (CLit core) = case core of - MachChar c -> StInt (toInteger c) + MachChar c -> StInt (toInteger (ord 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) - (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) - -litLitErr - = ncgPrimopMoan "native code generator can't handle lit-lits" empty \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -240,28 +230,22 @@ iNTLIKE_closure = StCLbl mkIntlikeClosureLabel cHARLIKE_closure :: StixExpr 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, @@ -273,20 +257,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,