-ToDo ADR: modify this to handle ForeignObjs.
-
-btw Why not let programmer use casm to provide assembly code instead
-of C code? ADR
-
-The (MP) integer operations are a true nightmare. Since we don't have
-a convenient abstract way of allocating temporary variables on the (C)
-stack, we use the space just below HpLim for the @MP_INT@ structures,
-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@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerQuotRemOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerDivModOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
- = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
-\end{code}
-
-Since we are using the heap for intermediate @MP_INT@ structs, integer
-comparison {\em does} require a heap check in the native code
-implementation.
-
-\begin{code}
-primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
- = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
-
-primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
- = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
-
-primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer (ar,sr,dr) (hp, n)
-
-primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer (ar,sr,dr) (liveness,str)
-
-primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
- = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
- = gmpInteger2Int res (hp, aa,sa,da)
-
-primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
- = gmpInteger2Word res (hp, aa,sa,da)
-
-primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
- = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
-
-primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
- = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
-
-primCode [res] Int2AddrOp [arg]
- = simpleCoercion AddrRep res arg
-
-primCode [res] Addr2IntOp [arg]
- = simpleCoercion IntRep res arg
-
-primCode [res] Int2WordOp [arg]
- = simpleCoercion IntRep{-WordRep?-} res arg
-
-primCode [res] Word2IntOp [arg]
- = simpleCoercion IntRep res arg
-\end{code}
-
-The @ErrorIO@ primitive is actually a bit weird...assign a new value
-to the root closure, and jump to the @ErrorIO_innards@.
-
-\begin{code}
-primCode [] ErrorIOPrimOp [rhs]
- = let
- changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
- in
- returnUs (\xs -> changeTop : errorIO : xs)
-\end{code}
-
-@newArray#@ ops allocate heap space.
-
-\begin{code}
-primCode [res] NewArrayOp args
- = let
- [liveness, n, initial] = map amodeToStix args
- result = amodeToStix res
- space = StPrim IntAddOp [n, mutHS]
- loc = StIndex PtrRep stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrRep result loc
- initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : initialise : xs))
-
-primCode [res] (NewByteArrayOp pk) args
- = let
- [liveness, count] = map amodeToStix args
- result = amodeToStix res
- n = StPrim IntMulOp [count, StInt (sizeOf pk)]
- slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
- words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
- loc = StIndex PtrRep stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrRep result loc
- init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
- init2 = StAssign IntRep
- (StInd IntRep
- (StIndex IntRep loc
- (StInt (toInteger fixedHdrSizeInWords))))
- (StPrim IntAddOp [words,
- StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
-
-primCode [res] SameMutableArrayOp args
- = let
- compare = StPrim AddrEqOp (map amodeToStix args)
- assign = StAssign IntRep (amodeToStix res) compare
- in
- returnUs (\xs -> assign : xs)
-
-primCode res@[_] SameMutableByteArrayOp args
- = primCode res SameMutableArrayOp args
-\end{code}
-
-Freezing an array of pointers is a double assignment. We fix the
-header of the ``new'' closure because the lhs is probably a better
-addressing mode for the indirection (most likely, it's a VanillaReg).
-
-\begin{code}
-
-primCode [lhs] UnsafeFreezeArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- header = StInd PtrRep lhs'
- assign = StAssign PtrRep lhs' rhs'
- freeze = StAssign PtrRep header imMutArrayOfPtrs_info
- in
- returnUs (\xs -> assign : freeze : xs)
-
-primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
- = simpleCoercion PtrRep lhs rhs
-\end{code}
-
-Returning the size of (mutable) byte arrays is just
-an indexing operation.
-
-\begin{code}
-primCode [lhs] SizeofByteArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- sz = StIndex IntRep rhs' fixedHS
- assign = StAssign IntRep lhs' (StInd IntRep sz)
- in
- returnUs (\xs -> assign : xs)
-
-primCode [lhs] SizeofMutableByteArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- sz = StIndex IntRep rhs' fixedHS
- assign = StAssign IntRep lhs' (StInd IntRep sz)
- in
- returnUs (\xs -> assign : xs)
-
-\end{code}
-
-Most other array primitives translate to simple indexing.
-
-\begin{code}
-
-primCode lhs@[_] IndexArrayOp args
- = primCode lhs ReadArrayOp args
-
-primCode [lhs] ReadArrayOp [obj, ix]
- = let
- lhs' = amodeToStix lhs
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- base = StIndex IntRep obj' mutHS
- assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
- in
- returnUs (\xs -> assign : xs)
-
-primCode [] WriteArrayOp [obj, ix, v]
- = let
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- v' = amodeToStix v
- base = StIndex IntRep obj' mutHS
- assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base 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)