X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=d8c9e9783fdedc01711daa9618c8be214f6df1f1;hb=39068cf49bf3553f90ec316569619c310a6be8de;hp=11b6cd684736384d95b02fce862f3821869576e7;hpb=5adf2314bfe7329e57cc956f02d0e566ae9569c9;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 11b6cd6..d8c9e97 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -8,23 +8,26 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where #include "HsVersions.h" import MachMisc -import MachRegs import Stix import StixInteger import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) -import Constants ( uF_UPDATEE ) import SMRep ( fixedHdrSize ) -import Const ( Literal(..) ) +import Literal ( Literal(..), word2IntLit ) +import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) +import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, + rESERVED_STACK_WORDS ) +import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, + mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel, + mkForeignLabel ) import CallConv ( cCallConv ) -import PrimOp ( PrimOp(..) ) -import PrimRep ( PrimRep(..), isFloatingRep ) -import UniqSupply ( returnUs, thenUs, UniqSM ) -import Constants ( mIN_INTLIKE ) import Outputable +import FastTypes -import Char ( ord ) +#include "NCG.h" \end{code} The main honcho here is primCode, which handles the guts of COpStmts. @@ -53,19 +56,18 @@ 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} -\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] Integer2IntOp arg@[aa,sa,da] - = gmpInteger2Int res (aa,sa,da) +primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] + = gmpCompareInt res (sa1,da1,ai) -primCode [res] Integer2WordOp arg@[aa,sa,da] - = gmpInteger2Word res (aa,sa,da) +primCode [res] Integer2IntOp arg@[sa,da] + = gmpInteger2Int res (sa,da) + +primCode [res] Integer2WordOp arg@[sa,da] + = gmpInteger2Word res (sa,da) primCode [res] Int2AddrOp [arg] = simpleCoercion AddrRep res arg @@ -78,6 +80,23 @@ primCode [res] Int2WordOp [arg] primCode [res] Word2IntOp [arg] = simpleCoercion IntRep res arg + +primCode [res] AddrToHValueOp [arg] + = simpleCoercion PtrRep res arg + +primCode [res] IntToInt8Op [arg] + = narrowingCoercion IntRep Int8Rep res arg +primCode [res] IntToInt16Op [arg] + = narrowingCoercion IntRep Int16Rep res arg +primCode [res] IntToInt32Op [arg] + = narrowingCoercion IntRep Int32Rep res arg + +primCode [res] WordToWord8Op [arg] + = narrowingCoercion WordRep Word8Rep res arg +primCode [res] WordToWord16Op [arg] + = narrowingCoercion WordRep Word16Rep res arg +primCode [res] WordToWord32Op [arg] + = narrowingCoercion WordRep Word32Rep res arg \end{code} \begin{code} @@ -90,6 +109,32 @@ primCode [res] SameMutableArrayOp args primCode res@[_] SameMutableByteArrayOp args = primCode res SameMutableArrayOp args + +primCode res@[_] SameMutVarOp args + = primCode res SameMutableArrayOp args +\end{code} + +\begin{code} +primCode res@[_] SameMVarOp args + = primCode res SameMutableArrayOp args + +-- #define isEmptyMVarzh(r,a) \ +-- r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info ) +primCode [res] IsEmptyMVarOp [arg] + = let res' = amodeToStix res + arg' = amodeToStix arg + arg_info = StInd PtrRep arg' + em_info = StCLbl mkEMPTY_MVAR_infoLabel + same = StPrim IntEqOp [arg_info, em_info] + assign = StAssign IntRep res' same + in + returnUs (\xs -> assign : xs) + +-- #define myThreadIdzh(t) (t = CurrentTSO) +primCode [res] MyThreadIdOp [] + = let res' = amodeToStix res + in returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs) + \end{code} Freezing an array of pointers is a double assignment. We fix the @@ -110,8 +155,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 @@ -149,7 +192,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,80 +202,188 @@ 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) -primCode lhs@[_] (IndexByteArrayOp pk) args - = primCode lhs (ReadByteArrayOp pk) args - --- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) - -primCode [lhs] (ReadByteArrayOp pk) [obj, ix] - = let - lhs' = amodeToStix lhs - obj' = amodeToStix obj - ix' = amodeToStix ix - base = StIndex IntRep obj' arrHS - assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) - in - returnUs (\xs -> assign : xs) - -primCode [lhs] (IndexOffAddrOp pk) [obj, ix] +primCode [] WriteForeignObjOp [obj, v] = let - lhs' = amodeToStix lhs obj' = amodeToStix obj - ix' = amodeToStix ix - assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix')) + v' = amodeToStix v + obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS + assign = StAssign AddrRep (StInd AddrRep obj'') v' in returnUs (\xs -> assign : xs) -primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix] - = let - lhs' = amodeToStix lhs - obj' = amodeToStix obj - ix' = amodeToStix ix - obj'' = StIndex PtrRep obj' fixedHS - assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix')) - in - returnUs (\xs -> assign : xs) +-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) +primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls IndexByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs +primCode ls IndexByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs +primCode ls IndexByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs +primCode ls IndexByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs +primCode ls IndexByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs +primCode ls IndexByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs +primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs +primCode ls IndexByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs +primCode ls IndexByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs +primCode ls IndexByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs +primCode ls IndexByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls IndexByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls IndexByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs +primCode ls IndexByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs +primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls ReadByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs +primCode ls ReadByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs +primCode ls ReadByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs +primCode ls ReadByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs +primCode ls ReadByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs +primCode ls ReadByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs +primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs +primCode ls ReadByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs +primCode ls ReadByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs +primCode ls ReadByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs +primCode ls ReadByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls ReadByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs +primCode ls ReadByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs +primCode ls ReadByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs +primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Word8Rep ls rs +primCode ls WriteByteArrayOp_WideChar rs = primCode_WriteByteArrayOp CharRep ls rs +primCode ls WriteByteArrayOp_Int rs = primCode_WriteByteArrayOp IntRep ls rs +primCode ls WriteByteArrayOp_Word rs = primCode_WriteByteArrayOp WordRep ls rs +primCode ls WriteByteArrayOp_Addr rs = primCode_WriteByteArrayOp AddrRep ls rs +primCode ls WriteByteArrayOp_Float rs = primCode_WriteByteArrayOp FloatRep ls rs +primCode ls WriteByteArrayOp_Double rs = primCode_WriteByteArrayOp DoubleRep ls rs +primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs +primCode ls WriteByteArrayOp_Int8 rs = primCode_WriteByteArrayOp Int8Rep ls rs +primCode ls WriteByteArrayOp_Int16 rs = primCode_WriteByteArrayOp Int16Rep ls rs +primCode ls WriteByteArrayOp_Int32 rs = primCode_WriteByteArrayOp Int32Rep ls rs +primCode ls WriteByteArrayOp_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs +primCode ls WriteByteArrayOp_Word8 rs = primCode_WriteByteArrayOp Word8Rep ls rs +primCode ls WriteByteArrayOp_Word16 rs = primCode_WriteByteArrayOp Word16Rep ls rs +primCode ls WriteByteArrayOp_Word32 rs = primCode_WriteByteArrayOp Word32Rep ls rs +primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs + +primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls IndexOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs +primCode ls IndexOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs +primCode ls IndexOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs +primCode ls IndexOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs +primCode ls IndexOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs +primCode ls IndexOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs +primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs +primCode ls IndexOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs +primCode ls IndexOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs +primCode ls IndexOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs +primCode ls IndexOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls IndexOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls IndexOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs +primCode ls IndexOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs +primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Word8Rep ls rs +primCode ls IndexOffForeignObjOp_WideChar rs = primCode_IndexOffForeignObjOp CharRep ls rs +primCode ls IndexOffForeignObjOp_Int rs = primCode_IndexOffForeignObjOp IntRep ls rs +primCode ls IndexOffForeignObjOp_Word rs = primCode_IndexOffForeignObjOp WordRep ls rs +primCode ls IndexOffForeignObjOp_Addr rs = primCode_IndexOffForeignObjOp AddrRep ls rs +primCode ls IndexOffForeignObjOp_Float rs = primCode_IndexOffForeignObjOp FloatRep ls rs +primCode ls IndexOffForeignObjOp_Double rs = primCode_IndexOffForeignObjOp DoubleRep ls rs +primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs +primCode ls IndexOffForeignObjOp_Int8 rs = primCode_IndexOffForeignObjOp Int8Rep ls rs +primCode ls IndexOffForeignObjOp_Int16 rs = primCode_IndexOffForeignObjOp Int16Rep ls rs +primCode ls IndexOffForeignObjOp_Int32 rs = primCode_IndexOffForeignObjOp Int32Rep ls rs +primCode ls IndexOffForeignObjOp_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs +primCode ls IndexOffForeignObjOp_Word8 rs = primCode_IndexOffForeignObjOp Word8Rep ls rs +primCode ls IndexOffForeignObjOp_Word16 rs = primCode_IndexOffForeignObjOp Word16Rep ls rs +primCode ls IndexOffForeignObjOp_Word32 rs = primCode_IndexOffForeignObjOp Word32Rep ls rs +primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs + +primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls ReadOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs +primCode ls ReadOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs +primCode ls ReadOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs +primCode ls ReadOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs +primCode ls ReadOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs +primCode ls ReadOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs +primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs +primCode ls ReadOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs +primCode ls ReadOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs +primCode ls ReadOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs +primCode ls ReadOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls ReadOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs +primCode ls ReadOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs +primCode ls ReadOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs +primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Word8Rep ls rs +primCode ls WriteOffAddrOp_WideChar rs = primCode_WriteOffAddrOp CharRep ls rs +primCode ls WriteOffAddrOp_Int rs = primCode_WriteOffAddrOp IntRep ls rs +primCode ls WriteOffAddrOp_Word rs = primCode_WriteOffAddrOp WordRep ls rs +primCode ls WriteOffAddrOp_Addr rs = primCode_WriteOffAddrOp AddrRep ls rs +primCode ls WriteOffAddrOp_Float rs = primCode_WriteOffAddrOp FloatRep ls rs +primCode ls WriteOffAddrOp_Double rs = primCode_WriteOffAddrOp DoubleRep ls rs +primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs +primCode ls WriteOffAddrOp_Int8 rs = primCode_WriteOffAddrOp Int8Rep ls rs +primCode ls WriteOffAddrOp_Int16 rs = primCode_WriteOffAddrOp Int16Rep ls rs +primCode ls WriteOffAddrOp_Int32 rs = primCode_WriteOffAddrOp Int32Rep ls rs +primCode ls WriteOffAddrOp_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs +primCode ls WriteOffAddrOp_Word8 rs = primCode_WriteOffAddrOp Word8Rep ls rs +primCode ls WriteOffAddrOp_Word16 rs = primCode_WriteOffAddrOp Word16Rep ls rs +primCode ls WriteOffAddrOp_Word32 rs = primCode_WriteOffAddrOp Word32Rep ls rs +primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs -primCode [] (WriteByteArrayOp pk) [obj, ix, v] - = let - obj' = amodeToStix obj - ix' = amodeToStix ix - v' = amodeToStix v - base = StIndex IntRep obj' arrHS - assign = StAssign pk (StInd pk (StIndex pk base ix')) v' - in - returnUs (\xs -> assign : xs) \end{code} +ToDo: saving/restoring of volatile regs around ccalls. + +JRS, 001113: always do the call of suspendThread and resumeThread as a ccall +rather than inheriting the calling convention of the thing which we're really +calling. + \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") {-no:cconv-} cCallConv + IntRep [stgBaseReg]) + resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv + 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 - ForeignObjRep -> StIndex PtrRep base fixedHS + ArrayRep -> StIndex PtrRep base arrPtrsHS + ByteArrayRep -> StIndex IntRep base arrWordsHS + ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS) _ -> base + + ccall = case lhs of + [] -> StCall fn cconv VoidRep args + [lhs] -> + let lhs' = amodeToStix lhs + pk = case getAmodeRep lhs of + FloatRep -> FloatRep + DoubleRep -> DoubleRep + other -> IntRep + in + StAssign pk lhs' (StCall fn cconv pk args) \end{code} DataToTagOp won't work for 64-bit archs, as it is. @@ -255,6 +406,40 @@ primCode [lhs] DataToTagOp [arg] 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} + +ForeignObj# primops. + +\begin{code} +primCode [rr] ForeignObjToAddrOp [fo] + = let code = StAssign AddrRep (amodeToStix rr) + (StInd AddrRep + (StIndex PtrRep (amodeToStix fo) fixedHS)) + in + returnUs (\xs -> code : xs) + +primCode [] TouchOp [_] = returnUs id +\end{code} + Now the more mundane operations. \begin{code} @@ -267,6 +452,63 @@ primCode lhs op rhs returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs) \end{code} +Helper fns for some array ops. + +\begin{code} +primCode_ReadByteArrayOp pk [lhs] [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + base = StIndex IntRep obj' arrWordsHS + assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) + in + returnUs (\xs -> assign : xs) + + +primCode_IndexOffAddrOp pk [lhs] [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix')) + in + returnUs (\xs -> assign : xs) + + +primCode_IndexOffForeignObjOp pk [lhs] [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + 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' arrWordsHS + assign = StAssign pk (StInd pk (StIndex pk base ix')) v' + in + returnUs (\xs -> assign : xs) + +\end{code} + \begin{code} simpleCoercion :: PrimRep @@ -276,6 +518,40 @@ simpleCoercion simpleCoercion pk lhs rhs = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs) + + +-- Rewrite a narrowing coercion into a pair of shifts. +narrowingCoercion + :: PrimRep -> PrimRep + -> CAddrMode -> CAddrMode + -> UniqSM StixTreeList + +narrowingCoercion pks pkd dst src + | szd > szs + = panic "StixPrim.narrowingCoercion" + | szd == szs + = returnUs (\xs -> StAssign pkd dst' src' : xs) + | otherwise + = returnUs (\xs -> assign : xs) + where + szs = getPrimRepSizeInBytes pks + szd = getPrimRepSizeInBytes pkd + src' = amodeToStix src + dst' = amodeToStix dst + shift_amt = fromIntegral (8 * (szs - szd)) + + assign + = StAssign pkd dst' + (StPrim (if signed then ISraOp else SrlOp) + [StPrim SllOp [src', StInt shift_amt], + StInt shift_amt]) + signed + = case pkd of + Int8Rep -> True; Int16Rep -> True + Int32Rep -> True; Int64Rep -> True; IntRep -> True + Word8Rep -> False; Word16Rep -> False + Word32Rep -> False; Word64Rep -> False; WordRep -> False + other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd) \end{code} Here we try to rewrite primitives into a form the code generator can @@ -326,13 +602,13 @@ amodeToStix am@(CVal rr CharRep) amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) amodeToStix (CAddr (SpRel off)) - = StIndex PtrRep stgSp (StInt (toInteger IBOX(off))) + = StIndex PtrRep stgSp (StInt (toInteger (iBox off))) amodeToStix (CAddr (HpRel off)) - = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off)))) + = StIndex IntRep stgHp (StInt (toInteger (- (iBox off)))) amodeToStix (CAddr (NodeRel off)) - = StIndex IntRep stgNode (StInt (toInteger IBOX(off))) + = StIndex IntRep stgNode (StInt (toInteger (iBox off))) amodeToStix (CAddr (CIndex base off pk)) = StIndex pk (amodeToStix base) (amodeToStix off) @@ -345,17 +621,15 @@ amodeToStix (CLbl lbl _) = StCLbl lbl -- For CharLike and IntLike, we attempt some trivial constant-folding here. amodeToStix (CCharLike (CLit (MachChar c))) - = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off)) + = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * ord c + off = charLikeSize * (c - mIN_CHARLIKE) amodeToStix (CCharLike x) - = StIndex PtrRep charLike off - where - off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))] + = panic "CCharLike" -amodeToStix (CIntLike (CLit (MachInt i _))) - = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off)) +amodeToStix (CIntLike (CLit (MachInt i))) + = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) @@ -364,41 +638,39 @@ amodeToStix (CIntLike x) amodeToStix (CLit core) = case core of - MachChar c -> StInt (toInteger (ord c)) + MachChar c -> StInt (toInteger c) MachStr s -> StString s MachAddr a -> StInt a - MachInt i _ -> StInt (toInteger i) - MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s)) - MachFloat d -> StDouble d + 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-}) + MachFloat d -> StFloat d MachDouble d -> StDouble d _ -> panic "amodeToStix:core literal" -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 - = case nm of - "stdout" -> stixFor_stdout - "stderr" -> stixFor_stderr - "stdin" -> stixFor_stdin - other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" - ++ "suggested workaround: use flag -fvia-C\n") + +litLitErr = + panic "native code generator can't compile lit-lits, use -fvia-C" \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays @@ -407,25 +679,73 @@ in the data segment. (These are in bytes.) \begin{code} -- The INTLIKE base pointer -intLikePtr :: StixTree - -intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure")) +iNTLIKE_closure :: StixTree +iNTLIKE_closure = StCLbl mkIntlikeClosureLabel -- The CHARLIKE base -charLike :: StixTree +cHARLIKE_closure :: StixTree +cHARLIKE_closure = StCLbl mkCharlikeClosureLabel -charLike = sStLitLbl SLIT("CHARLIKE_closure") +mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel --- Trees for the ErrorIOPrimOp - -topClosure, errorIO :: StixTree - -topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure")) -errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards"))) +-- these are the sizes of charLike and intLike closures, in _bytes_. +charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) +intLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) +\end{code} -mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info") -charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) -intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep)) +\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 + [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 + (StPrim IntAddOp [tso, + StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) + *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}