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

14 files changed, 117 insertions, 25 deletions

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 601165e0f3..6bcf3fbde4 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -211,6 +211,15 @@ mkCoerce co expr
 -- annotation if possible.
 mkTick :: Tickish Id -> CoreExpr -> CoreExpr
 
+mkTick t (Var x)
+  | isFunTy (idType x) = Tick t (Var x)
+  | otherwise
+  = if tickishCounts t
+       then if tickishScoped t && tickishCanSplit t
+               then Tick (mkNoScope t) (Var x)
+               else Tick t (Var x)
+       else Var x
+
 mkTick t (Cast e co)
   = Cast (mkTick t e) co -- Move tick inside cast
 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1a7db7abf5..2c714efd52 100644..100755
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -326,11 +326,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 	; dflags <- getDOpts
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-	         (ddump_deriving inst_info rn_binds newTyCons famInsts extraInstances))
-{-
-        ; when (not (null inst_info)) $
-          dumpDerivingInfo (ddump_deriving inst_info rn_binds)
--}
+	         (ddump_deriving inst_info rn_binds newTyCons famInsts))
 
   ; let all_tycons = map ATyCon (bagToList newTyCons)
   ; gbl_env <- tcExtendGlobalEnv all_tycons $
@@ -343,22 +339,18 @@ tcDeriving tycl_decls inst_decls deriv_decls
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name 
                    -> Bag TyCon  -- ^ Empty data constructors
                    -> Bag TyCon  -- ^ Rep type family instances
-                   -> Bag (InstInfo RdrName)
-                      -- ^ Instances for the repMetaTys
                    -> SDoc
-    ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+    ddump_deriving inst_infos extra_binds repMetaTys repTyCons
       =    hang (ptext (sLit "Derived instances:"))
               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
                  $$ ppr extra_binds)
         $$ hangP "Generic representation:" (
               hangP "Generated datatypes for meta-information:"
                (vcat (map ppr (bagToList repMetaTys)))
-           -- The Outputable instance for TyCon unfortunately only prints the name...
            $$ hangP "Representation types:"
-                (vcat (map ppr (bagToList repTyCons)))
-           $$ hangP "Meta-information instances:"
-                (vcat (map pprInstInfoDetails (bagToList metaInsts))))
+                (vcat (map pprTyFamInst (bagToList repTyCons))))
     
+    pprTyFamInst t = ppr t <+> text "=" <+> ppr (synTyConType t)
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
 
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 3b71ce39b5..a96cb2f20e 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -34,7 +34,7 @@ import Util
 import Outputable
 import FastString
 
-import Data.Typeable hiding (TyCon)
+import Data.Typeable (Typeable)
 import qualified Data.Data as Data
 \end{code}
 
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 96b02a898f..d05495f7ac 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -35,7 +35,7 @@ import UniqFM
 import Id
 import FastString
 
-import Data.Data        hiding (TyCon, mkTyConApp)
+import Data.Data        ( Data, Typeable )
 import Data.Maybe       ( isJust, isNothing )
 \end{code}
 
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index c8766d9c6f..45a11bc89d 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -97,7 +97,7 @@ import FastString
 import Constants
 import Util
 import qualified Data.Data as Data
-import Data.Typeable hiding (TyCon)
+import Data.Typeable (Typeable)
 \end{code}
 
 -----------------------------------------------
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index 7773bae6a9..0b276b1d9f 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -142,9 +142,9 @@
 #define EVENT_SPARK_GC            41 /* ()                     */
 #define EVENT_INTERN_STRING       42 /* (string, id) {not used by ghc} */
 #define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */
+#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */
 
-
-/* Range 44 - 59 is available for new GHC and common events */
+/* Range 45 - 59 is available for new GHC and common events */
 
 /* Range 60 - 80 is used by eden for parallel tracing
  * see http://www.mathematik.uni-marburg.de/~eden/
@@ -157,7 +157,7 @@
  * ranges higher than this are reserved but not currently emitted by ghc.
  * This must match the size of the EventDesc[] array in EventLog.c
  */
-#define NUM_GHC_EVENT_TAGS        44
+#define NUM_GHC_EVENT_TAGS        45
 
 #if 0  /* DEPRECATED EVENTS: */
 /* we don't actually need to record the thread, it's implicit */
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index c96e459975..85920932c9 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -631,8 +631,8 @@ stg_labelThreadzh
   /* args: 
 	R1 = ThreadId#
 	R2 = Addr# */
-#ifdef DEBUG
-  foreign "C" labelThread(R1 "ptr", R2 "ptr") [];
+#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
+  foreign "C" labelThread(MyCapability() "ptr", R1 "ptr", R2 "ptr") [];
 #endif
   jump %ENTRY_CODE(Sp(0));
 }
diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d
index 04005108d5..1c74619e79 100644
--- a/rts/RtsProbes.d
+++ b/rts/RtsProbes.d
@@ -50,6 +50,7 @@ provider HaskellEvent {
   probe request__seq__gc (EventCapNo);
   probe request__par__gc (EventCapNo);
   probe create__spark__thread (EventCapNo, EventThreadID);
+  probe thread__label (EventCapNo, EventThreadID, char *);
 
   /* other events */
 /* This one doesn't seem to be used at all at the moment: */
diff --git a/rts/ThreadLabels.c b/rts/ThreadLabels.c
index 6d2a5d641d..8838042a83 100644
--- a/rts/ThreadLabels.c
+++ b/rts/ThreadLabels.c
@@ -13,12 +13,13 @@
 #include "ThreadLabels.h"
 #include "RtsUtils.h"
 #include "Hash.h"
+#include "Trace.h"
 
 #include <stdlib.h>
 #include <string.h>
 
 #if defined(DEBUG)
-/* to the end */
+
 static HashTable * threadLabels = NULL;
 
 void
@@ -61,9 +62,14 @@ removeThreadLabel(StgWord key)
   }  
 }
 
+#endif /* DEBUG */
+
 void
-labelThread(StgPtr tso, char *label)
+labelThread(Capability *cap   STG_UNUSED,
+            StgTSO     *tso   STG_UNUSED,
+            char       *label STG_UNUSED)
 {
+#if defined(DEBUG)
   int len;
   void *buf;
 
@@ -72,7 +78,8 @@ labelThread(StgPtr tso, char *label)
   buf = stgMallocBytes(len * sizeof(char), "Schedule.c:labelThread()");
   strncpy(buf,label,len);
   /* Update will free the old memory for us */
-  updateThreadLabel(((StgTSO *)tso)->id,buf);
+  updateThreadLabel(tso->id,buf);
+#endif
+  traceThreadLabel(cap, tso, label);
 }
 
-#endif /* DEBUG */
diff --git a/rts/ThreadLabels.h b/rts/ThreadLabels.h
index 254b91ed10..742e77ae58 100644
--- a/rts/ThreadLabels.h
+++ b/rts/ThreadLabels.h
@@ -17,8 +17,10 @@ void    initThreadLabelTable (void);
 void    freeThreadLabelTable (void);
 void *  lookupThreadLabel    (StgWord key);
 void    removeThreadLabel    (StgWord key);
-void    labelThread          (StgPtr tso, char *label);
 #endif
+void    labelThread          (Capability *cap,
+                              StgTSO     *tso,
+                              char       *label);
 
 #include "EndPrivate.h"
 
diff --git a/rts/Trace.c b/rts/Trace.c
index a3aa266c4e..1671bfeb36 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -547,6 +547,24 @@ void traceUserMsg(Capability *cap, char *msg)
     traceFormatUserMsg(cap, "%s", msg);
 }
 
