X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=1f5fde1da62b8317553e1497d02ba7997c12e035;hb=a1cd15d30fb22dc5a315342ccaeb5b3eef1aa32f;hp=f32bb99037990cd3de85a5c5a60673041589511a;hpb=27c9fa7828e2005dee577dfd3aa0e6aa16409ea7;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index f32bb99..1f5fde1 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -8,23 +8,23 @@ 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 Literal ( Literal(..), word2IntLit ) -import CallConv ( cCallConv ) 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, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, + rESERVED_STACK_WORDS ) +import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, + mkMAP_FROZEN_infoLabel, mkForeignLabel ) import Outputable -import Char ( ord ) +#include "NCG.h" \end{code} The main honcho here is primCode, which handles the guts of COpStmts. @@ -91,6 +91,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 @@ -163,68 +169,107 @@ primCode [] WriteArrayOp [obj, 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] +primCode [] WriteForeignObjOp [obj, v] = 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 lhs@[_] (ReadOffAddrOp pk) args - = primCode lhs (IndexOffAddrOp pk) args - -primCode [lhs] (IndexOffAddrOp pk) [obj, ix] - = 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 Int8Rep 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_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Int8Rep 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_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs +primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs + +primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Int8Rep 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_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Int8Rep 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_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs +primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs + +primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Int8Rep 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_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs +primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs + +primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Int8Rep 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_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs +primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs + +primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Int8Rep 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_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs +primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs -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} +ToDo: saving/restoring of volatile regs around ccalls. + \begin{code} ---primCode lhs (CCallOp fn is_asm may_gc) 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 = @@ -233,8 +278,19 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs case getAmodeRep x of ArrayRep -> StIndex PtrRep base arrPtrsHS ByteArrayRep -> StIndex IntRep base arrWordsHS - ForeignObjRep -> StIndex PtrRep base fixedHS + 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. @@ -278,6 +334,19 @@ primCode [rr] ReadMutVarOp [aa] 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} @@ -290,6 +359,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 @@ -368,17 +494,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 Int8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * ord c + off = charLikeSize * (c - mIN_CHARLIKE) amodeToStix (CCharLike x) - = StIndex CharRep charLike off - where - off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] + = panic "CCharLike" amodeToStix (CIntLike (CLit (MachInt i))) - = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off)) + = StIndex Int8Rep iNTLIKE_closure (StInt (toInteger off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) @@ -387,19 +511,17 @@ 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 i MachWord w -> case word2IntLit core of MachInt iw -> StInt iw - MachLitLit s _ -> litLitToStix (_UNPK_ s) - MachFloat d -> StDouble d + 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 @@ -419,18 +541,9 @@ amodeToStix (CMacroExpr _ macro [arg]) 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 @@ -439,25 +552,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 = sStLitLbl SLIT("CHARLIKE_closure") +cHARLIKE_closure :: StixTree +cHARLIKE_closure = StCLbl mkCharlikeClosureLabel --- Trees for the ErrorIOPrimOp - -topClosure, errorIO :: StixTree - -topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure")) -errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards"))) - -mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info") +mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel +-- these are the sizes of charLike and intLike closures, in _bytes_. 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 + [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}