Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 597 insertions, 0 deletions

diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
new file mode 100644
index 0000000000..b1b1d9c52d
--- /dev/null
+++ b/rts/RtsAPI.c
@@ -0,0 +1,597 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2001
+ *
+ * API for invoking Haskell functions via the RTS
+ *
+ * --------------------------------------------------------------------------*/
+
+#include "PosixSource.h"
+#include "Rts.h"
+#include "OSThreads.h"
+#include "Storage.h"
+#include "RtsAPI.h"
+#include "SchedAPI.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Prelude.h"
+#include "Schedule.h"
+#include "Capability.h"
+
+#include <stdlib.h>
+
+/* ----------------------------------------------------------------------------
+   Building Haskell objects from C datatypes.
+   ------------------------------------------------------------------------- */
+HaskellObj
+rts_mkChar (Capability *cap, HsChar c)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
+  SET_HDR(p, Czh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgWord)(StgChar)c;
+  return p;
+}
+
+HaskellObj
+rts_mkInt (Capability *cap, HsInt i)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, Izh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgInt)i;
+  return p;
+}
+
+HaskellObj
+rts_mkInt8 (Capability *cap, HsInt8 i)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
+  /* Make sure we mask out the bits above the lowest 8 */
+  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xff);
+  return p;
+}
+
+HaskellObj
+rts_mkInt16 (Capability *cap, HsInt16 i)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
+  /* Make sure we mask out the relevant bits */
+  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
+  return p;
+}
+
+HaskellObj
+rts_mkInt32 (Capability *cap, HsInt32 i)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgInt)((unsigned)i & 0xffffffff);
+  return p;
+}
+
+HaskellObj
+rts_mkInt64 (Capability *cap, HsInt64 i)
+{
+  llong *tmp;
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
+  SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
+  tmp  = (llong*)&(p->payload[0]);
+  *tmp = (StgInt64)i;
+  return p;
+}
+
+HaskellObj
+rts_mkWord (Capability *cap, HsWord i)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgWord)i;
+  return p;
+}
+
+HaskellObj
+rts_mkWord8 (Capability *cap, HsWord8 w)
+{
+  /* see rts_mkInt* comments */
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xff);
+  return p;
+}
+
+HaskellObj
+rts_mkWord16 (Capability *cap, HsWord16 w)
+{
+  /* see rts_mkInt* comments */
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffff);
+  return p;
+}
+
+HaskellObj
+rts_mkWord32 (Capability *cap, HsWord32 w)
+{
+  /* see rts_mkInt* comments */
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)(StgWord)(w & 0xffffffff);
+  return p;
+}
+
+HaskellObj
+rts_mkWord64 (Capability *cap, HsWord64 w)
+{
+  ullong *tmp;
+
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
+  /* see mk_Int8 comment */
+  SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
+  tmp  = (ullong*)&(p->payload[0]);
+  *tmp = (StgWord64)w;
+  return p;
+}
+
+HaskellObj
+rts_mkFloat (Capability *cap, HsFloat f)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+  SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
+  ASSIGN_FLT((P_)p->payload, (StgFloat)f);
+  return p;
+}
+
+HaskellObj
+rts_mkDouble (Capability *cap, HsDouble d)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
+  SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
+  ASSIGN_DBL((P_)p->payload, (StgDouble)d);
+  return p;
+}
+
+HaskellObj
+rts_mkStablePtr (Capability *cap, HsStablePtr s)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+  SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)s;
+  return p;
+}
+
+HaskellObj
+rts_mkPtr (Capability *cap, HsPtr a)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+  SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)a;
+  return p;
+}
+
+HaskellObj
+rts_mkFunPtr (Capability *cap, HsFunPtr a)
+{
+  StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+  SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
+  p->payload[0]  = (StgClosure *)a;
+  return p;
+}
+
+HaskellObj
+rts_mkBool (Capability *cap STG_UNUSED, HsBool b)
+{
+  if (b) {
+    return (StgClosure *)True_closure;
+  } else {
+    return (StgClosure *)False_closure;
+  }
+}
+
+HaskellObj
+rts_mkString (Capability *cap, char *s)
+{
+  return rts_apply(cap, (StgClosure *)unpackCString_closure, rts_mkPtr(cap,s));
+}
+
+HaskellObj
+rts_apply (Capability *cap, HaskellObj f, HaskellObj arg)
+{
+    StgThunk *ap;
+
+    ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
+    SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
+    ap->payload[0] = f;
+    ap->payload[1] = arg;
+    return (StgClosure *)ap;
+}
+
+/* ----------------------------------------------------------------------------
+   Deconstructing Haskell objects
+
+   We would like to assert that we have the right kind of object in
+   each case, but this is problematic because in GHCi the info table
+   for the D# constructor (say) might be dynamically loaded.  Hence we
+   omit these assertions for now.
+   ------------------------------------------------------------------------- */
+
+HsChar
+rts_getChar (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Czh_con_info ||
+    //        p->header.info == Czh_static_info);
+    return (StgChar)(StgWord)(p->payload[0]);
+}
+
+HsInt
+rts_getInt (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Izh_con_info ||
+    //        p->header.info == Izh_static_info);
+    return (HsInt)(p->payload[0]);
+}
+
+HsInt8
+rts_getInt8 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == I8zh_con_info ||
+    //        p->header.info == I8zh_static_info);
+    return (HsInt8)(HsInt)(p->payload[0]);
+}
+
+HsInt16
+rts_getInt16 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == I16zh_con_info ||
+    //        p->header.info == I16zh_static_info);
+    return (HsInt16)(HsInt)(p->payload[0]);
+}
+
+HsInt32
+rts_getInt32 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == I32zh_con_info ||
+    //        p->header.info == I32zh_static_info);
+    return (HsInt32)(HsInt)(p->payload[0]);
+}
+
+HsInt64
+rts_getInt64 (HaskellObj p)
+{
+    HsInt64* tmp;
+    // See comment above:
+    // ASSERT(p->header.info == I64zh_con_info ||
+    //        p->header.info == I64zh_static_info);
+    tmp = (HsInt64*)&(p->payload[0]);
+    return *tmp;
+}
+HsWord
+rts_getWord (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Wzh_con_info ||
+    //        p->header.info == Wzh_static_info);
+    return (HsWord)(p->payload[0]);
+}
+
+HsWord8
+rts_getWord8 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == W8zh_con_info ||
+    //        p->header.info == W8zh_static_info);
+    return (HsWord8)(HsWord)(p->payload[0]);
+}
+
+HsWord16
+rts_getWord16 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == W16zh_con_info ||
+    //        p->header.info == W16zh_static_info);
+    return (HsWord16)(HsWord)(p->payload[0]);
+}
+
+HsWord32
+rts_getWord32 (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == W32zh_con_info ||
+    //        p->header.info == W32zh_static_info);
+    return (HsWord32)(HsWord)(p->payload[0]);
+}
+
+
+HsWord64
+rts_getWord64 (HaskellObj p)
+{
+    HsWord64* tmp;
+    // See comment above:
+    // ASSERT(p->header.info == W64zh_con_info ||
+    //        p->header.info == W64zh_static_info);
+    tmp = (HsWord64*)&(p->payload[0]);
+    return *tmp;
+}
+
+HsFloat
+rts_getFloat (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Fzh_con_info ||
+    //        p->header.info == Fzh_static_info);
+    return (float)(PK_FLT((P_)p->payload));
+}
+
+HsDouble
+rts_getDouble (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Dzh_con_info ||
+    //        p->header.info == Dzh_static_info);
+    return (double)(PK_DBL((P_)p->payload));
+}
+
+HsStablePtr
+rts_getStablePtr (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == StablePtr_con_info ||
+    //        p->header.info == StablePtr_static_info);
+    return (StgStablePtr)(p->payload[0]);
+}
+
+HsPtr
+rts_getPtr (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == Ptr_con_info ||
+    //        p->header.info == Ptr_static_info);
+    return (Capability *)(p->payload[0]);
+}
+
+HsFunPtr
+rts_getFunPtr (HaskellObj p)
+{
+    // See comment above:
+    // ASSERT(p->header.info == FunPtr_con_info ||
+    //        p->header.info == FunPtr_static_info);
+    return (void *)(p->payload[0]);
+}
+
+HsBool
+rts_getBool (HaskellObj p)
+{
+    StgInfoTable *info;
+
+    info = get_itbl((StgClosure *)p);
+    if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
+	return 0;
+    } else {
+	return 1;
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   Creating threads
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER void pushClosure   (StgTSO *tso, StgWord c) {
+  tso->sp--;
+  tso->sp[0] = (W_) c;
+}
+
+StgTSO *
+createGenThread (Capability *cap, nat stack_size,  StgClosure *closure)
+{
+  StgTSO *t;
+#if defined(GRAN)
+  t = createThread (cap, stack_size, NO_PRI);
+#else
+  t = createThread (cap, stack_size);
+#endif
+  pushClosure(t, (W_)closure);
+  pushClosure(t, (W_)&stg_enter_info);
+  return t;
+}
+
+StgTSO *
+createIOThread (Capability *cap, nat stack_size,  StgClosure *closure)
+{
+  StgTSO *t;
+#if defined(GRAN)
+  t = createThread (cap, stack_size, NO_PRI);
+#else
+  t = createThread (cap, stack_size);
+#endif
+  pushClosure(t, (W_)&stg_noforceIO_info);
+  pushClosure(t, (W_)&stg_ap_v_info);
+  pushClosure(t, (W_)closure);
+  pushClosure(t, (W_)&stg_enter_info);
+  return t;
+}
+
+/*
+ * Same as above, but also evaluate the result of the IO action
+ * to whnf while we're at it.
+ */
+
+StgTSO *
+createStrictIOThread(Capability *cap, nat stack_size,  StgClosure *closure)
+{
+  StgTSO *t;
+#if defined(GRAN)
+  t = createThread(cap, stack_size, NO_PRI);
+#else
+  t = createThread(cap, stack_size);
+#endif
+  pushClosure(t, (W_)&stg_forceIO_info);
+  pushClosure(t, (W_)&stg_ap_v_info);
+  pushClosure(t, (W_)closure);
+  pushClosure(t, (W_)&stg_enter_info);
+  return t;
+}
+
+/* ----------------------------------------------------------------------------
+   Evaluating Haskell expressions
+   ------------------------------------------------------------------------- */
+
+Capability *
+rts_eval (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
+{
+    StgTSO *tso;
+    
+    tso = createGenThread(cap, RtsFlags.GcFlags.initialStkSize, p);
+    return scheduleWaitThread(tso,ret,cap);
+}
+
+Capability *
+rts_eval_ (Capability *cap, HaskellObj p, unsigned int stack_size, 
+	   /*out*/HaskellObj *ret)
+{
+    StgTSO *tso;
+
+    tso = createGenThread(cap, stack_size, p);
+    return scheduleWaitThread(tso,ret,cap);
+}
+
+/*
+ * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
+ * result to WHNF before returning.
+ */
+Capability *
+rts_evalIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
+{
+    StgTSO* tso; 
+    
+    tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
+    return scheduleWaitThread(tso,ret,cap);
+}
+
+/*
+ * rts_evalStableIO() is suitable for calling from Haskell.  It
+ * evaluates a value of the form (StablePtr (IO a)), forcing the
+ * action's result to WHNF before returning.  The result is returned
+ * in a StablePtr.
+ */
+Capability *
+rts_evalStableIO (Capability *cap, HsStablePtr s, /*out*/HsStablePtr *ret)
+{
+    StgTSO* tso;
+    StgClosure *p, *r;
+    SchedulerStatus stat;
+    
+    p = (StgClosure *)deRefStablePtr(s);
+    tso = createStrictIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
+    cap = scheduleWaitThread(tso,&r,cap);
+    stat = rts_getSchedStatus(cap);
+
+    if (stat == Success && ret != NULL) {
+	ASSERT(r != NULL);
+	*ret = getStablePtr((StgPtr)r);
+    }
+
+    return cap;
+}
+
+/*
+ * Like rts_evalIO(), but doesn't force the action's result.
+ */
+Capability *
+rts_evalLazyIO (Capability *cap, HaskellObj p, /*out*/HaskellObj *ret)
+{
+    StgTSO *tso;
+
+    tso = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, p);
+    return scheduleWaitThread(tso,ret,cap);
+}
+
+Capability *
+rts_evalLazyIO_ (Capability *cap, HaskellObj p, unsigned int stack_size, 
+		 /*out*/HaskellObj *ret)
+{
+    StgTSO *tso;
+
+    tso = createIOThread(cap, stack_size, p);
+    return scheduleWaitThread(tso,ret,cap);
+}
+
+/* Convenience function for decoding the returned status. */
+
+void
+rts_checkSchedStatus (char* site, Capability *cap)
+{
+    SchedulerStatus rc = cap->running_task->stat;
+    switch (rc) {
+    case Success:
+	return;
+    case Killed:
+	errorBelch("%s: uncaught exception",site);
+	stg_exit(EXIT_FAILURE);
+    case Interrupted:
+	errorBelch("%s: interrupted", site);
+	stg_exit(EXIT_FAILURE);
+    default:
+	errorBelch("%s: Return code (%d) not ok",(site),(rc));	
+	stg_exit(EXIT_FAILURE);
+    }
+}
+
+SchedulerStatus
+rts_getSchedStatus (Capability *cap)
+{
+    return cap->running_task->stat;
+}
+
+Capability *
+rts_lock (void)
+{
+    Capability *cap;
+    Task *task;
+
+    // ToDo: get rid of this lock in the common case.  We could store
+    // a free Task in thread-local storage, for example.  That would
+    // leave just one lock on the path into the RTS: cap->lock when
+    // acquiring the Capability.
+    ACQUIRE_LOCK(&sched_mutex);
+    task = newBoundTask();
+    RELEASE_LOCK(&sched_mutex);
+
+    cap = NULL;
+    waitForReturnCapability(&cap, task);
+    return (Capability *)cap;
+}
+
+// Exiting the RTS: we hold a Capability that is not necessarily the
+// same one that was originally returned by rts_lock(), because
+// rts_evalIO() etc. may return a new one.  Now that we have
+// investigated the return value, we can release the Capability,
+// and free the Task (in that order).
+
+void
+rts_unlock (Capability *cap)
+{
+    Task *task;
+
+    task = cap->running_task;
+    ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
+
+    // slightly delicate ordering of operations below, pay attention!
+
+    // We are no longer a bound task/thread.  This is important,
+    // because the GC can run when we release the Capability below,
+    // and we don't want it to treat this as a live TSO pointer.
+    task->tso = NULL;
+
+    // Now release the Capability.  With the capability released, GC
+    // may happen.  NB. does not try to put the current Task on the
+    // worker queue.
+    releaseCapability(cap);
+
+    // Finally, we can release the Task to the free list.
+    boundTaskExiting(task);
+}