+void traceThreadLabel_(Capability *cap,
+                       StgTSO     *tso,
+                       char       *label)
+{
+#ifdef DEBUG
+    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+        ACQUIRE_LOCK(&trace_utx);
+        tracePreface();
+        debugBelch("cap %d: thread %lu has label %s\n",
+                   cap->no, (lnat)tso->id, label);
+        RELEASE_LOCK(&trace_utx);
+    } else
+#endif
+    {
+        postThreadLabel(cap, tso->id, label);
+    }
+}
+
 void traceThreadStatus_ (StgTSO *tso USED_IF_DEBUG)
 {
 #ifdef DEBUG
diff --git a/rts/Trace.h b/rts/Trace.h
index a0c5e26e2d..8dacb80eda 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -152,9 +152,18 @@ void trace_(char *msg, ...);
 
 /* 
  * A message or event emitted by the program
+ * Used by Debug.Trace.{traceEvent, traceEventIO}
  */
 void traceUserMsg(Capability *cap, char *msg);
 
+/*
+ * An event to record a Haskell thread's label/name
+ * Used by GHC.Conc.labelThread
+ */
+void traceThreadLabel_(Capability *cap,
+                       StgTSO     *tso,
+                       char       *label);
+
 /* 
  * Emit a debug message (only when DEBUG is defined)
  */
@@ -221,6 +230,7 @@ void traceSparkCounters_ (Capability *cap,
 #define debugTrace(class, str, ...) /* nothing */
 #define debugTraceCap(class, cap, str, ...) /* nothing */
 #define traceThreadStatus(class, tso) /* nothing */
+#define traceThreadLabel_(cap, tso, label) /* nothing */
 INLINE_HEADER void traceEventStartup_ (int n_caps STG_UNUSED) {};
 #define traceCapsetEvent_(tag, capset, info) /* nothing */
 #define traceWallClockTime_() /* nothing */
@@ -268,6 +278,8 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
     HASKELLEVENT_REQUEST_PAR_GC(cap)
 #define dtraceCreateSparkThread(cap, spark_tid)         \
     HASKELLEVENT_CREATE_SPARK_THREAD(cap, spark_tid)
+#define dtraceThreadLabel(cap, tso, label)              \
+    HASKELLEVENT_THREAD_LABEL(cap, tso, label)
 INLINE_HEADER void dtraceStartup (int num_caps) {
     HASKELLEVENT_STARTUP(num_caps);
 }
@@ -318,6 +330,7 @@ INLINE_HEADER void dtraceStartup (int num_caps) {
 #define dtraceRequestSeqGc(cap)                         /* nothing */
 #define dtraceRequestParGc(cap)                         /* nothing */
 #define dtraceCreateSparkThread(cap, spark_tid)         /* nothing */
+#define dtraceThreadLabel(cap, tso, label)              /* nothing */
 INLINE_HEADER void dtraceStartup (int num_caps STG_UNUSED) {};
 #define dtraceUserMsg(cap, msg)                         /* nothing */
 #define dtraceGcIdle(cap)                               /* nothing */
@@ -414,6 +427,16 @@ INLINE_HEADER void traceEventThreadWakeup(Capability *cap       STG_UNUSED,
                        (EventCapNo)other_cap);
 }
 
+INLINE_HEADER void traceThreadLabel(Capability *cap   STG_UNUSED,
+                                    StgTSO     *tso   STG_UNUSED,
+                                    char       *label STG_UNUSED)
+{
+    if (RTS_UNLIKELY(TRACE_sched)) {
+        traceThreadLabel_(cap, tso, label);
+    }
+    dtraceThreadLabel((EventCapNo)cap->no, (EventThreadID)tso->id, label);
+}
+
 INLINE_HEADER void traceEventGcStart(Capability *cap STG_UNUSED)
 {
     traceGcEvent(cap, EVENT_GC_START);
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index 09e12a2fa3..9547e7c788 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -62,6 +62,7 @@ char *EventDesc[] = {
   [EVENT_MIGRATE_THREAD]      = "Migrate thread",
   [EVENT_SHUTDOWN]            = "Shutdown",
   [EVENT_THREAD_WAKEUP]       = "Wakeup thread",
+  [EVENT_THREAD_LABEL]        = "Thread label",
   [EVENT_GC_START]            = "Starting GC",
   [EVENT_GC_END]              = "Finished GC",
   [EVENT_REQUEST_SEQ_GC]      = "Request sequential GC",
@@ -332,6 +333,7 @@ initEventLogging(void)
         case EVENT_RTS_IDENTIFIER:   // (capset, str)
         case EVENT_PROGRAM_ARGS:     // (capset, strvec)
         case EVENT_PROGRAM_ENV:      // (capset, strvec)
+        case EVENT_THREAD_LABEL:     // (thread, str)
             eventTypes[t].size = 0xffff;
             break;
 
@@ -791,6 +793,31 @@ void postEventStartup(EventCapNo n_caps)
     RELEASE_LOCK(&eventBufMutex);
 }
 
+void postThreadLabel(Capability    *cap,
+                     EventThreadID  id,
+                     char          *label)
+{
+    EventsBuf *eb;
+    int strsize = strlen(label);
+    int size = strsize + sizeof(EventCapsetID);
+
+    eb = &capEventBuf[cap->no];
+
+    if (!hasRoomForVariableEvent(eb, size)){
+        printAndClearEventBuf(eb);
+
+        if (!hasRoomForVariableEvent(eb, size)){
+            // Event size exceeds buffer size, bail out:
+            return;
+        }
+    }
+
+    postEventHeader(eb, EVENT_THREAD_LABEL);
+    postPayloadSize(eb, size);
+    postThreadID(eb, id);
+    postBuf(eb, (StgWord8*) label, strsize);
+}
+
 void closeBlockMarker (EventsBuf *ebuf)
 {
     StgInt8* save_pos;
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index d7368c30bf..667f34867d 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -83,6 +83,13 @@ void postSparkCountersEvent (Capability *cap,
                              SparkCounters counters,
                              StgWord remaining);
 
+/*
+ * Post an event to annotate a thread with a label
+ */
+void postThreadLabel(Capability    *cap,
+                     EventThreadID  id,
+                     char          *label);
+
 #else /* !TRACING */
 
 INLINE_HEADER void postSchedEvent (Capability *cap  STG_UNUSED,
@@ -105,6 +112,12 @@ INLINE_HEADER void postCapMsg (Capability *cap STG_UNUSED,
                                va_list ap STG_UNUSED)
 { /* nothing */ }
 
+
+INLINE_HEADER void postThreadLabel(Capability    *cap   STG_UNUSED,
+                                   EventThreadID  id    STG_UNUSED,
+                                   char          *label STG_UNUSED)
+{ /* nothing */ }
+                                   
 #endif
 
 #include "EndPrivate.h"