X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=81778922dd67424f9d8de5c43cb7692edf86a030;hb=a76db2a07f99716c40e05d73210f80b4e4794b9a;hp=7576dd80757b833568dbde243667f8d251260dc8;hpb=6254fd4ab7c5798599e58b48896c9e284222f26f;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 7576dd8..8177892 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -18,12 +18,12 @@ import Literal ( Literal(..), word2IntLit ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import PrimRep ( PrimRep(..), isFloatingRep ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) -import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE ) +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, isAlpha, isDigit ) +import FastTypes #include "NCG.h" \end{code} @@ -170,62 +170,6 @@ 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] - = 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')) - in - returnUs (\xs -> assign : xs) - -primCode [lhs] (IndexOffForeignObjOp pk) [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) - primCode [] WriteForeignObjOp [obj, v] = let obj' = amodeToStix obj @@ -234,6 +178,78 @@ primCode [] WriteForeignObjOp [obj, v] assign = StAssign AddrRep (StInd AddrRep obj'') v' 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 + \end{code} ToDo: saving/restoring of volatile regs around ccalls. @@ -263,7 +279,7 @@ 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 @@ -319,6 +335,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} @@ -331,6 +360,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 @@ -390,13 +476,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) @@ -409,17 +495,15 @@ amodeToStix (CLbl lbl _) = StCLbl lbl -- For CharLike and IntLike, we attempt some trivial constant-folding here. amodeToStix (CCharLike (CLit (MachChar c))) - = StIndex CharRep cHARLIKE_closure (StInt (toInteger off)) + = StIndex Int8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * ord c + off = charLikeSize * (c - mIN_CHARLIKE) amodeToStix (CCharLike x) - = StIndex CharRep cHARLIKE_closure off - where - off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] + = panic "CCharLike" amodeToStix (CIntLike (CLit (MachInt i))) - = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off)) + = StIndex Int8Rep iNTLIKE_closure (StInt (toInteger off)) where off = intLikeSize * (fromInteger (i - mIN_INTLIKE)) @@ -428,7 +512,7 @@ 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 @@ -499,10 +583,6 @@ save_thread_state (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, @@ -523,8 +603,9 @@ load_thread_state (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))])) : + (StPrim IntAddOp [tso, + StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS) + *BYTES_PER_WORD))]) : StAssign PtrRep stgHp (StPrim IntSubOp [ StInd PtrRep (StPrim IntAddOp