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, 446 insertions, 0 deletions

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
new file mode 100644
index 0000000000..b5c29626b2
--- /dev/null
+++ b/rts/Exception.cmm
@@ -0,0 +1,446 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Exception support
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC.  It is compiled by GHC directly.  For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/* -----------------------------------------------------------------------------
+   Exception Primitives
+
+   A thread can request that asynchronous exceptions not be delivered
+   ("blocked") for the duration of an I/O computation.  The primitive
+   
+	blockAsyncExceptions# :: IO a -> IO a
+
+   is used for this purpose.  During a blocked section, asynchronous
+   exceptions may be unblocked again temporarily:
+
+	unblockAsyncExceptions# :: IO a -> IO a
+
+   Furthermore, asynchronous exceptions are blocked automatically during
+   the execution of an exception handler.  Both of these primitives
+   leave a continuation on the stack which reverts to the previous
+   state (blocked or unblocked) on exit.
+
+   A thread which wants to raise an exception in another thread (using
+   killThread#) must block until the target thread is ready to receive
+   it.  The action of unblocking exceptions in a thread will release all
+   the threads waiting to deliver exceptions to that thread.
+
+   NB. there's a bug in here.  If a thread is inside an
+   unsafePerformIO, and inside blockAsyncExceptions# (there is an
+   unblockAsyncExceptions_ret on the stack), and it is blocked in an
+   interruptible operation, and it receives an exception, then the
+   unsafePerformIO thunk will be updated with a stack object
+   containing the unblockAsyncExceptions_ret frame.  Later, when
+   someone else evaluates this thunk, the blocked exception state is
+   not restored, and the result is that unblockAsyncExceptions_ret
+   will attempt to unblock exceptions in the current thread, but it'll
+   find that the CurrentTSO->blocked_exceptions is NULL.  Hence, we
+   work around this by checking for NULL in awakenBlockedQueue().
+
+   -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
+ 		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+    // Not true: see comments above
+    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+#if defined(GRAN) || defined(PAR)
+    foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr", 
+				   NULL "ptr"); 
+#else
+    foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr");
+#endif
+    StgTSO_blocked_exceptions(CurrentTSO) = NULL;
+#ifdef REG_R1
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(0));
+#else
+    Sp(1) = Sp(0);
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(1));
+#endif
+}
+
+INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
+  		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+    // Not true: see comments above
+    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) == NULL);
+    StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+#ifdef REG_R1
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(0));
+#else
+    Sp(1) = Sp(0);
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(1));
+#endif
+}
+
+blockAsyncExceptionszh_fast
+{
+    /* Args: R1 :: IO a */
+    STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
+
+    if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
+      StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+      /* avoid growing the stack unnecessarily */
+      if (Sp(0) == stg_blockAsyncExceptionszh_ret_info) {
+	Sp_adj(1);
+      } else {
+	Sp_adj(-1);
+	Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+      }
+    }
+    TICK_UNKNOWN_CALL();
+    TICK_SLOW_CALL_v();
+    jump stg_ap_v_fast;
+}
+
+unblockAsyncExceptionszh_fast
+{
+    /* Args: R1 :: IO a */
+    STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
+
+    if (StgTSO_blocked_exceptions(CurrentTSO) != NULL) {
+#if defined(GRAN) || defined(PAR)
+      foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr", 
+	          		     StgTSO_block_info(CurrentTSO) "ptr");
+#else
+      foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr");
+#endif
+      StgTSO_blocked_exceptions(CurrentTSO) = NULL;
+
+      /* avoid growing the stack unnecessarily */
+      if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
+	Sp_adj(1);
+      } else {
+	Sp_adj(-1);
+	Sp(0) = stg_blockAsyncExceptionszh_ret_info;
+      }
+    }
+    TICK_UNKNOWN_CALL();
+    TICK_SLOW_CALL_v();
+    jump stg_ap_v_fast;
+}
+
+
+#define interruptible(what_next) 		\
+        (   what_next == BlockedOnMVar		\
+         || what_next == BlockedOnException	\
+         || what_next == BlockedOnRead		\
+         || what_next == BlockedOnWrite		\
+         || what_next == BlockedOnDelay		\
+         || what_next == BlockedOnDoProc)
+
+killThreadzh_fast
+{
+  /* args: R1 = TSO to kill, R2 = Exception */
+
+  W_ why_blocked;
+
+  /* This thread may have been relocated.
+   * (see Schedule.c:threadStackOverflow)
+   */
+ while:
+  if (StgTSO_what_next(R1) == ThreadRelocated::I16) {
+    R1 = StgTSO_link(R1);
+    goto while;
+  }
+
+  /* Determine whether this thread is interruptible or not */
+
+  /* If the target thread is currently blocking async exceptions,
+   * we'll have to block until it's ready to accept them.  The
+   * exception is interruptible threads - ie. those that are blocked
+   * on some resource.
+   */
+  why_blocked = TO_W_(StgTSO_why_blocked(R1));
+  if (StgTSO_blocked_exceptions(R1) != NULL && !interruptible(why_blocked))
+  {
+      StgTSO_link(CurrentTSO) = StgTSO_blocked_exceptions(R1);
+      StgTSO_blocked_exceptions(R1) = CurrentTSO;
+      
+      StgTSO_why_blocked(CurrentTSO) = BlockedOnException::I16;
+      StgTSO_block_info(CurrentTSO) = R1;
+      
+      BLOCK( R1_PTR & R2_PTR, killThreadzh_fast );
+  }
+
+  /* Killed threads turn into zombies, which might be garbage
+   * collected at a later date.  That's why we don't have to
+   * explicitly remove them from any queues they might be on.
+   */
+
+  /* We might have killed ourselves.  In which case, better be *very*
+   * careful.  If the exception killed us, then return to the scheduler.
+   * If the exception went to a catch frame, we'll just continue from
+   * the handler.
+   */
+  if (R1 == CurrentTSO) {
+	SAVE_THREAD_STATE();
+	foreign "C" raiseAsync(MyCapability() "ptr", R1 "ptr", R2 "ptr");
+	if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+		R1 = ThreadFinished;
+		jump StgReturn;
+	} else {
+		LOAD_THREAD_STATE();
+		ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+		jump %ENTRY_CODE(Sp(0));
+	}
+  } else {
+	foreign "C" raiseAsync(MyCapability() "ptr", R1 "ptr", R2 "ptr");
+  }
+
+  jump %ENTRY_CODE(Sp(0));
+}
+
+/* -----------------------------------------------------------------------------
+   Catch frames
+   -------------------------------------------------------------------------- */
+
+#ifdef REG_R1
+#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) 	\
+   label					\
+   {						\
+      Sp = Sp + SIZEOF_StgCatchFrame; 		\
+      jump ret;					\
+   }
+#else
+#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) 	\
+   label					\
+   {						\
+      W_ rval;					\
+      rval = Sp(0);				\
+      Sp = Sp + SIZEOF_StgCatchFrame;		\
+      Sp(0) = rval;				\
+      jump ret;					\
+   }
+#endif
+
+#ifdef REG_R1
+#define SP_OFF 0
+#else
+#define SP_OFF 1
+#endif
+
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
+
+#if MAX_VECTORED_RTN > 8
+#error MAX_VECTORED_RTN has changed: please modify stg_catch_frame too.
+#endif
+
+#if defined(PROFILING)
+#define CATCH_FRAME_BITMAP 7
+#define CATCH_FRAME_WORDS  4
+#else
+#define CATCH_FRAME_BITMAP 1
+#define CATCH_FRAME_WORDS  2
+#endif
+
+/* Catch frames are very similar to update frames, but when entering
+ * one we just pop the frame off the stack and perform the correct
+ * kind of return to the activation record underneath us on the stack.
+ */
+
+INFO_TABLE_RET(stg_catch_frame,
+	       CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
+	       CATCH_FRAME,
+	       stg_catch_frame_0_ret,
+	       stg_catch_frame_1_ret,
+	       stg_catch_frame_2_ret,
+	       stg_catch_frame_3_ret,
+	       stg_catch_frame_4_ret,
+	       stg_catch_frame_5_ret,
+	       stg_catch_frame_6_ret,
+	       stg_catch_frame_7_ret)
+CATCH_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
+
+/* -----------------------------------------------------------------------------
+ * The catch infotable
+ *
+ * This should be exactly the same as would be generated by this STG code
+ *
+ * catch = {x,h} \n {} -> catch#{x,h}
+ *
+ * It is used in deleteThread when reverting blackholes.
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
+{
+  R2 = StgClosure_payload(R1,1); /* h */
+  R1 = StgClosure_payload(R1,0); /* x */
+  jump catchzh_fast;
+}
+
+catchzh_fast
+{
+    /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
+    STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, catchzh_fast);
+  
+    /* Set up the catch frame */
+    Sp = Sp - SIZEOF_StgCatchFrame;
+    SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
+    
+    StgCatchFrame_handler(Sp) = R2;
+    StgCatchFrame_exceptions_blocked(Sp) = 
+	(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+    TICK_CATCHF_PUSHED();
+
+    /* Apply R1 to the realworld token */
+    TICK_UNKNOWN_CALL();
+    TICK_SLOW_CALL_v();
+    jump stg_ap_v_fast;
+}      
+
+/* -----------------------------------------------------------------------------
+ * The raise infotable
+ * 
+ * This should be exactly the same as would be generated by this STG code
+ *
+ *   raise = {err} \n {} -> raise#{err}
+ *
+ * It is used in raisezh_fast to update thunks on the update list
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
+{
+  R1 = StgThunk_payload(R1,0);
+  jump raisezh_fast;
+}
+
+raisezh_fast
+{
+    W_ handler;
+    W_ raise_closure;
+    W_ frame_type;
+    /* args : R1 :: Exception */
+
+
+#if defined(PROFILING)
+    /* Debugging tool: on raising an  exception, show where we are. */
+
+    /* ToDo: currently this is a hack.  Would be much better if
+     * the info was only displayed for an *uncaught* exception.
+     */
+    if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags)) {
+      foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
+    }
+#endif
+
+retry_pop_stack:
+    StgTSO_sp(CurrentTSO) = Sp;
+    frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", R1 "ptr");
+    Sp = StgTSO_sp(CurrentTSO);
+    if (frame_type == ATOMICALLY_FRAME) {
+      /* The exception has reached the edge of a memory transaction.  Check that 
+       * the transaction is valid.  If not then perhaps the exception should
+       * not have been thrown: re-run the transaction */
+      W_ trec;
+      W_ r;
+      trec = StgTSO_trec(CurrentTSO);
+      r = foreign "C" stmValidateNestOfTransactions(trec "ptr");
+      foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+      StgTSO_trec(CurrentTSO) = NO_TREC;
+      if (r) {
+        // Transaction was valid: continue searching for a catch frame
+        Sp = Sp + SIZEOF_StgAtomicallyFrame;
+        goto retry_pop_stack;
+      } else {
+        // Transaction was not valid: we retry the exception (otherwise continue
+        // with a further call to raiseExceptionHelper)
+        "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
+        StgTSO_trec(CurrentTSO) = trec;
+        R1 = StgAtomicallyFrame_code(Sp);
+        jump stg_ap_v_fast;
+      }          
+    }
+
+    if (frame_type == STOP_FRAME) {
+	/*
+	 * We've stripped the entire stack, the thread is now dead.
+	 * We will leave the stack in a GC'able state, see the stg_stop_thread
+	 * entry code in StgStartup.cmm.
+	 */
+	Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
+		+ WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
+	Sp(1) = R1;		/* save the exception */
+	Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
+	StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
+	SAVE_THREAD_STATE();	/* inline! */
+
+	/* The return code goes in BaseReg->rRet, and BaseReg is returned in R1 */
+	StgRegTable_rRet(BaseReg) = ThreadFinished;
+	R1 = BaseReg;
+
+	jump StgReturn;
+    }
+
+    /* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME.  Pop everything
+     * down to and including this frame, update Su, push R1, and enter the handler.
+     */
+    if (frame_type == CATCH_FRAME) {
+      handler = StgCatchFrame_handler(Sp);
+    } else {
+      handler = StgCatchSTMFrame_handler(Sp);
+    }
+
+    /* Restore the blocked/unblocked state for asynchronous exceptions
+     * at the CATCH_FRAME.  
+     *
+     * If exceptions were unblocked, arrange that they are unblocked
+     * again after executing the handler by pushing an
+     * unblockAsyncExceptions_ret stack frame.
+     */
+    W_ frame;
+    frame = Sp;
+    if (frame_type == CATCH_FRAME) {
+      Sp = Sp + SIZEOF_StgCatchFrame;
+      if (StgCatchFrame_exceptions_blocked(frame) == 0) {
+        Sp_adj(-1);
+        Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+      }
+    } else {
+      Sp = Sp + SIZEOF_StgCatchSTMFrame;
+    }
+
+    /* Ensure that async excpetions are blocked when running the handler.
+    */
+    if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
+      StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+    }
+
+    /* Call the handler, passing the exception value and a realworld
+     * token as arguments.
+     */
+    Sp_adj(-1);
+    Sp(0) = R1;
+    R1 = handler;
+    Sp_adj(-1);
+    TICK_UNKNOWN_CALL();
+    TICK_SLOW_CALL_pv();
+    jump RET_LBL(stg_ap_pv);
+}
+
+raiseIOzh_fast
+{
+  /* Args :: R1 :: Exception */
+  jump raisezh_fast;
+}