-\begin{code}
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-
-genPrimCode target_STRICT res op args
- = genprim res op args
- where
- a2stix = amodeToStix target
- a2stix' = amodeToStix' target
- mut_hs = mutHS target
- data_hs = dataHS target
- heap_chkr = heapCheck target
- size_of = sizeof target
- fixed_hs = fixedHeaderSize target
- var_hs = varHeaderSize target
-
- --- real code will follow... -------------
-\end{code}
-
-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
-
- genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerQuotRemOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerDivModOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
- genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
- genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] =
- gmpTake1Return1 target (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}
- genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
- decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg)
-
- genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
- decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg)
-
- genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer target (ar,sr,dr) (hp, n)
-
- genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer target (ar,sr,dr) (liveness,str)
-
- genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
- = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
- = gmpInteger2Int target res (hp, aa,sa,da)
-
- genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon)
-
- genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon)
-
- genprim [res] Int2AddrOp [arg] =
- simpleCoercion AddrKind res arg
-
- genprim [res] Addr2IntOp [arg] =
- simpleCoercion IntKind res arg
-
- genprim [res] Int2WordOp [arg] =
- simpleCoercion IntKind{-WordKind?-} res arg
-
- genprim [res] Word2IntOp [arg] =
- simpleCoercion IntKind res arg
-
-\end{code}
-
-The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root
-closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
-
-\begin{code}
-
- genprim [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrKind topClosure (a2stix rhs)
- in
- returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
-
-\end{code}
-
-@newArray#@ ops allocate heap space.
-
-\begin{code}
- genprim [res] NewArrayOp args =
- let [liveness, n, initial] = map a2stix args
- result = a2stix res
- space = StPrim IntAddOp [n, mut_hs]
- loc = StIndex PtrKind stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrKind result loc
- initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial]
- in
- heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
-
- returnSUs (heap_chk . (\xs -> assign : initialise : xs))
-
- genprim [res] (NewByteArrayOp pk) args =
- let [liveness, count] = map a2stix args
- result = a2stix res
- n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
- slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))]
- words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
- loc = StIndex PtrKind stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrKind result loc
- init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info
- init2 = StAssign IntKind
- (StInd IntKind
- (StIndex IntKind loc
- (StInt (toInteger fixed_hs))))
- (StPrim IntAddOp [words,
- StInt (toInteger (var_hs (DataRep 0)))])
- in
- heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
-
- returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
-
- genprim [res] SameMutableArrayOp args =
- let compare = StPrim AddrEqOp (map a2stix args)
- assign = StAssign IntKind (a2stix res) compare
- in
- returnSUs (\xs -> assign : xs)
-
- genprim res@[_] SameMutableByteArrayOp args =
- genprim 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}
-
- genprim [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = a2stix lhs
- rhs' = a2stix rhs
- header = StInd PtrKind lhs'
- assign = StAssign PtrKind lhs' rhs'
- freeze = StAssign PtrKind header imMutArrayOfPtrs_info
- in
- returnSUs (\xs -> assign : freeze : xs)
-
- genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
- simpleCoercion PtrKind lhs rhs