+#ifdef XMLAMBDA
+/*------------------------------------------------------------------------
+ Insert and Remove primitives on Rows. This is important stuff for
+ XMlambda, these prims are called *all* the time. That's the reason
+ for all the specialized versions of the basic instructions.
+ note: A Gc might move rows around => allocate first, than pop the arguments.
+------------------------------------------------------------------------*/
+
+/*------------------------------------------------------------------------
+ i_rowInsertAt: insert an element into a row
+------------------------------------------------------------------------*/
+ case i_rowInsertAt:
+ {
+ StgWord j;
+ StgWord i;
+ StgWord n;
+ StgClosure* x;
+
+ /* allocate a new row before popping arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop index and value */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
+ newRow->ptrs = n+1;
+
+ i = PopTaggedWord();
+ x = PopCPtr();
+
+ ASSERT(i <= n);
+
+ /* copy the fields, inserting the new value */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ newRow->payload[i] = x;
+ for (j = i+1; j <= n; j++)
+ {
+ newRow->payload[j] = row->payload[j-1];
+ }
+
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
+ instruction is vital for XMLambda since we would otherwise allocate
+ a lot of intermediate rows.
+ It assumes that the RTS has no NULL pointers.
+ It behaves 'optimal' if the witnesses are ordered, (lowest on the
+ bottom of the stack).
+------------------------------------------------------------------------*/
+#define ROW_HOLE 0
+ case i_rowChainInsert:
+ {
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop the row and assign again (it may have moved during gc!) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = n + row->ptrs;
+
+ /* zero the fields */
+ for (i = 0; i < newRow->ptrs; i++)
+ {
+ newRow->payload[i] = ROW_HOLE;
+ }
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
+
+ /* copy the values from the old row into the holes */
+ for (j =0, i = 0; i < row->ptrs; j++,i++)
+ {
+ while (newRow->payload[j] != ROW_HOLE) j++;
+ ASSERT(j < n);
+ newRow->payload[j] = row->payload[i];
+ }
+
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
+------------------------------------------------------------------------*/
+ case i_rowChainBuild:
+ {
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ newRow->ptrs = n;
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
+
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowRemoveAt: remove an element from a row
+------------------------------------------------------------------------*/
+ case i_rowRemoveAt:
+ {
+ StgWord j;
+ StgWord i;
+ StgWord n;
+
+ /* allocate new row before popping the arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop the index */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
+ newRow->ptrs = n-1;
+
+ i = PopTaggedWord();
+
+ ASSERT(i < n);
+
+ /* copy the fields, except for the removed value. */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ for (j = i+1; j < n; j++)
+ {
+ newRow->payload[j-1] = row->payload[j];
+ }
+
+ PushCPtr(row->payload[i]);
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
+ this is a vital instruction to avoid lots of intermediate rows.
+ It behaves 'optimal' if the witnessses are ordered, lowest on the
+ bottom of the stack.
+ The implementation is quite dirty, blame Daan for this :-)
+ (It overwrites witnesses on the stack with results and marks pointers
+ using their lowest bit.)
+------------------------------------------------------------------------*/
+#define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
+#define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
+#define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
+
+ case i_rowChainRemove:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord j;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+
+ /* pop number of arguments (=witnesses) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row and assign again (gc might have moved it) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = row->ptrs - n;
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* copy all remaining elements and clear the marks */
+ for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
+ {
+ while (ISMARKED(row->payload[j]))
+ {
+ row->payload[j] = UNMARK(row->payload[j]);
+ j++;
+ }
+ newRow->payload[i] = row->payload[j];
+ }
+
+ /* unmark tail */
+ while (j < row->ptrs)
+ {
+ value = row->payload[j];
+ if (ISMARKED(value)) row->payload[j] = UNMARK(value);
+ j++;
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+
+ /* and push the result row */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
+ the resulting row, only the removed elements.
+------------------------------------------------------------------------*/
+ case i_rowChainSelect:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+ /* pop number of arguments (=witnesses) and row*/
+ StgWord n = PopTaggedWord();
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* unmark elements */
+ for( i = 0; i < row->ptrs; i++)
+ {
+ value = row->payload[i];
+ if (ISMARKED(value)) row->payload[i] = UNMARK(value);
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+ break;
+ }
+
+#endif /* XMLAMBDA */