Commit ed26b477 authored by Ross Paterson's avatar Ross Paterson

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

parents da11a225 c739d845
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
-----------------------------------------------
......
......@@ -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 */
......
......@@ -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));
}
......
......@@ -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: */
......
......@@ -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 */
......@@ -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"
......
......@@ -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
......
......@@ -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);
......
......@@ -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;
......
......@@ -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"
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment