X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=034e6410259cfa6169a3086b1b73159420bcc586;hb=0b3dcf9dd504c2db156d08f1908e906e00e66c7a;hp=9f014888ab885b2d4c1da7c9c0e904c0157a0ab3;hpb=a5f7799965947977599a777dae10f103f9b9fd1a;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 9f01488..034e641 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -15,15 +15,17 @@ import StixInteger import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import SMRep ( fixedHdrSize ) -import Const ( Literal(..) ) +import Literal ( Literal(..), word2IntLit ) import CallConv ( cCallConv ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) -import UniqSupply ( returnUs, thenUs, UniqSM ) -import Constants ( mIN_INTLIKE ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE ) import Outputable -import Char ( ord ) +import Char ( ord, isAlphaNum ) + +#include "NCG.h" \end{code} The main honcho here is primCode, which handles the guts of COpStmts. @@ -52,19 +54,20 @@ and modify our heap check accordingly. \begin{code} -- NB: ordering of clauses somewhere driven by -- the desire to getting sane patt-matching behavior -primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da] - = gmpNegate (ar,sr,dr) (aa,sa,da) -\end{code} +primCode res@[sr,dr] IntegerNegOp arg@[sa,da] + = gmpNegate (sr,dr) (sa,da) -\begin{code} -primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2] - = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2) +primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2] + = gmpCompare res (sa1,da1, sa2,da2) + +primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] + = gmpCompareInt res (sa1,da1,ai) -primCode [res] Integer2IntOp arg@[aa,sa,da] - = gmpInteger2Int res (aa,sa,da) +primCode [res] Integer2IntOp arg@[sa,da] + = gmpInteger2Int res (sa,da) -primCode [res] Integer2WordOp arg@[aa,sa,da] - = gmpInteger2Word res (aa,sa,da) +primCode [res] Integer2WordOp arg@[sa,da] + = gmpInteger2Word res (sa,da) primCode [res] Int2AddrOp [arg] = simpleCoercion AddrRep res arg @@ -89,6 +92,12 @@ primCode [res] SameMutableArrayOp args primCode res@[_] SameMutableByteArrayOp args = primCode res SameMutableArrayOp args + +primCode res@[_] SameMutVarOp args + = primCode res SameMutableArrayOp args + +primCode res@[_] SameMVarOp args + = primCode res SameMutableArrayOp args \end{code} Freezing an array of pointers is a double assignment. We fix the @@ -109,8 +118,6 @@ primCode [lhs] UnsafeFreezeArrayOp [rhs] primCode [lhs] UnsafeFreezeByteArrayOp [rhs] = simpleCoercion PtrRep lhs rhs -primCode [lhs] UnsafeThawByteArrayOp [rhs] - = simpleCoercion PtrRep lhs rhs \end{code} Returning the size of (mutable) byte arrays is just @@ -140,7 +147,6 @@ primCode [lhs] SizeofMutableByteArrayOp [rhs] Most other array primitives translate to simple indexing. \begin{code} - primCode lhs@[_] IndexArrayOp args = primCode lhs ReadArrayOp args @@ -149,7 +155,7 @@ primCode [lhs] ReadArrayOp [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - base = StIndex IntRep obj' arrHS + base = StIndex IntRep obj' arrPtrsHS assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix')) in returnUs (\xs -> assign : xs) @@ -159,7 +165,7 @@ primCode [] WriteArrayOp [obj, ix, v] obj' = amodeToStix obj ix' = amodeToStix ix v' = amodeToStix v - base = StIndex IntRep obj' arrHS + base = StIndex IntRep obj' arrPtrsHS assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' in returnUs (\xs -> assign : xs) @@ -174,11 +180,14 @@ primCode [lhs] (ReadByteArrayOp pk) [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - base = StIndex IntRep obj' arrHS + base = StIndex IntRep obj' arrWordsHS assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) in returnUs (\xs -> assign : xs) +primCode lhs@[_] (ReadOffAddrOp pk) args + = primCode lhs (IndexOffAddrOp pk) args + primCode [lhs] (IndexOffAddrOp pk) [obj, ix] = let lhs' = amodeToStix lhs @@ -193,46 +202,118 @@ primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix] lhs' = amodeToStix lhs obj' = amodeToStix obj ix' = amodeToStix ix - obj'' = StIndex PtrRep obj' fixedHS + obj'' = StIndex AddrRep obj' fixedHS assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix')) in returnUs (\xs -> assign : xs) +primCode [] (WriteOffAddrOp pk) [obj, ix, v] + = let + obj' = amodeToStix obj + ix' = amodeToStix ix + v' = amodeToStix v + assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v' + in + returnUs (\xs -> assign : xs) + primCode [] (WriteByteArrayOp pk) [obj, ix, v] = let obj' = amodeToStix obj ix' = amodeToStix ix v' = amodeToStix v - base = StIndex IntRep obj' arrHS + base = StIndex IntRep obj' arrWordsHS assign = StAssign pk (StInd pk (StIndex pk base ix')) v' in returnUs (\xs -> assign : xs) + +primCode [] WriteForeignObjOp [obj, v] + = let + obj' = amodeToStix obj + v' = amodeToStix v + obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS + assign = StAssign AddrRep (StInd AddrRep obj'') v' + in + returnUs (\xs -> assign : xs) \end{code} +ToDo: saving/restoring of volatile regs around ccalls. + \begin{code} ---primCode lhs (CCallOp fn is_asm may_gc) rhs -primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs +primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs | is_asm = error "ERROR: Native code generator can't handle casm" - | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n" - | otherwise - = case lhs of - [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs) - [lhs] -> - let lhs' = amodeToStix lhs - pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep - call = StAssign pk lhs' (StCall fn cconv pk args) - in - returnUs (\xs -> call : xs) + | not may_gc = returnUs (\xs -> ccall : xs) + | otherwise = + save_thread_state `thenUs` \ save -> + load_thread_state `thenUs` \ load -> + getUniqueUs `thenUs` \ uniq -> + let + id = StReg (StixTemp uniq IntRep) + + suspend = StAssign IntRep id + (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg]) + resume = StCall SLIT("resumeThread") cconv VoidRep [id] + 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 arrHS - ByteArrayRep -> StIndex IntRep base arrHS + ArrayRep -> StIndex PtrRep base arrPtrsHS + ByteArrayRep -> StIndex IntRep base arrWordsHS ForeignObjRep -> StIndex PtrRep base fixedHS _ -> base + + ccall = case lhs of + [] -> StCall fn cconv VoidRep args + [lhs] -> + let lhs' = amodeToStix lhs + pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep + in + StAssign pk lhs' (StCall fn cconv pk args) +\end{code} + +DataToTagOp won't work for 64-bit archs, as it is. + +\begin{code} +primCode [lhs] DataToTagOp [arg] + = let lhs' = amodeToStix lhs + arg' = amodeToStix arg + infoptr = StInd PtrRep arg' + word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1))) + masked_le32 = StPrim SrlOp [word_32, StInt 16] + masked_be32 = StPrim AndOp [word_32, StInt 65535] +#ifdef WORDS_BIGENDIAN + masked = masked_be32 +#else + masked = masked_le32 +#endif + assign = StAssign IntRep lhs' masked + in + returnUs (\xs -> assign : xs) +\end{code} + +MutVars are pretty simple. +#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) + +\begin{code} +primCode [] WriteMutVarOp [aa,vv] + = let aa_s = amodeToStix aa + vv_s = amodeToStix vv + var_field = StIndex PtrRep aa_s fixedHS + assign = StAssign PtrRep (StInd PtrRep var_field) vv_s + in + returnUs (\xs -> assign : xs) + +primCode [rr] ReadMutVarOp [aa] + = let aa_s = amodeToStix aa + rr_s = amodeToStix rr + var_field = StIndex PtrRep aa_s fixedHS + assign = StAssign PtrRep rr_s (StInd PtrRep var_field) + in + returnUs (\xs -> assign : xs) \end{code} Now the more mundane operations. @@ -330,11 +411,11 @@ amodeToStix (CCharLike (CLit (MachChar c))) off = charLikeSize * ord c amodeToStix (CCharLike x) - = StIndex PtrRep charLike off + = StIndex CharRep charLike off where - off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))] + off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] -amodeToStix (CIntLike (CLit (MachInt i _))) +amodeToStix (CIntLike (CLit (MachInt i))) = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) @@ -347,27 +428,46 @@ amodeToStix (CLit core) MachChar c -> StInt (toInteger (ord c)) MachStr s -> StString s MachAddr a -> StInt a - MachInt i _ -> StInt (toInteger i) - MachLitLit s _ -> StLitLit s + MachInt i -> StInt i + MachWord w -> case word2IntLit core of MachInt iw -> StInt iw + MachLitLit s _ -> litLitToStix (_UNPK_ s) MachFloat d -> StDouble d MachDouble d -> StDouble d _ -> panic "amodeToStix:core literal" - -- A CLitLit is just a (CLit . MachLitLit) -amodeToStix (CLitLit s _) = StLitLit s +amodeToStix (CLitLit s _) + = litLitToStix (_UNPK_ s) amodeToStix (CMacroExpr _ macro [arg]) = case macro of ENTRY_CODE -> amodeToStix arg ARG_TAG -> amodeToStix arg -- just an integer no. of words - GET_TAG -> StPrim SrlOp - [StInd WordRep (StPrim IntSubOp [amodeToStix arg, - StInt 1]), + GET_TAG -> +#ifdef WORDS_BIGENDIAN + StPrim AndOp + [StInd WordRep (StIndex PtrRep (amodeToStix arg) + (StInt (toInteger (-1)))), + StInt 65535] +#else + StPrim SrlOp + [StInd WordRep (StIndex PtrRep (amodeToStix arg) + (StInt (toInteger (-1)))), StInt 16] - +#endif + UPD_FRAME_UPDATEE + -> StInd PtrRep (StIndex PtrRep (amodeToStix arg) + (StInt (toInteger uF_UPDATEE))) -- XXX!!! -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len, -- which we've had to hand-code here. + +litLitToStix :: String -> StixTree +litLitToStix nm + | all is_id nm = StLitLbl (text nm) + | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" + ++ "suggested workaround: use flag -fvia-C\n") + + where is_id c = isAlphaNum c || c == '_' \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -398,3 +498,62 @@ mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info") charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) \end{code} + + +\begin{code} +save_thread_state + = getUniqueUs `thenUs` \tso_uq -> + let tso = StReg (StixTemp tso_uq ThreadIdRep) in + returnUs (\xs -> + StAssign ThreadIdRep tso stgCurrentTSO : + StAssign PtrRep + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) + stgSp : + StAssign PtrRep + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) + stgSu : + StAssign PtrRep + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) + stgSpLim : + StAssign PtrRep + (StInd PtrRep (StPrim IntAddOp + [stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])) + (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) : + xs + ) + +load_thread_state + = getUniqueUs `thenUs` \tso_uq -> + let tso = StReg (StixTemp tso_uq ThreadIdRep) in + returnUs (\xs -> + StAssign ThreadIdRep tso stgCurrentTSO : + StAssign PtrRep stgSp + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) : + StAssign PtrRep stgSu + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) : + StAssign PtrRep stgSpLim + (StInd PtrRep (StPrim IntAddOp + [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) : + StAssign PtrRep stgHp + (StPrim IntSubOp [ + StInd PtrRep (StPrim IntAddOp + [stgCurrentNursery, + StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]), + StInt (toInteger (1 * BYTES_PER_WORD)) + ]) : + StAssign PtrRep stgHpLim + (StPrim IntAddOp [ + StInd PtrRep (StPrim IntAddOp + [stgCurrentNursery, + StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]), + StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD))) + ]) : + xs + ) +\end{code}