import AbsCSyn hiding ( spRel )
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
+import Constants ( uF_UPDATEE )
import SMRep ( fixedHdrSize )
import Const ( Literal(..) )
import CallConv ( cCallConv )
\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
Most other array primitives translate to simple indexing.
\begin{code}
-
primCode lhs@[_] IndexArrayOp args
= primCode lhs ReadArrayOp args
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)
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)
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}
+DataToTagOp won't work for 64-bit archs, as it is.
+
+\begin{code}
+primCode [lhs] DataToTagOp [arg]
+ = let lhs' = amodeToStix lhs
+ arg' = amodeToStix arg
+ infoptr = StInd PtrRep arg'
+ word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
+ masked_le32 = StPrim SrlOp [word_32, StInt 16]
+ masked_be32 = StPrim AndOp [word_32, StInt 65535]
+#ifdef WORDS_BIGENDIAN
+ masked = masked_be32
+#else
+ masked = masked_le32
+#endif
+ assign = StAssign IntRep lhs' masked
+ in
+ returnUs (\xs -> assign : xs)
+\end{code}
+
Now the more mundane operations.
\begin{code}
amodeToStix (CAddr (NodeRel off))
= StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
+amodeToStix (CAddr (CIndex base off pk))
+ = StIndex pk (amodeToStix base) (amodeToStix off)
+
amodeToStix (CReg magic) = StReg (StixMagicId magic)
amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
amodeToStix (CLbl lbl _) = StCLbl lbl
-amodeToStix (CTableEntry base off pk)
- = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
-
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
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 _)))
= StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
amodeToStix (CIntLike x)
= panic "CIntLike"
- -- A CString is just a (CLit . MachStr)
-amodeToStix (CString s) = StString s
-
amodeToStix (CLit core)
= case core of
MachChar c -> StInt (toInteger (ord c))
MachStr s -> StString s
MachAddr a -> StInt a
MachInt i _ -> StInt (toInteger i)
- MachLitLit s _ -> StLitLit s
+ MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (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
projects / ghc-hetmet.git / blobdiff