2 files changed, 337 insertions, 0 deletions
diff --git a/libraries/ghc-heap/cbits/Stack.c b/libraries/ghc-heap/cbits/Stack.c
new file mode 100644
index 0000000000..3bbcbf1bd3
--- /dev/null
+++ b/libraries/ghc-heap/cbits/Stack.c
@@ -0,0 +1,150 @@
+#include "MachDeps.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+#include "rts/Types.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/InfoTables.h"
+
+StgWord stackFrameSize(StgStack *stack, StgWord index) {
+  StgClosure *c = (StgClosure *)stack->sp + index;
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+  return stack_frame_sizeW(c);
+}
+
+StgStack *getUnderflowFrameStack(StgStack *stack, StgWord index) {
+  StgClosure *frame = (StgClosure *)stack->sp + index;
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
+  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
+
+  if (info->i.type == UNDERFLOW_FRAME) {
+    return ((StgUnderflowFrame *)frame)->next_chunk;
+  } else {
+    return NULL;
+  }
+}
+
+// Only exists to make the get_itbl macro available in Haskell code (via FFI).
+const StgInfoTable *getItbl(StgClosure *closure) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+  return get_itbl(closure);
+};
+
+StgWord getBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgWord bitmap = info->layout.bitmap;
+  return BITMAP_SIZE(bitmap);
+}
+
+StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_SIZE(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    return GET_FUN_LARGE_BITMAP(fun_info)->size;
+  default:
+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getBitmapWord(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgWord bitmap = info->layout.bitmap;
+  StgWord bitmapWord = BITMAP_BITS(bitmap);
+  return bitmapWord;
+}
+
+StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_BITS(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    // Cannot do more than warn and exit.
+    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
+    stg_exit(EXIT_INTERNAL_ERROR);
+  default:
+    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getLargeBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+  return bitmap->size;
+}
+
+StgWord getRetFunSize(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_SIZE(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    return GET_FUN_LARGE_BITMAP(fun_info)->size;
+  default:
+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getBCOLargeBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  StgBCO *bco = (StgBCO *)*c->payload;
+
+  return BCO_BITMAP_SIZE(bco);
+}
+
+StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+  const StgInfoTable *info = get_itbl(c);
+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+
+  return bitmap->bitmap;
+}
+
+StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
+
+  return bitmap->bitmap;
+}
+
+StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  StgBCO *bco = (StgBCO *)*c->payload;
+  StgLargeBitmap *bitmap = BCO_BITMAP(bco);
+
+  return bitmap->bitmap;
+}
+
+StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
+  return frame->next_chunk;
+}
+
+StgWord getRetFunType(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  return fun_info->f.fun_type;
+}
+
+StgClosure *getStackClosure(StgClosure **c) { return *c; }
diff --git a/libraries/ghc-heap/cbits/Stack.cmm b/libraries/ghc-heap/cbits/Stack.cmm
new file mode 100644
index 0000000000..ed9712fe7b
--- /dev/null
+++ b/libraries/ghc-heap/cbits/Stack.cmm
@@ -0,0 +1,187 @@
+// Uncomment to enable assertions during development
+// #define DEBUG 1
+
+#include "Cmm.h"
+
+// StgStack_marking was not available in the Stage0 compiler at the time of
+// writing. Because, it has been added to derivedConstants when Stack.cmm was
+// developed.
+#if defined(StgStack_marking)
+
+// Returns the next stackframe's StgStack* and offset in it. And, an indicator
+// if this frame is the last one (`hasNext` bit.)
+// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
+advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
+  W_ frameSize;
+  (frameSize) = ccall stackFrameSize(stack, offsetWords);
+
+  P_ nextClosurePtr;
+  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));
+
+  P_ stackArrayPtr;
+  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;
+
+  P_ stackBottom;
+  W_ stackSize, stackSizeInBytes;
+  stackSize = TO_W_(StgStack_stack_size(stack));
+  stackSizeInBytes = WDS(stackSize);
+  stackBottom = stackSizeInBytes + stackArrayPtr;
+
+  P_ newStack;
+  W_ newOffsetWords, hasNext;
+  if(nextClosurePtr < stackBottom) (likely: True) {
+    newStack = stack;
+    newOffsetWords = offsetWords + frameSize;
+    hasNext = 1;
+  } else {
+    P_ underflowFrameStack;
+    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
+    if (underflowFrameStack == NULL) (likely: True) {
+      newStack = NULL;
+      newOffsetWords = NULL;
+      hasNext = NULL;
+    } else {
+      newStack = underflowFrameStack;
+      newOffsetWords = NULL;
+      hasNext = 1;
+    }
+  }
+
+  return (newStack, newOffsetWords, hasNext);
+}
+
+// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+getSmallBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ bitmap, size;
+  (bitmap) = ccall getBitmapWord(c);
+  (size) = ccall getBitmapSize(c);
+
+  return (bitmap, size);
+}
+
+
+// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ bitmap, size, specialType;
+  (bitmap) = ccall getRetFunBitmapWord(c);
+  (size) = ccall getRetFunBitmapSize(c);
+
+  return (bitmap, size);
+}
+
+// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getLargeBitmap(MyCapability(), c);
+  (size) = ccall getLargeBitmapSize(c);
+
+  return (words, size);
+}
+
+// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getBCOLargeBitmap(MyCapability(), c);
+  (size) = ccall getBCOLargeBitmapSize(c);
+
+  return (words, size);
+}
+
+// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);
+  (size) = ccall getRetFunSize(c);
+
+  return (words, size);
+}
+
+// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)
+getWordzh(P_ stack, W_ offsetWords) {
+  P_ wordAddr;
+  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));
+  return (W_[wordAddr]);
+}
+
+// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)
+getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {
+  P_ closurePtr;
+  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
+  ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr));
+
+  P_ next_chunk;
+  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
+  ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk));
+  return (next_chunk);
+}
+
+// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)
+getRetFunTypezh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ type;
+  (type) = ccall getRetFunType(c);
+  return (type);
+}
+
+// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
+getInfoTableAddrzh(P_ stack, W_ offsetWords) {
+  P_ p, info;
+  p = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+  info = %GET_STD_INFO(UNTAG(p));
+
+  return (info);
+}
+
+// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
+getStackInfoTableAddrzh(P_ stack) {
+  P_ info;
+  info = %GET_STD_INFO(UNTAG(stack));
+  return (info);
+}
+
+// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
+getStackClosurezh(P_ stack, W_ offsetWords) {
+  P_ ptr;
+  ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+  P_ closure;
+  (closure) = ccall getStackClosure(ptr);
+  return (closure);
+}
+
+// (bits32, bits8, bits8) getStackFieldszh(StgStack* stack)
+getStackFieldszh(P_ stack){
+  bits32 size;
+  bits8 dirty, marking;
+
+  size = StgStack_stack_size(stack);
+  dirty = StgStack_dirty(stack);
+  marking = StgStack_marking(stack);
+
+  return (size, dirty, marking);
+}
+#endif