Merge branch 'master' of http://darcs.haskell.org/ghc

compiler/cmm/CmmSink.hs

@@ -365,23 +365,31 @@ tryToInline dflags live node assigs = go usages node [] assigs
   go _usages node _skipped [] = (node, [])
 
   go usages node skipped (a@(l,rhs,_) : rest)
-   | can_inline     = inline_and_discard
-   | isTrivial rhs  = inline_and_keep
+   | cannot_inline           = dont_inline
+   | occurs_once             = inline_and_discard
+   | isTrivial rhs           = inline_and_keep
+   | otherwise               = dont_inline
    where
-        inline_and_discard = go usages' node' skipped rest
+        inline_and_discard = go usages' inl_node skipped rest
+          where usages' = foldRegsUsed addUsage usages rhs
 
-        inline_and_keep = (node'', a : rest')
-          where (node'',rest') = go usages' node' (l:skipped) rest
+        dont_inline        = keep node  -- don't inline the assignment, keep it
+        inline_and_keep    = keep inl_node -- inline the assignment, keep it
 
-        can_inline =
-            not (l `elemRegSet` live)
-         && not (skipped `regsUsedIn` rhs)  -- Note [dependent assignments]
-         && okToInline dflags rhs node
-         && lookupUFM usages l == Just 1
+        keep node' = (final_node, a : rest')
+          where (final_node, rest') = go usages' node' (l:skipped) rest
+                usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs
+                -- we must not inline anything that is mentioned in the RHS
+                -- of a binding that we have already skipped, so we set the
+                -- usages of the regs on the RHS to 2.
 
-        usages' = foldRegsUsed addUsage usages rhs
+        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]
+                        || not (okToInline dflags rhs node)
 
-        node' = mapExpDeep inline node
+        occurs_once = not (l `elemRegSet` live)
+                      && lookupUFM usages l == Just 1
+
+        inl_node = mapExpDeep inline node
            where inline (CmmReg    (CmmLocal l'))     | l == l' = rhs
                  inline (CmmRegOff (CmmLocal l') off) | l == l'
                     = cmmOffset dflags rhs off
@@ -389,14 +397,6 @@ tryToInline dflags live node assigs = go usages node [] assigs
                  inline (CmmMachOp op args) = cmmMachOpFold dflags op args
                  inline other = other
 
-  go usages node skipped (assig@(l,rhs,_) : rest)
-    = (node', assig : rest')
-    where (node', rest') = go usages' node (l:skipped) rest
-          usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs
-          -- we must not inline anything that is mentioned in the RHS
-          -- of a binding that we have already skipped, so we set the
-          -- usages of the regs on the RHS to 2.
-
 -- Note [dependent assignments]
 --
 -- If our assignment list looks like

compiler/main/GHC.hs

@@ -1260,7 +1260,7 @@ showRichTokenStream ts = go startLoc ts ""
                                        . (str ++)
                                        . go tokEnd ts
                  | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
-                              . ((replicate tokCol ' ') ++)
+                               . ((replicate (tokCol - 1) ' ') ++)
                               . (str ++)
                               . go tokEnd ts
                   where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)

includes/stg/MiscClosures.h

@@ -261,6 +261,7 @@ RTS_RET(stg_ret_f);
 RTS_RET(stg_ret_d);
 RTS_RET(stg_ret_l);
 
+RTS_FUN_DECL(stg_gc_prim);
 RTS_FUN_DECL(stg_gc_prim_p);
 RTS_FUN_DECL(stg_gc_prim_pp);
 RTS_FUN_DECL(stg_gc_prim_n);
@@ -392,6 +393,7 @@ RTS_FUN_DECL(stg_deRefStablePtrzh);
 RTS_FUN_DECL(stg_forkzh);
 RTS_FUN_DECL(stg_forkOnzh);
 RTS_FUN_DECL(stg_yieldzh);
+RTS_FUN_DECL(stg_killMyself);
 RTS_FUN_DECL(stg_killThreadzh);
 RTS_FUN_DECL(stg_getMaskingStatezh);
 RTS_FUN_DECL(stg_maskAsyncExceptionszh);

rts/Capability.c

@@ -842,7 +842,7 @@ tryGrabCapability (Capability *cap, Task *task)
  * allow the workers to stop.
  *
  * This function should be called when interrupted and
- * shutting_down_scheduler = rtsTrue, thus any worker that wakes up
+ * sched_state = SCHED_SHUTTING_DOWN, thus any worker that wakes up
  * will exit the scheduler and call taskStop(), and any bound thread
  * that wakes up will return to its caller.  Runnable threads are
  * killed.

rts/Profiling.c

@@ -1067,7 +1067,7 @@ fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso)
     {
         char *desc;
         StgInfoTable *info;
-        info = get_itbl(exception);
+        info = get_itbl(UNTAG_CLOSURE(exception));
         switch (info->type) {
         case CONSTR:
         case CONSTR_1_0:

rts/Schedule.c

@@ -97,13 +97,6 @@ volatile StgWord sched_state = SCHED_RUNNING;
  */
 StgTSO dummy_tso;
 
-/*
- * Set to TRUE when entering a shutdown state (via shutdownHaskellAndExit()) --
- * in an MT setting, needed to signal that a worker thread shouldn't hang around
- * in the scheduler when it is out of work.
- */
-rtsBool shutting_down_scheduler = rtsFalse;
-
 /*
  * This mutex protects most of the global scheduler data in
  * the THREADED_RTS runtime.
@@ -180,28 +173,6 @@ static void deleteThread_(Capability *cap, StgTSO *tso);
       * thread ends
       * stack overflow
 
-   GRAN version:
-     In a GranSim setup this loop iterates over the global event queue.
-     This revolves around the global event queue, which determines what 
-     to do next. Therefore, it's more complicated than either the 
-     concurrent or the parallel (GUM) setup.
-  This version has been entirely removed (JB 2008/08).
-
-   GUM version:
-     GUM iterates over incoming messages.
-     It starts with nothing to do (thus CurrentTSO == END_TSO_QUEUE),
-     and sends out a fish whenever it has nothing to do; in-between
-     doing the actual reductions (shared code below) it processes the
-     incoming messages and deals with delayed operations 
-     (see PendingFetches).
-     This is not the ugliest code you could imagine, but it's bloody close.
-
-  (JB 2008/08) This version was formerly indicated by a PP-Flag PAR,
-  now by PP-flag PARALLEL_HASKELL. The Eden RTS (in GHC-6.x) uses it,
-  as well as future GUM versions. This file has been refurbished to
-  only contain valid code, which is however incomplete, refers to
-  invalid includes etc.
-
    ------------------------------------------------------------------------ */
 
 static Capability *