X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=08a63568f9714194aa2d0a1def7ff53a2f381177;hb=6f2ed8b680338aeb351522f61f09b29233ae36b4;hp=0b4feb693dd642f9934b94a7fe0cecd901f7a65a;hpb=b5067df9a354f1da9e67d5c86c86ef871fdbd50f;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 0b4feb6..08a6356 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -16,9 +16,9 @@ import AbsCSyn hiding ( spRel ) import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import Constants ( uF_UPDATEE ) 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 ) @@ -53,19 +53,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] 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 @@ -90,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 @@ -110,8 +117,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 +154,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 +164,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 +179,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,25 +201,43 @@ 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} \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 @@ -229,8 +255,8 @@ primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs 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 \end{code} @@ -255,6 +281,27 @@ 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} + Now the more mundane operations. \begin{code} @@ -350,11 +397,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)) @@ -367,29 +414,47 @@ 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 + = 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") \end{code} Sizes of the CharLike and IntLike closures that are arranged as arrays