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 )
\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
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
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
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)
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)
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
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
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}
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}
off = charLikeSize * ord c
amodeToStix (CCharLike x)
- = StIndex PtrRep charLike off
+ = StIndex CharRep charLike off
where
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))
MachChar c -> StInt (toInteger (ord c))
MachStr s -> StString s
MachAddr a -> StInt a
- MachInt i _ -> StInt (toInteger i)
- MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ 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"
= 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)))
projects / ghc-hetmet.git / blobdiff